Support keep going on fetch failure (#115)

README.md

@@ -106,7 +106,7 @@ To run nvfetcher as a CLI program, you'll need to provide package sources define
 Usage: nvfetcher [--version] [--help] [-o|--build-dir DIR] [--commit-changes] 
                  [-l|--changelog FILE] [-j NUM] [-r|--retry NUM] [-t|--timing] 
                  [-v|--verbose] [-f|--filter REGEX] [-k|--keyfile FILE] 
-                 [--keep-old] [TARGET] [-c|--config FILE]
+                 [--keep-old] [--keep-going] [TARGET] [-c|--config FILE]
 
   generate nix sources expr for the latest version of packages
 
@@ -128,6 +128,7 @@ Available options:
   -k,--keyfile FILE        Nvchecker keyfile
   --keep-old               Don't remove old files other than generated json and
                            nix before build
+  --keep-going             Don't stop if some packages failed to be fetched
   TARGET                   Three targets are available: 1.build 2.clean (remove
                            all generated files) 3.purge (remove shake db)
                            (default: build)

src/NvFetcher.hs

@@ -57,9 +57,9 @@ import qualified Data.Aeson.Encode.Pretty as A
 import qualified Data.Aeson.Types as A
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import Data.Default
-import Data.List ((\\))
+import Data.List (partition, (\\))
 import qualified Data.Map.Strict as Map
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Development.Shake
@@ -114,7 +114,8 @@ applyCliOptions config CLIOptions {..} = do
         filterRegex = optPkgNameFilter,
         retry = optRetry,
         keyfile = aKeyfile,
-        keepOldFiles = optKeepOldFiles
+        keepOldFiles = optKeepOldFiles,
+        keepGoing = optKeepGoing
       }
 
 logChangesToFile :: FilePath -> Action ()
@@ -199,10 +200,12 @@ mainRules Config {..} = do
         putVerbose $ "Removing old files: " <> show oldFiles
         liftIO $ removeFiles buildDir oldFiles
     allKeys <- getAllPackageKeys
-    results <- parallel $ runPackage <$> allKeys
+    results <- fmap (zip allKeys) $ parallel $ runPackage <$> allKeys
+    let (fmap (fromJust . snd) -> successResults, fmap fst -> failureKeys) = partition (isJust . snd) results
     -- Record removed packages to version changes
+    -- Failure keys are also considered as removed in this run
     getAllOnDiskVersions
-      >>= \oldPkgs -> forM_ (Map.keys oldPkgs \\ allKeys) $
+      >>= \oldPkgs -> forM_ (Map.keys oldPkgs \\ (allKeys \\ failureKeys)) $
         \pkg -> recordVersionChange (coerce pkg) (oldPkgs Map.!? pkg) "∅"
     getVersionChanges >>= \changes ->
       if null changes
@@ -214,9 +217,9 @@ mainRules Config {..} = do
     let generatedNixPath = buildDir </> generatedNixFileName
         generatedJSONPath = buildDir </> generatedJsonFileName
     putVerbose $ "Generating " <> generatedNixPath
-    writeFileChanged generatedNixPath $ T.unpack $ srouces (T.unlines $ toNixExpr <$> results) <> "\n"
+    writeFileChanged generatedNixPath $ T.unpack $ srouces (T.unlines $ toNixExpr <$> successResults) <> "\n"
     putVerbose $ "Generating " <> generatedJSONPath
-    writeFileChanged generatedJSONPath $ LBS.unpack $ A.encodePretty $ A.object [aesonKey (_prname r) A..= r | r <- results]
+    writeFileChanged generatedJSONPath $ LBS.unpack $ A.encodePretty $ A.object [aesonKey (_prname r) A..= r | r <- successResults]
     actionAfterBuild
 
   customRules

src/NvFetcher/Config.hs

@@ -20,7 +20,9 @@ data Config = Config
     cacheNvchecker :: Bool,
     keepOldFiles :: Bool,
     -- | Absolute path
-    keyfile :: Maybe FilePath
+    keyfile :: Maybe FilePath,
+    -- | When set to 'True', nvfetcher will keep going even if some packages failed to /fetch/
+    keepGoing :: Bool
   }
 
 instance Default Config where
