git.iko.soy/typeable/cabal2nix
on 8810b21 help sign in
typeable/cabal2nix/src/Distribution/Nixpkgs/Fetch.hs
155 lines 6.4 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE DeriveGeneric #-}
6module Distribution.Nixpkgs.Fetch
7 ( Source(..)
8 , Hash(..)
9 , DerivationSource(..), fromDerivationSource
10 , fetch
11 , fetchWith
12 ) where
14import Control.Applicative
15import Control.DeepSeq
16import Control.Monad
17import Control.Monad.IO.Class
18import Control.Monad.Trans.Maybe
19import Data.Aeson
20import qualified Data.ByteString.Lazy.Char8 as BS
21import GHC.Generics ( Generic )
22import System.Directory
23import System.Environment
24import System.Exit
25import System.IO
26import System.Process
28-- | A source is a location from which we can fetch, such as a HTTP URL, a GIT URL, ....
29data Source = Source
30 { sourceUrl :: String -- ^ URL to fetch from.
31 , sourceRevision :: String -- ^ Revision to use. For protocols where this doesn't make sense (such as HTTP), this
32 -- should be the empty string.
33 , sourceHash :: Hash -- ^ The expected hash of the source, if available.
34 , sourceCabalDir :: String -- ^ Directory where Cabal file is found.
35 } deriving (Show, Eq, Ord, Generic)
37instance NFData Source
39data Hash = Certain String | Guess String | UnknownHash
40 deriving (Show, Eq, Ord, Generic)
42instance NFData Hash
44isUnknown :: Hash -> Bool
45isUnknown UnknownHash = True
46isUnknown _ = False
48hashToList :: Hash -> [String]
49hashToList (Certain s) = [s]
50hashToList _ = []
52-- | A source for a derivation. It always needs a hash and also has a protocol attached to it (url, git, svn, ...).
53-- A @DerivationSource@ also always has it's revision fully resolved (not relative revisions like @master@, @HEAD@, etc).
54data DerivationSource = DerivationSource
55 { derivKind :: String -- ^ The kind of the source. The name of the build-support fetch derivation should be fetch<kind>.
56 , derivUrl :: String -- ^ URL to fetch from.
57 , derivRevision :: String -- ^ Revision to use. Leave empty if the fetcher doesn't support revisions.
58 , derivHash :: String -- ^ The hash of the source.
59 }
60 deriving (Show, Eq, Ord, Generic)
62instance NFData DerivationSource
64instance FromJSON DerivationSource where
65 parseJSON (Object o) = DerivationSource (error "undefined DerivationSource.kind")
66 <$> o .: "url"
67 <*> o .: "rev"
68 <*> o .: "sha256"
69 parseJSON _ = error "invalid DerivationSource"
71fromDerivationSource :: DerivationSource -> Source
72fromDerivationSource DerivationSource{..} = Source derivUrl derivRevision (Certain derivHash) "."
74-- | Fetch a source, trying any of the various nix-prefetch-* scripts.
75fetch :: forall a. (String -> MaybeT IO a) -- ^ This function is passed the output path name as an argument.
76 -- It should return 'Nothing' if the file doesn't match the expected format.
77 -- This is required, because we cannot always check if a download succeeded otherwise.
78 -> Source -- ^ The source to fetch from.
79 -> IO (Maybe (DerivationSource, a)) -- ^ The derivation source and the result of the processing function. Returns Nothing if the download failed.
80fetch f = runMaybeT . fetchers where
81 fetchers :: Source -> MaybeT IO (DerivationSource, a)
82 fetchers source = msum . (fetchLocal source :) $ map (\fetcher -> fetchWith fetcher source >>= process)
83 [ (False, "url", [])
84 , (True, "git", ["--fetch-submodules"])
85 , (True, "hg", [])
86 , (True, "svn", [])
87 , (True, "bzr", [])
88 ]
90 -- | Remove '/' from the end of the path. Nix doesn't accept paths that
91 -- end in a slash.
92 stripSlashSuffix :: String -> String
93 stripSlashSuffix = reverse . dropWhile (== '/') . reverse
95 fetchLocal :: Source -> MaybeT IO (DerivationSource, a)
96 fetchLocal src = do
97 let path = stripSlashSuffix $ stripPrefix "file://" $ sourceUrl src
98 existsFile <- liftIO $ doesFileExist path
99 existsDir <- liftIO $ doesDirectoryExist path
100 guard $ existsDir || existsFile
101 let path' | '/' `elem` path = path
102 | otherwise = "./" ++ path
103 process (DerivationSource "" path' "" "", path') <|> localArchive path'
105 localArchive :: FilePath -> MaybeT IO (DerivationSource, a)
106 localArchive path = do
107 absolutePath <- liftIO $ canonicalizePath path
108 unpacked <- snd <$> fetchWith (False, "url", ["--unpack"]) (Source ("file://" ++ absolutePath) "" UnknownHash ".")
109 process (DerivationSource "" absolutePath "" "", unpacked)
111 process :: (DerivationSource, FilePath) -> MaybeT IO (DerivationSource, a)
112 process (derivSource, file) = (,) derivSource <$> f file
114-- | Like 'fetch', but allows to specify which script to use.
115fetchWith :: (Bool, String, [String]) -> Source -> MaybeT IO (DerivationSource, FilePath)
116fetchWith (supportsRev, kind, addArgs) source = do
117 unless ((sourceRevision source /= "") || isUnknown (sourceHash source) || not supportsRev) $
118 liftIO (hPutStrLn stderr "** need a revision for VCS when the hash is given. skipping.") >> mzero
120 MaybeT $ liftIO $ do
121 envs <- getEnvironment
122 (Nothing, Just stdoutH, _, processH) <- createProcess (proc script args)
123 { env = Just $ ("PRINT_PATH", "1") : envs
124 , std_in = Inherit
125 , std_err = Inherit
126 , std_out = CreatePipe
127 }
129 exitCode <- waitForProcess processH
130 case exitCode of
131 ExitFailure _ -> return Nothing
132 ExitSuccess -> do
133 buf <- BS.hGetContents stdoutH
134 let (l:ls) = reverse (BS.lines buf)
135 buf' = BS.unlines (reverse ls)
136 case length ls of
137 0 -> return Nothing
138 1 -> return (Just (DerivationSource kind (sourceUrl source) "" (BS.unpack (head ls)) , sourceUrl source))
139 _ -> case eitherDecode buf' of
140 Left err -> error ("invalid JSON: " ++ err ++ " in " ++ show buf')
141 Right ds -> return (Just (ds { derivKind = kind }, BS.unpack l))
142 where
144 script :: String
145 script = "nix-prefetch-" ++ kind
147 args :: [String]
148 args = addArgs ++ sourceUrl source : [ sourceRevision source | supportsRev ] ++ hashToList (sourceHash source)
150stripPrefix :: Eq a => [a] -> [a] -> [a]
151stripPrefix prefix as
152 | prefix' == prefix = stripped
153 | otherwise = as
154 where
155 (prefix', stripped) = splitAt (length prefix) as