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

@@ -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) =>

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]

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 ::

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

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)

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.

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!"

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",

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)