@@ -29,7 +31,8 @@ instance Default Config where
       { shakeConfig =
           shakeOptions
             { shakeProgress = progressSimple,
-              shakeThreads = 0
+              shakeThreads = 0,
+              shakeVersion = "1"
             },
         buildDir = "_sources",
         customRules = pure (),
@@ -39,5 +42,6 @@ instance Default Config where
         filterRegex = Nothing,
         cacheNvchecker = True,
         keepOldFiles = False,
-        keyfile = Nothing
+        keyfile = Nothing,
+        keepGoing = False
       }

src/NvFetcher/Core.hs

@@ -43,7 +43,7 @@ coreRules = do
     -- since the package definition is not tracked at all
     alwaysRerun
     lookupPackage pkg >>= \case
-      Nothing -> fail $ "Unkown package key: " <> show pkg
+      Nothing -> fail $ "Unknown package key: " <> show pkg
       Just
         Package
           { _pversion = CheckVersion versionSource options,
@@ -52,71 +52,75 @@ coreRules = do
           } -> do
           _prversion@(NvcheckerResult version _mOldV _isStale) <- checkVersion versionSource options pkg
           _prfetched <- prefetch (_pfetcher version) _pforcefetch
-          buildDir <- getBuildDir
-          -- extract src
-          _prextract <-
-            case _pextract of
-              Just (PackageExtractSrc extract) -> do
-                result <- HMap.toList <$> extractSrcs _prfetched extract
-                Just . HMap.fromList
-                  <$> sequence
-                    [ do
-                        -- write extracted files to build dir
-                        -- and read them in nix using 'builtins.readFile'
-                        writeFile' (buildDir </> path) (T.unpack v)
-                        pure (k, T.pack path)
-                      | (k, v) <- result,
-                        let path =
-                              "./"
-                                <> T.unpack _pname
+          -- If we fail to prefetch, we should fail on this package
+          case _prfetched of
+            Just _prfetched -> do
+              buildDir <- getBuildDir
+              -- extract src
+              _prextract <-
+                case _pextract of
+                  Just (PackageExtractSrc extract) -> do
+                    result <- HMap.toList <$> extractSrcs _prfetched extract
+                    Just . HMap.fromList
+                      <$> sequence
+                        [ do
+                            -- write extracted files to build dir
+                            -- and read them in nix using 'builtins.readFile'
+                            writeFile' (buildDir </> path) (T.unpack v)
+                            pure (k, T.pack path)
+                          | (k, v) <- result,
+                            let path =
+                                  "./"
+                                    <> T.unpack _pname
+                                    <> "-"
+                                    <> T.unpack (coerce version)
+                                    </> k
+                        ]
+                  _ -> pure Nothing
+              -- cargo locks
+              _prcargolock <-
+                case _pcargo of
+                  Just (PackageCargoLockFiles lockPath) -> do
+                    lockFiles <- HMap.toList <$> extractSrcs _prfetched lockPath
+                    result <- parallel $
+                      flip fmap lockFiles $ \(lockPath, lockData) -> do
+                        result <- fetchRustGitDeps _prfetched lockPath
+                        let lockPath' =
+                              T.unpack _pname
                                 <> "-"
                                 <> T.unpack (coerce version)
-                                </> k
-                    ]
-              _ -> pure Nothing
-          -- cargo locks
-          _prcargolock <-
-            case _pcargo of
-              Just (PackageCargoLockFiles lockPath) -> do
-                lockFiles <- HMap.toList <$> extractSrcs _prfetched lockPath
-                result <- parallel $
-                  flip fmap lockFiles $ \(lockPath, lockData) -> do
-                    result <- fetchRustGitDeps _prfetched lockPath
-                    let lockPath' =
-                          T.unpack _pname
-                            <> "-"
-                            <> T.unpack (coerce version)
-                            </> lockPath
-                        lockPathNix = "./" <> T.pack lockPath'
-                    -- similar to extract src, write lock file to build dir
-                    writeFile' (buildDir </> lockPath') $ T.unpack lockData
-                    pure (lockPath, (lockPathNix, result))
-                pure . Just $ HMap.fromList result
-              _ -> pure Nothing
+                                </> lockPath
+                            lockPathNix = "./" <> T.pack lockPath'
+                        -- similar to extract src, write lock file to build dir
+                        writeFile' (buildDir </> lockPath') $ T.unpack lockData
+                        pure (lockPath, (lockPathNix, result))
+                    pure . Just $ HMap.fromList result
+                  _ -> pure Nothing
 
