Fix multiple download issue in stack-to-nix

Author: hamishmack

nix-tools/cabal2nix/Main.hs

@@ -44,7 +44,7 @@ main = getArgs >>= \case
   [url,hash] | "http" `isPrefixOf` url ->
           let subdir = "." in
           fetch (\dir -> cabalFromPath url hash subdir $ dir </> subdir)
-            (Source url mempty UnknownHash subdir) >>= \case
+            (Source url mempty UnknownHash) >>= \case
             (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash
             _ -> return ()
   [path,file] -> doesDirectoryExist file >>= \case

nix-tools/lib/Distribution/Nixpkgs/Fetch.hs

@@ -31,7 +31,6 @@ data Source = Source
   , sourceRevision  :: String       -- ^ Revision to use. For protocols where this doesn't make sense (such as HTTP), this
                                     --   should be the empty string.
   , sourceHash      :: Hash         -- ^ The expected hash of the source, if available.
-  , sourceCabalDir  :: String       -- ^ Directory where Cabal file is found.
   } deriving (Show, Eq, Ord, Generic)
 
 instance NFData Source
@@ -69,24 +68,26 @@ instance FromJSON DerivationSource where
   parseJSON _ = error "invalid DerivationSource"
 
 fromDerivationSource :: DerivationSource -> Source
-fromDerivationSource DerivationSource{..} = Source derivUrl derivRevision (Certain derivHash) "."
+fromDerivationSource DerivationSource{..} = Source derivUrl derivRevision (Certain derivHash)
+
+firstJust :: Monad m => [m (Maybe a)] -> m (Maybe a)
+firstJust [] = pure Nothing
+firstJust (x:xs) = x >>= maybe (firstJust xs) (pure . Just)
 
 -- | Fetch a source, trying any of the various nix-prefetch-* scripts.
 fetch :: forall a. (String -> MaybeT IO a)      -- ^ This function is passed the output path name as an argument.
                                                 -- It should return 'Nothing' if the file doesn't match the expected format.
                                                 -- This is required, because we cannot always check if a download succeeded otherwise.
       -> Source                                 -- ^ The source to fetch from.
       -> IO (Maybe (DerivationSource, a))       -- ^ The derivation source and the result of the processing function. Returns Nothing if the download failed.
