git.iko.soy/stackage
on a29ba67 help sign in
stackage/Stackage/Util.hs
150 lines 6.0 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)
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)
22import System.Directory (canonicalizePath,
23 createDirectoryIfMissing)
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)
119 : ("--libdir=" ++ libDir settings)
120 : ("--bindir=" ++ binDir settings)
121 : ("--datadir=" ++ dataDir settings)
122 : ("--docdir=" ++ docDir settings)
123 : extraArgs settings bs ++ rest
125-- | Modified environment that adds our sandboxed bin folder to PATH.
126getModifiedEnv :: BuildSettings -> IO [(String, String)]
127getModifiedEnv settings = do
128 fmap (map $ fixEnv $ binDir settings) getEnvironment
129 where
130 fixEnv :: FilePath -> (String, String) -> (String, String)
131 fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
132 fixEnv _ x = x
134 -- | Separate for the PATH environment variable
135 pathSep :: Char
136#ifdef mingw32_HOST_OS
137 pathSep = ';'
138#else
139 pathSep = ':'
140#endif
142-- | Minor fixes, such as making paths absolute.
143--
144-- Note: creates the sandbox root in the process.
145fixBuildSettings :: BuildSettings -> IO BuildSettings
146fixBuildSettings settings' = do
147 let root' = sandboxRoot settings'
148 createDirectoryIfMissing True root'
149 root <- canonicalizePath root'
150 return settings' { sandboxRoot = root }