diff --git a/BuildClient.hs b/BuildClient.hs index be990f81a..433fcb588 100644 --- a/BuildClient.hs +++ b/BuildClient.hs @@ -11,6 +11,7 @@ import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, import Distribution.Package import Distribution.Text +import qualified Text.PrettyPrint as Disp import Distribution.Verbosity import Distribution.Simple.Utils hiding (intercalate) import Distribution.Version (Version(..)) @@ -19,10 +20,12 @@ import Data.List import Data.Maybe import Data.IORef import Data.Time +import Control.Applicative ((<$>), (<*>)) import Control.Exception import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as M import qualified Data.Set as S import qualified Codec.Compression.GZip as GZip @@ -55,7 +58,9 @@ data BuildOpts = BuildOpts { bo_dryRun :: Bool, bo_prune :: Bool, bo_username :: Maybe String, - bo_password :: Maybe String + bo_password :: Maybe String, + bo_buildAttempts :: Int + -- ^ how many times to attempt to rebuild a failing package } data BuildConfig = BuildConfig { @@ -134,6 +139,23 @@ initialise opts uri auxUris where readMissingOpt prompt = maybe (putStrLn prompt >> getLine) return + +-- | Parse the @00-index.cache@ file of the available package repositories. +parseRepositoryIndices :: IO (S.Set PackageIdentifier) +parseRepositoryIndices = do + cabalDir <- getAppUserDataDirectory "cabal/packages" + cacheDirs <- listDirectory cabalDir + indexFiles <- filterM doesFileExist $ map (\dir -> cabalDir dir "00-index.cache") cacheDirs + S.unions <$> mapM readCache indexFiles + where + readCache fname = + S.fromList . mapMaybe parseLine . lines <$> readFile fname + parseLine line + | "pkg:" : name : ver : _ <- words line + = PackageIdentifier <$> simpleParse name <*> simpleParse ver + | otherwise + = Nothing + writeConfig :: BuildOpts -> BuildConfig -> IO () writeConfig opts BuildConfig { bc_srcURI = uri, @@ -388,6 +410,11 @@ getDocumentationStats verbosity config didFail = do buildOnce :: BuildOpts -> [PackageId] -> IO () buildOnce opts pkgs = keepGoing $ do config <- readConfig opts + -- Due to caching sometimes the package repository state may lag behind the + -- documentation index. Consequently, we make sure that the packages we are + -- going to build actually appear in the repository before building. See + -- #543. + repoIndex <- parseRepositoryIndices notice verbosity "Initialising" (has_failed, mark_as_failed, persist_failed) <- mkPackageFailed opts @@ -406,6 +433,7 @@ buildOnce opts pkgs = keepGoing $ do -- Find those files *not* marked as having documentation in our cache let toBuild :: [DocInfo] toBuild = filter shouldBuild + . filter (flip S.member repoIndex . docInfoPackage) . latestFirst . map (sortBy (flip (comparing docInfoPackageVersion))) . groupBy (equating docInfoPackageName) @@ -486,9 +514,10 @@ buildOnce opts pkgs = keepGoing $ do unless (update_ec == ExitSuccess) $ die "Could not 'cabal update' from specified server" - --- Builds a little memoised function that can tell us whether a --- particular package failed to build its documentation +-- | Builds a little memoised function that can tell us whether a +-- particular package failed to build its documentation, a function to mark a +-- package as having failed, and a function to write the final failed list back +-- to disk. mkPackageFailed :: BuildOpts -> IO (PackageId -> IO Bool, PackageId -> IO (), IO ()) mkPackageFailed opts = do @@ -496,22 +525,33 @@ mkPackageFailed opts = do cache_var <- newIORef init_failed let mark_as_failed pkg_id = atomicModifyIORef cache_var $ \already_failed -> - (S.insert pkg_id already_failed, ()) - has_failed pkg_id = liftM (pkg_id `S.member`) $ readIORef cache_var + (M.insertWith (+) pkg_id 1 already_failed, ()) + has_failed pkg_id = f <$> readIORef cache_var + where f cache = M.findWithDefault 0 pkg_id cache > bo_buildAttempts opts persist = readIORef cache_var >>= writeFailedCache (bo_stateDir opts) return (has_failed, mark_as_failed, persist) where - readFailedCache :: FilePath -> IO (S.Set PackageId) + readFailedCache :: FilePath -> IO (M.Map PackageId Int) readFailedCache cache_dir = do pkgstrs <- handleDoesNotExist [] $ liftM lines $ readFile (cache_dir "failed") - case validatePackageIds pkgstrs of + let (pkgids, attempts) = unzip $ map (parseLine . words) pkgstrs + where + parseLine [pkg_id] = (pkg_id, 1) + parseLine [pkg_id, attempts'] + | [(n,_)] <- reads attempts' = (pkg_id, n) + | otherwise = (pkg_id, 1) + parseLine other = error $ "failed to parse failed list line: "++show other + case validatePackageIds pkgids of Left theError -> die theError - Right pkgs -> return (S.fromList pkgs) + Right pkgs -> return (M.fromList $ zip pkgs attempts) - writeFailedCache :: FilePath -> S.Set PackageId -> IO () + writeFailedCache :: FilePath -> M.Map PackageId Int -> IO () writeFailedCache cache_dir pkgs = - writeFile (cache_dir "failed") $ unlines $ map display $ S.toList pkgs + writeFile (cache_dir "failed") + $ unlines + $ map (\(pkgid,n) -> show $ disp pkgid Disp.<+> disp n) + $ M.assocs pkgs -- | Build documentation and return @(Just tgz)@ for the built tgz file @@ -778,7 +818,8 @@ data BuildFlags = BuildFlags { flagInterval :: Maybe String, flagPrune :: Bool, flagUsername :: Maybe String, - flagPassword :: Maybe String + flagPassword :: Maybe String, + flagBuildAttempts :: Maybe Int } emptyBuildFlags :: BuildFlags @@ -795,6 +836,7 @@ emptyBuildFlags = BuildFlags { , flagPrune = False , flagUsername = Nothing , flagPassword = Nothing + , flagBuildAttempts = Nothing } buildFlagDescrs :: [OptDescr (BuildFlags -> BuildFlags)] @@ -848,6 +890,12 @@ buildFlagDescrs = , Option [] ["init-password"] (ReqArg (\passwd opts -> opts { flagPassword = Just passwd }) "PASSWORD") "The password of the Hackage user to run the build as (used with init)" + + , Option [] ["build-attempts"] + (ReqArg (\attempts opts -> case reads attempts of + [(attempts', "")] -> opts { flagBuildAttempts = Just attempts' } + _ -> error "Can't parse attempt count") "ATTEMPTS") + "How many times to attempt to build a package before giving up" ] validateOpts :: [String] -> IO (Mode, BuildOpts) @@ -869,7 +917,8 @@ validateOpts args = do bo_dryRun = flagDryRun flags, bo_prune = flagPrune flags, bo_username = flagUsername flags, - bo_password = flagPassword flags + bo_password = flagPassword flags, + bo_buildAttempts = fromMaybe 10 $ flagBuildAttempts flags } mode = case args' of diff --git a/hackage-server.cabal b/hackage-server.cabal index 821a04528..7b4d9f980 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -431,7 +431,7 @@ executable hackage-build build-depends: base, containers, array, vector, bytestring, text, pretty, - filepath, directory, process >= 1.0, + filepath, directory >= 1.2.5, process >= 1.0, time, time-locale-compat >= 0.1.0.1, tar, zlib,