-fetch f = runMaybeT . fetchers where
-  fetchers :: Source -> MaybeT IO (DerivationSource, a)
-  fetchers source = msum . (fetchLocal source :) $ map (\fetcher -> fetchWith fetcher source >>= process)
-    [ (False, "url", [])
-    , (True, "git", ["--fetch-submodules"])
+fetch f source = firstJust . map runMaybeT . (fetchLocal source :) $ map (\fetcher -> fetchWith fetcher source >>= process)
+    [ (True, "git", ["--fetch-submodules"])
     , (True, "hg", [])
     , (True, "svn", [])
     , (True, "bzr", [])
+    , (False, "url", [])
     ]
-
+ where
   -- | Remove '/' from the end of the path. Nix doesn't accept paths that
   -- end in a slash.
   stripSlashSuffix :: String -> String
@@ -105,7 +106,7 @@ fetch f = runMaybeT . fetchers where
   localArchive :: FilePath -> MaybeT IO (DerivationSource, a)
   localArchive path = do
     absolutePath <- liftIO $ canonicalizePath path
-    unpacked <- snd <$> fetchWith (False, "url", ["--unpack"]) (Source ("file://" ++ absolutePath) "" UnknownHash ".")
+    unpacked <- snd <$> fetchWith (False, "url", ["--unpack"]) (Source ("file://" ++ absolutePath) "" UnknownHash)
     process (DerivationSource "" absolutePath "" "", unpacked)
 
   process :: (DerivationSource, FilePath) -> MaybeT IO (DerivationSource, a)

nix-tools/lib/Stack2nix.hs

@@ -8,6 +8,7 @@ module Stack2nix
 
 import qualified Data.Text as T
 import Data.String (fromString)
+import Data.Maybe (fromMaybe)
 
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class (liftIO)
@@ -161,42 +162,43 @@ packages2nix args pkgs =
                       prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile
                     return (fromString pkg, fromString pkg $= mkPath False nix)
        (DVCS (Git url rev) _ subdirs) ->
-         fmap concat . forM subdirs $ \subdir ->
-         do cacheHits <- liftIO $ cacheHits (argCacheFile args) url rev subdir
-            case cacheHits of
-              [] -> do
-                fetch (\dir -> cabalFromPath url rev subdir $ dir </> subdir)
-                  (Source url rev UnknownHash subdir) >>= \case
-                  (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash
-                  _ -> return []
-              hits ->
-                forM hits $ \( pkg, nix ) -> do
+         do hits <- forM subdirs $ \subdir -> liftIO $ cacheHits (argCacheFile args) url rev subdir
+            if any null hits
+              then
+                fetch (return . cabalFromPath url rev subdirs)
+                  (Source url rev UnknownHash) >>= \case
+                    (Just (DerivationSource{..}, genBindings)) -> fromMaybe [] <$> runMaybeT (genBindings derivHash)
+                    _ -> return []
+              else
+                forM (concat hits) $ \( pkg, nix ) ->
                   return (fromString pkg, fromString pkg $= mkPath False nix)
        _ -> return []
   where relPath = shortRelativePath (argOutputDir args) (dropFileName (argStackYaml args))
         cabalFromPath
-          :: String    -- URL
-          -> String    -- Revision
-          -> FilePath  -- Subdir
-          -> FilePath  -- Local Directory
-          -> MaybeT IO (String -> IO [(T.Text, Binding NExpr)])
-        cabalFromPath url rev subdir path = do
-          d <- liftIO $ doesDirectoryExist path
-          unless d $ fail ("not a directory: " ++ path)
-          cabalFiles <- liftIO $ findCabalFiles (argHpackUse args) path
-          return $ \sha256 ->
+          :: String      -- URL
+          -> String      -- Revision
+          -> [FilePath]  -- Subdirs
+          -> FilePath    -- Local Directory
+          -> String      -- Sha256
+          -> MaybeT IO [(T.Text, Binding NExpr)]
+        cabalFromPath url rev subdirs dir sha256 =
+          fmap concat . forM subdirs $ \subdir -> do
+            let path = dir </> subdir
+            d <- liftIO $ doesDirectoryExist path
+            unless d $ fail ("not a directory: " ++ path)
+            cabalFiles <- liftIO $ findCabalFiles (argHpackUse args) path
             forM cabalFiles $ \cabalFile -> do
-            let pkg = cabalFilePkgName cabalFile
-                nix = pkg <.> "nix"
-                nixFile = argOutputDir args </> nix
-                subdir' = if subdir == "." then Nothing
-                          else Just subdir
-                src = Just $ C2N.Git url rev (Just sha256) subdir'
-            createDirectoryIfMissing True (takeDirectory nixFile)
-            writeDoc nixFile =<<
-              prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile
-            liftIO $ appendCache (argCacheFile args) url rev subdir sha256 pkg nix
-            return (fromString pkg, fromString pkg $= mkPath False nix)
+              let pkg = cabalFilePkgName cabalFile
+                  nix = pkg <.> "nix"
+                  nixFile = argOutputDir args </> nix
+                  subdir' = if subdir == "." then Nothing
+                            else Just subdir
+                  src = Just $ C2N.Git url rev (Just sha256) subdir'
+              liftIO $ createDirectoryIfMissing True (takeDirectory nixFile)
+              liftIO $ writeDoc nixFile =<<
+                prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile
+              liftIO $ appendCache (argCacheFile args) url rev subdir sha256 pkg nix
+              return (fromString pkg, fromString pkg $= mkPath False nix)
 
 defaultNixContents :: String
 defaultNixContents = unlines

nix-tools/plan2nix/Plan2Nix.hs

@@ -98,7 +98,7 @@ plan2nix args (Plan { packages, extras, compilerVersion, compilerPackages }) = d
          case cacheHits of
            [] -> do
              fetch (\dir -> cabalFromPath url rev subdir $ dir </> subdir)
-               (Source url rev UnknownHash subdir) >>= \case
+               (Source url rev UnknownHash) >>= \case
                (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash
                _ -> return []
            hits ->