Merge pull request #544 from bgamari/doc-builder-retry

BuildClient: Add simple retry policy for failed doc builds

Author: bgamari

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,32 +514,44 @@ 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
     init_failed <- readFailedCache (bo_stateDir opts)
     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

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,