git.iko.soy/stackage
on b2ed20c help sign in
stackage/Stackage/Util.hs
170 lines 6.7 kB history raw
1{-# LANGUAGE CPP #-}
2module Stackage.Util where
4import qualified Codec.Archive.Tar as Tar
5import qualified Codec.Archive.Tar.Entry as TarEntry
6import Control.Monad (guard, when)
7import Data.Char (isSpace, toUpper)
8import Data.List (stripPrefix)
9import qualified Data.Map as Map
10import Data.Maybe (mapMaybe)
11import qualified Data.Set as Set
12import Data.Version (showVersion)
13import Distribution.License (License (..))
14import qualified Distribution.Package as P
15import qualified Distribution.PackageDescription as PD
16import Distribution.Text (display, simpleParse)
17import Distribution.Version (thisVersion)
18import Stackage.Types
19import System.Directory (doesDirectoryExist,
20 removeDirectoryRecursive)
21import System.Directory (getAppUserDataDirectory
22 ,canonicalizePath,
23 createDirectoryIfMissing, doesFileExist)
24import System.Environment (getEnvironment)
25import System.FilePath ((</>), (<.>))
27-- | Allow only packages with permissive licenses.
28allowPermissive :: [String] -- ^ list of explicitly allowed packages
29 -> PD.GenericPackageDescription
30 -> Either String ()
31allowPermissive allowed gpd
32 | P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right ()
33 | otherwise =
34 case PD.license $ PD.packageDescription gpd of
35 BSD3 -> Right ()
36 MIT -> Right ()
37 PublicDomain -> Right ()
38 l -> Left $ "Non-permissive license: " ++ display l
40identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer)
41identsToRanges =
42 Map.unions . map go . Set.toList
43 where
44 go (PackageIdentifier package version) = Map.singleton package (thisVersion version, Maintainer "Haskell Platform")
46packageVersionString :: (PackageName, Version) -> String
47packageVersionString (PackageName p, v) = concat [p, "-", showVersion v]
49rm_r :: FilePath -> IO ()
50rm_r fp = do
51 exists <- doesDirectoryExist fp
52 when exists $ removeDirectoryRecursive fp
54getCabalRoot :: IO FilePath
55getCabalRoot = getAppUserDataDirectory "cabal"
57-- | Name of the 00-index.tar downloaded from Hackage.
58getTarballName :: IO FilePath
59getTarballName = do
60 c <- getCabalRoot
61 configLines <- fmap lines $ readFile (c </> "config")
62 case mapMaybe getRemoteCache configLines of
63 [x] -> return $ x </> "hackage.haskell.org" </> "00-index.tar"
64 [] -> error $ "No remote-repo-cache found in Cabal config file"
65 _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file"
66 where
67 getRemoteCache s = do
68 ("remote-repo-cache", ':':v) <- Just $ break (== ':') s
69 Just $ reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace v
71stableRepoName, extraRepoName :: String
72stableRepoName = "stackage"
73extraRepoName = "stackage-extra"
75-- | Locations for the stackage and stackage-extra tarballs
76getStackageTarballNames :: IO (FilePath, FilePath)
77getStackageTarballNames = do
78 c <- getCabalRoot
79 let f x = c </> "packages" </> x </> "00-index.tar"
80 return (f stableRepoName, f extraRepoName)
82getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version)
83getPackageVersion e = do
84 let (package', s1) = break (== '/') fp
85 package = PackageName package'
86 s2 <- stripPrefix "/" s1
87 let (version', s3) = break (== '/') s2
88 version <- simpleParse version'
89 s4 <- stripPrefix "/" s3
90 guard $ s4 == package' ++ ".cabal"
91 Just (package, version)
92 where
93 fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e
95-- | If a package cannot be parsed or is not found, the default value for
96-- whether it has a test suite. We default to @True@ since, worst case
97-- scenario, this just means a little extra time trying to run a suite that's
98-- not there. Defaulting to @False@ would result in silent failures.
99defaultHasTestSuites :: Bool
100defaultHasTestSuites = True
102packageDir, libDir, binDir, dataDir, docDir :: BuildSettings -> FilePath
103packageDir = (</> "package-db") . sandboxRoot
104libDir = (</> "lib") . sandboxRoot
105binDir = (</> "bin") . sandboxRoot
106dataDir = (</> "share") . sandboxRoot
107docDir x = sandboxRoot x </> "share" </> "doc" </> "$pkgid"
109addCabalArgsOnlyGlobal :: [String] -> [String]
110addCabalArgsOnlyGlobal rest
111 = "--package-db=clear"
112 : "--package-db=global"
113 : rest
115addCabalArgs :: BuildSettings -> BuildStage -> [String] -> [String]
116addCabalArgs settings bs rest
117 = addCabalArgsOnlyGlobal
118 $ ("--package-db=" ++ packageDir settings ++ toolsSuffix)
119 : ("--libdir=" ++ libDir settings ++ toolsSuffix)
120 : ("--bindir=" ++ binDir settings)
121 : ("--datadir=" ++ dataDir settings)
122 : ("--docdir=" ++ docDir settings ++ toolsSuffix)
123 : extraArgs settings bs ++ rest
124 where
125 toolsSuffix =
126 case bs of
127 BSTools -> "-tools"
128 _ -> ""
130-- | Modified environment that adds our sandboxed bin folder to PATH.
131getModifiedEnv :: BuildSettings -> IO [(String, String)]
132getModifiedEnv settings = do
133 fmap (map $ fixEnv $ binDir settings) getEnvironment
134 where
135 fixEnv :: FilePath -> (String, String) -> (String, String)
136 fixEnv bin (p, x)
137 -- Thank you Windows having case-insensitive environment variables...
138 | map toUpper p == "PATH" = (p, bin ++ pathSep : x)
139 | otherwise = (p, x)
141 -- | Separate for the PATH environment variable
142 pathSep :: Char
143#ifdef mingw32_HOST_OS
144 pathSep = ';'
145#else
146 pathSep = ':'
147#endif
149-- | Minor fixes, such as making paths absolute.
150--
151-- Note: creates the sandbox root in the process.
152fixBuildSettings :: BuildSettings -> IO BuildSettings
153fixBuildSettings settings' = do
154 let root' = sandboxRoot settings'
155 createDirectoryIfMissing True root'
156 root <- canonicalizePath root'
157 return settings' { sandboxRoot = root }
159-- | Check if a tarball exists in the tarball directory and, if so, use that
160-- instead of the given name.
161replaceTarball :: FilePath -- ^ tarball directory
162 -> String
163 -> IO String
164replaceTarball tarballdir pkgname = do
165 exists <- doesFileExist fp
166 if exists
167 then canonicalizePath fp
168 else return pkgname
169 where
170 fp = tarballdir </> pkgname <.> "tar.gz"