git.iko.soy/typeable/cabal2nix
on 3faffc2 help sign in
typeable/cabal2nix/src/Distribution/NixOS/Fetch.hs
142 lines 6.3 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Distribution.NixOS.Fetch
5 ( Source(..)
6 , DerivationSource(..), fromDerivationSource
7 , fetch
8 , fetchWith
9 ) where
11import Control.Applicative
12import Control.DeepSeq
13import Control.Monad
14import Control.Monad.IO.Class
15import Control.Monad.Trans.Maybe
16import Data.Maybe
17import System.Directory
18import System.Environment
19import System.Exit
20import System.IO
21import System.Process
23-- | A source is a location from which we can fetch, such as a HTTP URL, a GIT URL, ....
24data Source = Source
25 { sourceUrl :: String -- ^ URL to fetch from.
26 , sourceRevision :: String -- ^ Revision to use. For protocols where this doesn't make sense (such as HTTP), this
27 -- should be the empty string.
28 , sourceHash :: Maybe String -- ^ The expected hash of the source, if available.
29 } deriving (Show, Eq, Ord)
31-- | A source for a derivation. It always needs a hash and also has a protocol attached to it (url, git, svn, ...).
32-- A @DerivationSource@ also always has it's revision fully resolved (not relative revisions like @master@, @HEAD@, etc).
33data DerivationSource = DerivationSource
34 { derivKind :: String -- ^ The kind of the source. The name of the build-support fetch derivation should be fetch<kind>.
35 , derivUrl :: String -- ^ URL to fetch from.
36 , derivRevision :: String -- ^ Revision to use. Leave empty if the fetcher doesn't support revisions.
37 , derivHash :: String -- ^ The hash of the source.
38 } deriving (Show, Eq, Ord)
40instance NFData DerivationSource where
41 rnf (DerivationSource a b c d) = a `deepseq` b `deepseq` c `deepseq` d `deepseq` ()
43fromDerivationSource :: DerivationSource -> Source
44fromDerivationSource DerivationSource{..} = Source derivUrl derivRevision $ Just derivHash
46-- | Fetch a source, trying any of the various nix-prefetch-* scripts.
47fetch :: forall a. (String -> MaybeT IO a) -- ^ This function is passed the output path name as an argument.
48 -- It should return 'Nothing' if the file doesn't match the expected format.
49 -- This is required, because we cannot always check if a download succeeded otherwise.
50 -> Source -- ^ The source to fetch from.
51 -> IO (Maybe (DerivationSource, a)) -- ^ The derivation source and the result of the processing function. Returns Nothing if the download failed.
52fetch f = runMaybeT . fetchers where
53 fetchers :: Source -> MaybeT IO (DerivationSource, a)
54 fetchers source = msum . (fetchLocal source :) $ map (\fetcher -> fetchWith fetcher source >>= process)
55 [ (False, "zip", [])
56 , (False, "url", [])
57 , (True, "git", ["--fetch-submodules"])
58 , (True, "hg", [])
59 , (True, "svn", [])
60 , (True, "bzr", [])
61 ]
63 -- | Remove '/' from the end of the path. Nix doesn't accept paths that
64 -- end in a slash.
65 stripSlashSuffix :: String -> String
66 stripSlashSuffix = reverse . dropWhile (== '/') . reverse
68 fetchLocal :: Source -> MaybeT IO (DerivationSource, a)
69 fetchLocal src = do
70 let path = stripSlashSuffix $ stripPrefix "file://" $ sourceUrl src
71 existsFile <- liftIO $ doesFileExist path
72 existsDir <- liftIO $ doesDirectoryExist path
73 guard $ existsDir || existsFile
74 let path' | '/' `elem` path = path
75 | otherwise = "./" ++ path
76 process (DerivationSource "" path' "" "", path') <|> localArchive path'
78 localArchive :: FilePath -> MaybeT IO (DerivationSource, a)
79 localArchive path = do
80 absolutePath <- liftIO $ canonicalizePath path
81 unpacked <- snd <$> fetchWith (False, "zip", []) (Source ("file://" ++ absolutePath) "" Nothing)
82 process (DerivationSource "" absolutePath "" "", unpacked)
84 process :: (DerivationSource, FilePath) -> MaybeT IO (DerivationSource, a)
85 process (derivSource, file) = (,) derivSource <$> f file
87-- | Like 'fetch', but allows to specify which script to use.
88fetchWith :: (Bool, String, [String]) -> Source -> MaybeT IO (DerivationSource, FilePath)
89fetchWith (supportsRev, kind, addArgs) source = do
90 unless ((sourceRevision source /= "") || isNothing (sourceHash source) || not supportsRev) $
91 liftIO (hPutStrLn stderr "** need a revision for VCS when the hash is given. skipping.") >> mzero
93 MaybeT $ liftIO $ do
94 envs <- getEnvironment
95 (Nothing, Just stdoutH, _, processH) <- createProcess (proc script args)
96 { env = Just $ ("PRINT_PATH", "1") : envs
97 , std_in = Inherit
98 , std_err = Inherit
99 , std_out = CreatePipe
100 }
102 exitCode <- waitForProcess processH
103 case exitCode of
104 ExitSuccess -> fmap Just . processOutputSwitch . lines =<< hGetContents stdoutH
105 ExitFailure _ -> return Nothing
107 where
109 script :: String
110 script = "nix-prefetch-" ++ kind
112 args :: [String]
113 args = addArgs ++ sourceUrl source : [ sourceRevision source | supportsRev ] ++ maybeToList (sourceHash source)
115 processOutputWithRev :: [String] -> IO (DerivationSource, FilePath)
116 processOutputWithRev [rev,hash,path] = return (DerivationSource kind (sourceUrl source) (extractRevision rev) hash, path)
117 processOutputWithRev out = unexpectedOutput out
119 extractRevision :: String -> String
120 extractRevision = unwords . drop 3 . words -- drop the "<vcs> revision is" prefix
122 processOutput :: [String] -> IO (DerivationSource, FilePath)
123 processOutput [hash,path] = return (DerivationSource kind (sourceUrl source) (sourceRevision source) hash, path)
124 processOutput out = unexpectedOutput out
126 unexpectedOutput :: [String] -> IO a
127 unexpectedOutput out = do
128 hPutStrLn stderr $ "*** unexpected output from " ++ "nix-prefetch-" ++ kind ++ " script: "
129 hPutStr stderr $ unlines out
130 exitFailure
132 processOutputSwitch :: [String] -> IO (DerivationSource, FilePath)
133 processOutputSwitch
134 | supportsRev && isNothing (sourceHash source) = processOutputWithRev
135 | otherwise = processOutput
137stripPrefix :: Eq a => [a] -> [a] -> [a]
138stripPrefix prefix as
139 | prefix' == prefix = stripped
140 | otherwise = as
141 where
142 (prefix', stripped) = splitAt (length prefix) as