git.iko.soy/stackage
on 0051979 help sign in
stackage/Stackage/Util.hs
141 lines 5.4 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.List (stripPrefix)
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Data.Version (showVersion)
11import Distribution.Text (simpleParse, display)
12import Distribution.Version (thisVersion)
13import Stackage.Types
14import System.Directory (doesDirectoryExist,
15 removeDirectoryRecursive)
16import System.Directory (getAppUserDataDirectory)
17import System.Environment (getEnvironment)
18import System.FilePath ((</>))
19import qualified Distribution.Package as P
20import qualified Distribution.PackageDescription as PD
21import Distribution.License (License (..))
22import System.Directory (canonicalizePath,
23 createDirectoryIfMissing,
24 doesDirectoryExist)
26-- | Allow only packages with permissive licenses.
27allowPermissive :: [String] -- ^ list of explicitly allowed packages
28 -> PD.GenericPackageDescription
29 -> Either String ()
30allowPermissive allowed gpd
31 | P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right ()
32 | otherwise =
33 case PD.license $ PD.packageDescription gpd of
34 BSD3 -> Right ()
35 MIT -> Right ()
36 PublicDomain -> Right ()
37 l -> Left $ "Non-permissive license: " ++ display l
39identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer)
40identsToRanges =
41 Map.unions . map go . Set.toList
42 where
43 go (PackageIdentifier package version) = Map.singleton package (thisVersion version, Maintainer "Haskell Platform")
45packageVersionString :: (PackageName, Version) -> String
46packageVersionString (PackageName p, v) = concat [p, "-", showVersion v]
48rm_r :: FilePath -> IO ()
49rm_r fp = do
50 exists <- doesDirectoryExist fp
51 when exists $ removeDirectoryRecursive fp
53getCabalRoot :: IO FilePath
54getCabalRoot = getAppUserDataDirectory "cabal"
56-- | Name of the 00-index.tar downloaded from Hackage.
57getTarballName :: IO FilePath
58getTarballName = do
59 c <- getCabalRoot
60 return $ c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"
62stableRepoName, extraRepoName :: String
63stableRepoName = "stackage"
64extraRepoName = "stackage-extra"
66-- | Locations for the stackage and stackage-extra tarballs
67getStackageTarballNames :: IO (FilePath, FilePath)
68getStackageTarballNames = do
69 c <- getCabalRoot
70 let f x = c </> "packages" </> x </> "00-index.tar"
71 return (f stableRepoName, f extraRepoName)
73getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version)
74getPackageVersion e = do
75 let (package', s1) = break (== '/') fp
76 package = PackageName package'
77 s2 <- stripPrefix "/" s1
78 let (version', s3) = break (== '/') s2
79 version <- simpleParse version'
80 s4 <- stripPrefix "/" s3
81 guard $ s4 == package' ++ ".cabal"
82 Just (package, version)
83 where
84 fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e
86-- | If a package cannot be parsed or is not found, the default value for
87-- whether it has a test suite. We default to @True@ since, worst case
88-- scenario, this just means a little extra time trying to run a suite that's
89-- not there. Defaulting to @False@ would result in silent failures.
90defaultHasTestSuites :: Bool
91defaultHasTestSuites = True
93packageDir, libDir, binDir, dataDir, docDir :: BuildSettings -> FilePath
94packageDir = (</> "package-db") . sandboxRoot
95libDir = (</> "lib") . sandboxRoot
96binDir = (</> "bin") . sandboxRoot
97dataDir = (</> "share") . sandboxRoot
98docDir x = sandboxRoot x </> "share" </> "doc" </> "$pkgid"
100addCabalArgsOnlyGlobal :: [String] -> [String]
101addCabalArgsOnlyGlobal rest
102 = "--package-db=clear"
103 : "--package-db=global"
104 : rest
106addCabalArgs :: BuildSettings -> [String] -> [String]
107addCabalArgs settings rest
108 = addCabalArgsOnlyGlobal
109 $ ("--package-db=" ++ packageDir settings)
110 : ("--libdir=" ++ libDir settings)
111 : ("--bindir=" ++ binDir settings)
112 : ("--datadir=" ++ dataDir settings)
113 : ("--docdir=" ++ docDir settings)
114 : extraArgs settings ++ rest
116-- | Modified environment that adds our sandboxed bin folder to PATH.
117getModifiedEnv :: BuildSettings -> IO [(String, String)]
118getModifiedEnv settings = do
119 fmap (map $ fixEnv $ binDir settings) getEnvironment
120 where
121 fixEnv :: FilePath -> (String, String) -> (String, String)
122 fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
123 fixEnv _ x = x
125 -- | Separate for the PATH environment variable
126 pathSep :: Char
127#ifdef mingw32_HOST_OS
128 pathSep = ';'
129#else
130 pathSep = ':'
131#endif
133-- | Minor fixes, such as making paths absolute.
134--
135-- Note: creates the sandbox root in the process.
136fixBuildSettings :: BuildSettings -> IO BuildSettings
137fixBuildSettings settings' = do
138 let root' = sandboxRoot settings'
139 createDirectoryIfMissing True root'
140 root <- canonicalizePath root'
141 return settings' { sandboxRoot = root }