git.iko.soy/stackage
on fccd62f help sign in
stackage/Stackage/Util.hs
174 lines 6.9 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 (intercalate, 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,
21 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 :: BuildSettings -> [String] -> [String]
110addCabalArgsOnlyGlobal settings rest
111 = "--package-db=clear"
112 : "--package-db=global"
113 : map ("--package-db=" ++) (underlayPackageDirs settings)
114 ++ rest
116addCabalArgs :: BuildSettings -> BuildStage -> [String] -> [String]
117addCabalArgs settings bs rest
118 = addCabalArgsOnlyGlobal settings
119 $ ("--package-db=" ++ packageDir settings ++ toolsSuffix)
120 : ("--libdir=" ++ libDir settings ++ toolsSuffix)
121 : ("--bindir=" ++ binDir settings)
122 : ("--datadir=" ++ dataDir settings)
123 : ("--docdir=" ++ docDir settings ++ toolsSuffix)
124 : extraArgs settings bs ++ rest
125 where
126 toolsSuffix =
127 case bs of
128 BSTools -> "-tools"
129 _ -> ""
131-- | Modified environment that adds our sandboxed bin folder to PATH.
132getModifiedEnv :: BuildSettings -> IO [(String, String)]
133getModifiedEnv settings = do
134 fmap (map $ fixEnv $ binDir settings) getEnvironment
135 where
136 fixEnv :: FilePath -> (String, String) -> (String, String)
137 fixEnv bin (p, x)
138 -- Thank you Windows having case-insensitive environment variables...
139 | map toUpper p == "PATH" = (p, bin ++ pathSep : x)
140 | otherwise = (p, x)
142 -- | Separate for the PATH environment variable
143 pathSep :: Char
144#ifdef mingw32_HOST_OS
145 pathSep = ';'
146#else
147 pathSep = ':'
148#endif
150-- | Minor fixes, such as making paths absolute.
151--
152-- Note: creates the sandbox root in the process.
153fixBuildSettings :: BuildSettings -> IO BuildSettings
154fixBuildSettings settings' = do
155 let root' = sandboxRoot settings'
156 createDirectoryIfMissing True root'
157 root <- canonicalizePath root'
158 return settings' { sandboxRoot = root }
160-- | Check if a tarball exists in the tarball directory and, if so, use that
161-- instead of the given name.
162replaceTarball :: FilePath -- ^ tarball directory
163 -> String
164 -> IO String
165replaceTarball tarballdir pkgname = do
166 exists <- doesFileExist fp
167 if exists
168 then canonicalizePath fp
169 else return pkgname
170 where
171 fp = tarballdir </> pkgname <.> "tar.gz"
173githubMentions :: [String] -> String
174githubMentions = intercalate "," . map ('@' :)