-          -- Only git version source supports git commit date
-          _prgitdate <- case versionSource of
-            Git {..} -> Just <$> getGitCommitDate _vurl (coerce version) _pgitdateformat
-            _ -> pure Nothing
+              -- Only git version source supports git commit date
+              _prgitdate <- case versionSource of
+                Git {..} -> Just <$> getGitCommitDate _vurl (coerce version) _pgitdateformat
+                _ -> pure Nothing
 
-          -- update changelog
-          -- always use on disk version
-          mOldV <- getLastVersionOnDisk pkg
-          case mOldV of
-            Nothing ->
-              recordVersionChange _pname Nothing version
-            Just old
-              | old /= version ->
-                recordVersionChange _pname (Just old) version
-            _ -> pure ()
+              -- update changelog
+              -- always use on disk version
+              mOldV <- getLastVersionOnDisk pkg
+              case mOldV of
+                Nothing ->
+                  recordVersionChange _pname Nothing version
+                Just old
+                  | old /= version ->
+                      recordVersionChange _pname (Just old) version
+                _ -> pure ()
 
-          let _prpassthru = if HMap.null passthru then Nothing else Just passthru
-              _prname = _pname
-              _prpinned = _ppinned
-          -- Since we don't save the previous result, we are not able to know if the result changes
-          -- Depending on this rule leads to RunDependenciesChanged
-          pure $ RunResult ChangedRecomputeDiff mempty PackageResult {..}
+              let _prpassthru = if HMap.null passthru then Nothing else Just passthru
+                  _prname = _pname
+                  _prpinned = _ppinned
+              -- Since we don't save the previous result, we are not able to know if the result changes
+              -- Depending on this rule leads to RunDependenciesChanged
+              pure $ RunResult ChangedRecomputeDiff mempty $ Just PackageResult {..}
+            _ -> pure $ RunResult ChangedRecomputeDiff mempty Nothing
 
 -- | 'Core' rule take a 'PackageKey', find the corresponding 'Package', and run all needed rules to get 'PackageResult'
-runPackage :: PackageKey -> Action PackageResult
+runPackage :: PackageKey -> Action (Maybe PackageResult)
 runPackage k = apply1 $ WithPackageKey (Core, k)

src/NvFetcher/FetchRustGitDeps.hs

@@ -24,6 +24,7 @@ module NvFetcher.FetchRustGitDeps
 where
 
 import Control.Monad (void)
+import Control.Monad.Extra (fromMaybeM)
 import Data.Binary.Instances ()
 import Data.Coerce (coerce)
 import Data.HashMap.Strict (HashMap)
@@ -54,7 +55,7 @@ fetchRustGitDepsRule = void $
       parallel
         [ case parse gitSrcParser (T.unpack rname) src of
             Right ParsedGitSrc {..} -> do
-              (_sha256 -> sha256) <- prefetch (gitFetcher pgurl pgsha) NoForceFetch
+              (_sha256 -> sha256) <- fromMaybeM (fail $ "Prefetch failed for " <> T.unpack pgurl) $ prefetch (gitFetcher pgurl pgsha) NoForceFetch
               -- @${name}-${version}@ -> sha256
               pure (rname <> "-" <> coerce rversion, sha256)
             Left err -> fail $ "Failed to parse git source in Cargo.lock: " <> show err

src/NvFetcher/NixFetcher.hs

@@ -55,6 +55,7 @@ module NvFetcher.NixFetcher
   )
 where
 
+import Control.Exception (ErrorCall)
 import Control.Monad (void, when)
 import qualified Data.Aeson as A
 import Data.Coerce (coerce)
@@ -168,10 +169,17 @@ prefetchRule = void $
   addOracleCache $ \(RunFetch force f) -> do
     when (force == ForceFetch) alwaysRerun
     putInfo . show $ "#" <+> pretty f
-    withRetry $ runFetcher f
+    keepGoing <- nvcheckerKeepGoing
+    if keepGoing
+      then -- If fetch failed, always rerun and return Nothing
+      actionCatch (fmap Just <$> withRetry $ runFetcher f) $ \(e :: ErrorCall) -> do
+        alwaysRerun
+        putError $ show e <> "\nKeep going..."
+        pure Nothing
+      else fmap Just <$> withRetry $ runFetcher f
 
 -- | Run nix fetcher
-prefetch :: NixFetcher Fresh -> ForceFetch -> Action (NixFetcher Fetched)
+prefetch :: NixFetcher Fresh -> ForceFetch -> Action (Maybe (NixFetcher Fetched))
 prefetch f force = askOracle $ RunFetch force f
 
 --------------------------------------------------------------------------------

