mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
124 lines
4.6 KiB
Haskell
124 lines
4.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Stackage.Util where
|
|
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import qualified Codec.Archive.Tar.Entry as TarEntry
|
|
import Control.Monad (guard, when)
|
|
import Data.List (stripPrefix)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Data.Version (showVersion)
|
|
import Distribution.Text (simpleParse, display)
|
|
import Distribution.Version (thisVersion)
|
|
import Stackage.Types
|
|
import System.Directory (doesDirectoryExist,
|
|
removeDirectoryRecursive)
|
|
import System.Directory (getAppUserDataDirectory)
|
|
import System.Environment (getEnvironment)
|
|
import System.FilePath ((</>))
|
|
import qualified Distribution.Package as P
|
|
import qualified Distribution.PackageDescription as PD
|
|
import Distribution.License (License (..))
|
|
|
|
-- | Allow only packages with permissive licenses.
|
|
allowPermissive :: [String] -- ^ list of explicitly allowed packages
|
|
-> PD.GenericPackageDescription
|
|
-> Either String ()
|
|
allowPermissive allowed gpd
|
|
| P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right ()
|
|
| otherwise =
|
|
case PD.license $ PD.packageDescription gpd of
|
|
BSD3 -> Right ()
|
|
MIT -> Right ()
|
|
PublicDomain -> Right ()
|
|
l -> Left $ "Non-permissive license: " ++ display l
|
|
|
|
identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer)
|
|
identsToRanges =
|
|
Map.unions . map go . Set.toList
|
|
where
|
|
go (PackageIdentifier package version) = Map.singleton package (thisVersion version, Maintainer "Haskell Platform")
|
|
|
|
packageVersionString :: (PackageName, Version) -> String
|
|
packageVersionString (PackageName p, v) = concat [p, "-", showVersion v]
|
|
|
|
rm_r :: FilePath -> IO ()
|
|
rm_r fp = do
|
|
exists <- doesDirectoryExist fp
|
|
when exists $ removeDirectoryRecursive fp
|
|
|
|
getCabalRoot :: IO FilePath
|
|
getCabalRoot = getAppUserDataDirectory "cabal"
|
|
|
|
-- | Name of the 00-index.tar downloaded from Hackage.
|
|
getTarballName :: IO FilePath
|
|
getTarballName = do
|
|
c <- getCabalRoot
|
|
return $ c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"
|
|
|
|
stableRepoName, extraRepoName :: String
|
|
stableRepoName = "stackage"
|
|
extraRepoName = "stackage-extra"
|
|
|
|
-- | Locations for the stackage and stackage-extra tarballs
|
|
getStackageTarballNames :: IO (FilePath, FilePath)
|
|
getStackageTarballNames = do
|
|
c <- getCabalRoot
|
|
let f x = c </> "packages" </> x </> "00-index.tar"
|
|
return (f stableRepoName, f extraRepoName)
|
|
|
|
getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version)
|
|
getPackageVersion e = do
|
|
let (package', s1) = break (== '/') fp
|
|
package = PackageName package'
|
|
s2 <- stripPrefix "/" s1
|
|
let (version', s3) = break (== '/') s2
|
|
version <- simpleParse version'
|
|
s4 <- stripPrefix "/" s3
|
|
guard $ s4 == package' ++ ".cabal"
|
|
Just (package, version)
|
|
where
|
|
fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e
|
|
|
|
-- | If a package cannot be parsed or is not found, the default value for
|
|
-- whether it has a test suite. We default to @True@ since, worst case
|
|
-- scenario, this just means a little extra time trying to run a suite that's
|
|
-- not there. Defaulting to @False@ would result in silent failures.
|
|
defaultHasTestSuites :: Bool
|
|
defaultHasTestSuites = True
|
|
|
|
packageDir, libDir, binDir, dataDir, docDir :: BuildSettings -> FilePath
|
|
packageDir = (</> "package-db") . sandboxRoot
|
|
libDir = (</> "lib") . sandboxRoot
|
|
binDir = (</> "bin") . sandboxRoot
|
|
dataDir = (</> "share") . sandboxRoot
|
|
docDir x = sandboxRoot x </> "share" </> "doc" </> "$pkgid"
|
|
|
|
addCabalArgs :: BuildSettings -> [String] -> [String]
|
|
addCabalArgs settings rest
|
|
= "--package-db=clear"
|
|
: "--package-db=global"
|
|
: ("--package-db=" ++ packageDir settings)
|
|
: ("--libdir=" ++ libDir settings)
|
|
: ("--bindir=" ++ binDir settings)
|
|
: ("--datadir=" ++ dataDir settings)
|
|
: ("--docdir=" ++ docDir settings)
|
|
: extraArgs settings ++ rest
|
|
|
|
-- | Modified environment that adds our sandboxed bin folder to PATH.
|
|
getModifiedEnv :: BuildSettings -> IO [(String, String)]
|
|
getModifiedEnv settings = do
|
|
fmap (map $ fixEnv $ binDir settings) getEnvironment
|
|
where
|
|
fixEnv :: FilePath -> (String, String) -> (String, String)
|
|
fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
|
|
fixEnv _ x = x
|
|
|
|
-- | Separate for the PATH environment variable
|
|
pathSep :: Char
|
|
#ifdef mingw32_HOST_OS
|
|
pathSep = ';'
|
|
#else
|
|
pathSep = ':'
|
|
#endif
|