From 873b1971318d0440e2d5614357d1dd70cd56eb75 Mon Sep 17 00:00:00 2001 From: Martin Lavoie Date: Sun, 19 Sep 2021 17:27:23 +0200 Subject: [PATCH 1/2] Prefetch github dependencies - Add the source name as a parameter to the Update arrow - Add a test to check that the prefetch worked --- src/Niv/Cli.hs | 12 ++++++------ src/Niv/Cmd.hs | 2 +- src/Niv/Git/Cmd.hs | 6 +++--- src/Niv/Git/Test.hs | 20 ++++++++++++-------- src/Niv/GitHub.hs | 9 +++++---- src/Niv/GitHub/Cmd.hs | 10 +++++----- src/Niv/GitHub/Test.hs | 41 +++++++++++++++++++++++----------------- src/Niv/Local/Cmd.hs | 2 +- src/Niv/Update.hs | 18 +++++++++--------- src/Niv/Update/Test.hs | 21 ++++++++++---------- tests/github/default.nix | 16 +++++++++++++++- 11 files changed, 92 insertions(+), 65 deletions(-) diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index 988a932..5137c8e 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -358,7 +358,7 @@ cmdAdd cmd packageName attrs = do when (HMS.member packageName sources) $ li $ abortCannotAddPackageExists packageName - eFinalSpec <- fmap attrsToSpec <$> li (doUpdate attrs cmd) + eFinalSpec <- fmap attrsToSpec <$> li (doUpdate packageName attrs cmd) case eFinalSpec of Left e -> li (abortUpdateFailed [(packageName, e)]) Right finalSpec -> do @@ -447,7 +447,7 @@ cmdUpdate = \case Just "local" -> localCmd _ -> githubCmd spec = specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec - fmap attrsToSpec <$> li (doUpdate spec cmd) + fmap attrsToSpec <$> li (doUpdate packageName spec cmd) Nothing -> li $ abortCannotUpdateNoSuchPackage packageName case eFinalSpec of Left e -> li $ abortUpdateFailed [(packageName, e)] @@ -469,7 +469,7 @@ cmdUpdate = \case Just "git" -> gitCmd Just "local" -> localCmd _ -> githubCmd - finalSpec <- fmap attrsToSpec <$> li (doUpdate initialSpec cmd) + finalSpec <- fmap attrsToSpec <$> li (doUpdate packageName initialSpec cmd) pure finalSpec let (failed, sources') = partitionEithersHMS esources' unless (HMS.null failed) $ @@ -478,10 +478,10 @@ cmdUpdate = \case li $ setSources fsj $ Sources sources' -- | pretty much tryEvalUpdate but we might issue some warnings first -doUpdate :: Attrs -> Cmd -> IO (Either SomeException Attrs) -doUpdate attrs cmd = do +doUpdate :: PackageName -> Attrs -> Cmd -> IO (Either SomeException Attrs) +doUpdate packageName attrs cmd = do forM_ (extraLogs cmd attrs) $ tsay - tryEvalUpdate attrs (updateCmd cmd) + tryEvalUpdate packageName attrs (updateCmd cmd) partitionEithersHMS :: (Eq k, Hashable k) => diff --git a/src/Niv/Cmd.hs b/src/Niv/Cmd.hs index 4d3df51..00ddab5 100644 --- a/src/Niv/Cmd.hs +++ b/src/Niv/Cmd.hs @@ -13,7 +13,7 @@ data Cmd = Cmd { description :: forall a. Opts.InfoMod a, parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object), parsePackageSpec :: Opts.Parser PackageSpec, - updateCmd :: Update () (), + updateCmd :: Update PackageName (), name :: T.Text, -- | Some notes to print extraLogs :: Attrs -> [T.Text] diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs index 2d52906..f91cfbe 100644 --- a/src/Niv/Git/Cmd.hs +++ b/src/Niv/Git/Cmd.hs @@ -141,8 +141,8 @@ gitUpdate :: (T.Text -> T.Text -> IO T.Text) -> -- | latest rev and default ref (T.Text -> IO (T.Text, T.Text)) -> - Update () () -gitUpdate latestRev' defaultBranchAndRev' = proc () -> do + Update PackageName () +gitUpdate latestRev' defaultBranchAndRev' = proc _packageName -> do useOrSet "type" -< ("git" :: Box T.Text) repository <- load "repo" -< () discoverRev <+> discoverRefAndRev -< repository @@ -159,7 +159,7 @@ gitUpdate latestRev' defaultBranchAndRev' = proc () -> do returnA -< () -- | The "real" (IO) update -gitUpdate' :: Update () () +gitUpdate' :: Update PackageName () gitUpdate' = gitUpdate latestRev defaultBranchAndRev latestRev :: diff --git a/src/Niv/Git/Test.hs b/src/Niv/Git/Test.hs index 2c93027..3abe9f8 100644 --- a/src/Niv/Git/Test.hs +++ b/src/Niv/Git/Test.hs @@ -56,11 +56,13 @@ test_gitUpdates = test_gitUpdateRev :: IO () test_gitUpdateRev = do - interState <- evalUpdate initialState $ proc () -> - gitUpdate (error "should be def") defaultBranchAndHEAD' -< () + interState <- + evalUpdate (PackageName "Test") initialState $ + gitUpdate (error "should be def") defaultBranchAndHEAD' let interState' = HMS.map (first (\_ -> Free)) interState - actualState <- evalUpdate interState' $ proc () -> - gitUpdate latestRev' (error "should update") -< () + actualState <- + evalUpdate (PackageName "Test") interState' $ + gitUpdate latestRev' (error "should update") unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState @@ -106,11 +108,13 @@ test_gitCalledOnce :: IO () test_gitCalledOnce = do defaultBranchAndHEAD'' <- once1 defaultBranchAndHEAD' latestRev'' <- once2 latestRev' - interState <- evalUpdate initialState $ proc () -> - gitUpdate (error "should be def") defaultBranchAndHEAD'' -< () + interState <- + evalUpdate (PackageName "Test") initialState $ + gitUpdate (error "should be def") defaultBranchAndHEAD'' let interState' = HMS.map (first (\_ -> Free)) interState - actualState <- evalUpdate interState' $ proc () -> - gitUpdate latestRev'' (error "should update") -< () + actualState <- + evalUpdate (PackageName "Test") interState' $ + gitUpdate latestRev'' (error "should update") unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs index 0c01f26..3896de5 100644 --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -12,6 +12,7 @@ import Data.Bool import Data.Maybe import qualified Data.Text as T import Niv.GitHub.API +import Niv.Sources import Niv.Update -- | The GitHub update function @@ -22,13 +23,13 @@ import Niv.Update -- * ... ? githubUpdate :: -- | prefetch - (Bool -> T.Text -> IO T.Text) -> + (Bool -> PackageName -> T.Text -> IO T.Text) -> -- | latest revision (T.Text -> T.Text -> T.Text -> IO T.Text) -> -- | get repo (T.Text -> T.Text -> IO GithubRepo) -> - Update () () -githubUpdate prefetch latestRev ghRepo = proc () -> do + Update PackageName () +githubUpdate prefetch latestRev ghRepo = proc packageName -> do urlTemplate <- template <<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") @@ -38,7 +39,7 @@ githubUpdate prefetch latestRev ghRepo = proc () -> do let isTarGuess = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> url type' <- useOrSet "type" -< bool "file" "tarball" <$> isTarGuess :: Box T.Text let doUnpack = (== "tarball") <$> type' - _sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url + _sha256 <- update "sha256" <<< run (\(up, p, u) -> prefetch up p u) -< (,,) <$> doUnpack <*> pure packageName <*> url returnA -< () where completeSpec :: Update () (Box T.Text) diff --git a/src/Niv/GitHub/Cmd.hs b/src/Niv/GitHub/Cmd.hs index 9fc2556..d04806a 100644 --- a/src/Niv/GitHub/Cmd.hs +++ b/src/Niv/GitHub/Cmd.hs @@ -152,20 +152,20 @@ parseAddShortcutGitHub str = _ -> Just (PackageName str, HMS.empty) -- | The IO (real) github update -githubUpdate' :: Update () () +githubUpdate' :: Update PackageName () githubUpdate' = githubUpdate nixPrefetchURL githubLatestRev githubRepo -nixPrefetchURL :: Bool -> T.Text -> IO T.Text -nixPrefetchURL unpack turl@(T.unpack -> url) = do +nixPrefetchURL :: Bool -> PackageName -> T.Text -> IO T.Text +nixPrefetchURL unpack packageName (T.unpack -> url) = do (exitCode, sout, serr) <- runNixPrefetch case (exitCode, lines sout) of (ExitSuccess, l : _) -> pure $ T.pack l _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) where - args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename] + args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename <> "-src"] runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" sanitizeName = T.unpack . T.filter isOk - basename = last $ T.splitOn "/" turl + basename = unPackageName packageName -- From the nix-prefetch-url documentation: -- Path names are alphanumeric and can include the symbols +-._?= and must -- not begin with a period. diff --git a/src/Niv/GitHub/Test.hs b/src/Niv/GitHub/Test.hs index 438ef3c..1eeb0cc 100644 --- a/src/Niv/GitHub/Test.hs +++ b/src/Niv/GitHub/Test.hs @@ -10,17 +10,19 @@ import qualified Data.HashMap.Strict as HMS import Data.IORef import Niv.GitHub import Niv.GitHub.API +import Niv.Sources import Niv.Update test_githubInitsProperly :: IO () test_githubInitsProperly = do - actualState <- evalUpdate initialState $ proc () -> - githubUpdate prefetch latestRev ghRepo -< () + actualState <- + evalUpdate (PackageName "Test") initialState $ + githubUpdate prefetch latestRev ghRepo unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState where - prefetch _ _ = pure "some-sha" + prefetch _ _ _ = pure "some-sha" latestRev _ _ _ = pure "some-rev" ghRepo _ _ = pure @@ -50,13 +52,14 @@ test_githubInitsProperly = do test_githubUpdates :: IO () test_githubUpdates = do - actualState <- evalUpdate initialState $ proc () -> - githubUpdate prefetch latestRev ghRepo -< () + actualState <- + evalUpdate (PackageName "Test") initialState $ + githubUpdate prefetch latestRev ghRepo unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState where - prefetch _ _ = pure "new-sha" + prefetch _ _ _ = pure "new-sha" latestRev _ _ _ = pure "new-rev" ghRepo _ _ = pure @@ -94,13 +97,14 @@ test_githubUpdates = do test_githubDoesntOverrideRev :: IO () test_githubDoesntOverrideRev = do - actualState <- evalUpdate initialState $ proc () -> - githubUpdate prefetch latestRev ghRepo -< () + actualState <- + evalUpdate (PackageName "Test") initialState $ + githubUpdate prefetch latestRev ghRepo unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState where - prefetch _ _ = pure "new-sha" + prefetch _ _ _ = pure "new-sha" latestRev _ _ _ = error "shouldn't fetch rev" ghRepo _ _ = error "shouldn't fetch repo" initialState = @@ -133,13 +137,14 @@ test_githubDoesntOverrideRev = do -- TODO: HMS diff for test output test_githubURLFallback :: IO () test_githubURLFallback = do - actualState <- evalUpdate initialState $ proc () -> - githubUpdate prefetch latestRev ghRepo -< () + actualState <- + evalUpdate (PackageName "Test") initialState $ + githubUpdate prefetch latestRev ghRepo unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState where - prefetch _ _ = pure "some-sha" + prefetch _ _ _ = pure "some-sha" latestRev _ _ _ = error "shouldn't fetch rev" ghRepo _ _ = error "shouldn't fetch repo" initialState = @@ -159,20 +164,22 @@ test_githubURLFallback = do test_githubUpdatesOnce :: IO () test_githubUpdatesOnce = do ioref <- newIORef False - tmpState <- evalUpdate initialState $ proc () -> - githubUpdate (prefetch ioref) latestRev ghRepo -< () + tmpState <- + evalUpdate (PackageName "Test") initialState $ + githubUpdate (prefetch ioref) latestRev ghRepo unless ((snd <$> tmpState) == expectedState) $ error $ "State mismatch: " <> show tmpState -- Set everything free let tmpState' = HMS.map (first (\_ -> Free)) tmpState - actualState <- evalUpdate tmpState' $ proc () -> - githubUpdate (prefetch ioref) latestRev ghRepo -< () + actualState <- + evalUpdate (PackageName "Text") tmpState' $ + githubUpdate (prefetch ioref) latestRev ghRepo unless ((snd <$> actualState) == expectedState) $ error $ "State mismatch: " <> show actualState where - prefetch ioref _ _ = do + prefetch ioref _ _ _ = do readIORef ioref >>= \case False -> pure () True -> error "Prefetch should be called once!" diff --git a/src/Niv/Local/Cmd.hs b/src/Niv/Local/Cmd.hs index 087c209..1412e9a 100644 --- a/src/Niv/Local/Cmd.hs +++ b/src/Niv/Local/Cmd.hs @@ -24,7 +24,7 @@ localCmd = { description = describeLocal, parseCmdShortcut = parseLocalShortcut, parsePackageSpec = parseLocalPackageSpec, - updateCmd = proc () -> do + updateCmd = proc _packageName -> do useOrSet "type" -< ("local" :: Box T.Text) returnA -< (), name = "local", diff --git a/src/Niv/Update.hs b/src/Niv/Update.hs index dae09d3..9786b8b 100644 --- a/src/Niv/Update.hs +++ b/src/Niv/Update.hs @@ -69,12 +69,12 @@ instance Show (Update b c) where data Compose a c = forall b. Compose' (Update b c) (Update a b) -- | Run an 'Update' and return the new attributes and result. -runUpdate :: Attrs -> Update () a -> IO (Attrs, a) -runUpdate (attrs) a = boxAttrs attrs >>= flip runUpdate' a >>= feed +runUpdate :: a -> Attrs -> Update a b -> IO (Attrs, b) +runUpdate a attrs updateArr = boxAttrs attrs >>= flip runUpdate' updateArr >>= feed where feed = \case UpdateReady res -> hndl res - UpdateNeedMore next -> next (()) >>= hndl + UpdateNeedMore next -> next (a) >>= hndl hndl = \case UpdateSuccess f v -> (,v) <$> unboxAttrs f UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e) @@ -89,14 +89,14 @@ runUpdate (attrs) a = boxAttrs attrs >>= flip runUpdate' a >>= feed "with keys: " <> T.intercalate ", " keys ] -execUpdate :: Attrs -> Update () a -> IO a -execUpdate attrs a = snd <$> runUpdate attrs a +execUpdate :: a -> Attrs -> Update a b -> IO b +execUpdate a attrs updateArr = snd <$> runUpdate a attrs updateArr -evalUpdate :: Attrs -> Update () a -> IO Attrs -evalUpdate attrs a = fst <$> runUpdate attrs a +evalUpdate :: a -> Attrs -> Update a b -> IO Attrs +evalUpdate a attrs updateArr = fst <$> runUpdate a attrs updateArr -tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs) -tryEvalUpdate attrs upd = tryAny (evalUpdate attrs upd) +tryEvalUpdate :: a -> Attrs -> Update a b -> IO (Either SomeException Attrs) +tryEvalUpdate a attrs updateArr = tryAny (evalUpdate a attrs updateArr) type JSON a = (ToJSON a, FromJSON a) diff --git a/src/Niv/Update/Test.hs b/src/Niv/Update/Test.hs index a618f5b..a561767 100644 --- a/src/Niv/Update/Test.hs +++ b/src/Niv/Update/Test.hs @@ -13,7 +13,7 @@ import Niv.Update simplyRuns :: IO () simplyRuns = void $ - runUpdate attrs $ proc () -> do + runUpdate () attrs $ proc () -> do returnA -< () where attrs = HMS.empty @@ -21,7 +21,7 @@ simplyRuns = picksFirst :: IO () picksFirst = do v <- - execUpdate HMS.empty $ + execUpdate () HMS.empty $ let l = proc () -> do returnA -< 2 r = proc () -> do @@ -31,7 +31,7 @@ picksFirst = do loads :: IO () loads = do - v <- execUpdate attrs $ load "foo" + v <- execUpdate () attrs $ load "foo" v' <- runBox v unless (v' == ("bar" :: T.Text)) (error "bad value") where @@ -39,7 +39,7 @@ loads = do survivesChecks :: IO () survivesChecks = do - v <- execUpdate attrs $ proc () -> do + v <- execUpdate () attrs $ proc () -> do (sawLeft <+> sawRight) -< () load "res" -< () v' <- runBox v @@ -68,15 +68,15 @@ isNotTooEager = do let f1 = proc () -> do run (const $ error "IO is too eager (f1)") -< pure () useOrSet "foo" -< "foo" - void $ (execUpdate attrs f :: IO (Box T.Text)) - void $ (execUpdate attrs f1 :: IO (Box T.Text)) + void $ (execUpdate () attrs f :: IO (Box T.Text)) + void $ (execUpdate () attrs f1 :: IO (Box T.Text)) where attrs = HMS.singleton "foo" (Locked, "right") dirtyForcesUpdate :: IO () dirtyForcesUpdate = do let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello" - attrs' <- evalUpdate attrs f + attrs' <- evalUpdate () attrs f unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $ error $ "bad value for hello: " <> show attrs' @@ -88,18 +88,19 @@ shouldNotRunWhenNoChanges = do let f = proc () -> do update "hello" -< ("world" :: Box T.Text) run (\() -> error "io shouldn't be run") -< pure () - attrs <- evalUpdate HMS.empty f + attrs <- evalUpdate () HMS.empty f unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $ error $ "bad value for hello: " <> show attrs let f' = proc () -> do run (\() -> error "io shouldn't be run") -< pure () update "hello" -< ("world" :: Box T.Text) - attrs' <- evalUpdate HMS.empty f' + attrs' <- evalUpdate () HMS.empty f' unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $ error $ "bad value for hello: " <> show attrs' v3 <- execUpdate + () (HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))]) $ proc () -> do v1 <- update "hello" -< "world" @@ -111,7 +112,7 @@ shouldNotRunWhenNoChanges = do templatesExpand :: IO () templatesExpand = do - v3 <- execUpdate attrs $ proc () -> template -< "-" + v3 <- execUpdate () attrs $ proc () -> template -< "-" v3' <- runBox v3 unless (v3' == "hello-world") $ error "bad value" where diff --git a/tests/github/default.nix b/tests/github/default.nix index ab83b76..ed3669c 100644 --- a/tests/github/default.nix +++ b/tests/github/default.nix @@ -82,7 +82,8 @@ pkgs.runCommand "test" (echo "Mismatched sources.json"; \ echo "Reference: tests/expected/niv-init.json"; \ exit 1) - + niv_output_path=$(nix eval --json '(import ./nix/sources.nix).niv.outPath' | jq -r) + nix-store --delete $niv_output_path echo "*** ok." @@ -113,7 +114,20 @@ pkgs.runCommand "test" echo -e "\n*** niv update niv" cat ${./data/repos/nmattia/niv/commits.json} | jq -j '.[0] | .sha' > mock/repos/nmattia/niv/commits/master + + echo -n "Check that the expected store path does not exist before niv update ($niv_output_path): " + test ! -e $niv_output_path; echo OK + niv update niv + + echo -n "Check that the expected store path exist after niv update ($niv_output_path): " + test -e $niv_output_path; echo OK + + new_niv_output_path=$(nix eval --json '(import ./nix/sources.nix).niv.outPath' | jq -r) + echo -n "Check that the resulting outPath is the one that we expect ($niv_output_path): " + test $niv_output_path = $new_niv_output_path; echo OK + + echo -n "niv.rev == ${niv_HEAD} (HEAD): " cat nix/sources.json | jq -e '.niv | .rev == "${niv_HEAD}"' echo -e "*** ok." From 7556d7785f7b9bbb2600c3492583428e96e1b990 Mon Sep 17 00:00:00 2001 From: Martin Lavoie Date: Sun, 26 Sep 2021 11:47:43 +0200 Subject: [PATCH 2/2] Better error message when nix-prefetch-url return an error 404 close nmattia/niv#129 close nmattia/niv#309 close nmattia/niv#330 --- src/Niv/GitHub/Cmd.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Niv/GitHub/Cmd.hs b/src/Niv/GitHub/Cmd.hs index d04806a..a178dd4 100644 --- a/src/Niv/GitHub/Cmd.hs +++ b/src/Niv/GitHub/Cmd.hs @@ -11,6 +11,7 @@ module Niv.GitHub.Cmd where import Control.Applicative +import Control.Monad import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import Data.Bifunctor @@ -160,7 +161,10 @@ nixPrefetchURL unpack packageName (T.unpack -> url) = do (exitCode, sout, serr) <- runNixPrefetch case (exitCode, lines sout) of (ExitSuccess, l : _) -> pure $ T.pack l - _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) + _ -> do + let tserr = T.pack serr + checkNixPrefetchUrlNotFound (T.pack url) tserr + abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) tserr where args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename <> "-src"] runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" @@ -172,6 +176,17 @@ nixPrefetchURL unpack packageName (T.unpack -> url) = do -- (note: we assume they don't begin with a period) isOk = \c -> isAlphaNum c || T.any (c ==) "+-._?=" +checkNixPrefetchUrlNotFound :: T.Text -> T.Text -> IO () +checkNixPrefetchUrlNotFound url serr = do + guard ("HTTP error 404" `T.isInfixOf` serr) + abort $ + T.unlines + [ "The url '" <> url <> "' was not found by 'nix-prefetch-url'.", + "Changing your source's template or attributes may help you resolve the situation.", + "For further help, you can read the niv readme at https://github.com/nmattia/niv", + "or open an ticket at https://github.com/nmattia/niv/issues/new." + ] + abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a abortNixPrefetchExpectedOutput args sout serr = abort $