src/NvFetcher/Options.hs

@@ -46,6 +46,7 @@ data CLIOptions = CLIOptions
     optPkgNameFilter :: Maybe String,
     optKeyfile :: Maybe FilePath,
     optKeepOldFiles :: Bool,
+    optKeepGoing :: Bool,
     optTarget :: Target
   }
   deriving (Show)
@@ -112,6 +113,7 @@ cliOptionsParser =
           )
       )
     <*> switch (long "keep-old" <> help "Don't remove old files other than generated json and nix before build")
+    <*> switch (long "keep-going" <> help "Don't stop if some packages failed to be fetched")
     <*> argument
       targetParser
       ( metavar "TARGET"

src/NvFetcher/Types.hs

@@ -383,7 +383,8 @@ instance Default ForceFetch where
 data RunFetch = RunFetch ForceFetch (NixFetcher Fresh)
   deriving (Show, Eq, Ord, Hashable, NFData, Binary, Typeable, Generic)
 
-type instance RuleResult RunFetch = NixFetcher Fetched
+-- Prefetch rule never throws exceptions
+type instance RuleResult RunFetch = Maybe (NixFetcher Fetched)
 
 -- | If the package is prefetched, then we can obtain the SHA256
 data NixFetcher (k :: FetchStatus)
@@ -702,7 +703,8 @@ newtype PackageKey = PackageKey PackageName
 data Core = Core
   deriving (Eq, Show, Ord, Typeable, Generic, Hashable, Binary, NFData)
 
-type instance RuleResult Core = PackageResult
+-- If prefetch fails, we don't want to fail the whole build
+type instance RuleResult Core = Maybe PackageResult
 
 -- | Decorate a rule's key with 'PackageKey'
 newtype WithPackageKey k = WithPackageKey (k, PackageKey)

src/NvFetcher/Types/ShakeExtras.hs

@@ -40,8 +40,9 @@ module NvFetcher.Types.ShakeExtras
     getAllOnDiskVersions,
     getLastVersionUpdated,
 
-    -- * Cache nvchecker
+    -- * Booleans
     nvcheckerCacheEnabled,
+    nvcheckerKeepGoing,
   )
 where
 
@@ -175,3 +176,7 @@ getAllOnDiskVersions = do
 -- | Get if 'cacheNvchecker' is enabled
 nvcheckerCacheEnabled :: Action Bool
 nvcheckerCacheEnabled = cacheNvchecker . config <$> getShakeExtras
+
+-- | Get if 'keepGoing' is enabled
+nvcheckerKeepGoing :: Action Bool
+nvcheckerKeepGoing = keepGoing . config <$> getShakeExtras

test/FetchRustGitDepsSpec.hs

@@ -3,6 +3,7 @@
 
 module FetchRustGitDepsSpec where
 
+import Control.Monad (join)
 import Control.Monad.Trans.Reader
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HMap
@@ -30,7 +31,7 @@ spec = aroundShake $
           ]
 
 runPrefetchRule :: NixFetcher Fresh -> ReaderT ActionQueue IO (Maybe (NixFetcher Fetched))
-runPrefetchRule fetcher = runActionChan $ prefetch fetcher NoForceFetch
+runPrefetchRule fetcher = fmap join $ runActionChan $ prefetch fetcher NoForceFetch
 
 runFetchRustGitDepsRule :: NixFetcher Fetched -> FilePath -> ReaderT ActionQueue IO (Maybe (HashMap Text Checksum))
 runFetchRustGitDepsRule fetcher lockPath = runActionChan $ fetchRustGitDeps fetcher lockPath

test/PrefetchSpec.hs

@@ -4,6 +4,7 @@
 module PrefetchSpec where
 
 import Control.Arrow ((&&&))
+import Control.Monad (join)
 import Control.Monad.Trans.Reader
 import NvFetcher.NixFetcher
 import NvFetcher.Types
@@ -72,4 +73,4 @@ runPrefetchRule :: NixFetcher Fresh -> ReaderT ActionQueue IO (Maybe Checksum)
 runPrefetchRule = runPrefetchRule' _sha256
 
 runPrefetchRule' :: (NixFetcher Fetched -> a) -> NixFetcher Fresh -> ReaderT ActionQueue IO (Maybe a)
-runPrefetchRule' g f = runActionChan $ g <$> prefetch f NoForceFetch
+runPrefetchRule' g f = fmap join $ runActionChan $ prefetch f NoForceFetch >>= \m -> pure $ g <$> m