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