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