stack-0.1.10.0/src/ 0000755 0000000 0000000 00000000000 12630315471 012013 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Control/ 0000755 0000000 0000000 00000000000 12546477354 013452 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Control/Concurrent/ 0000755 0000000 0000000 00000000000 12623647202 015557 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/ 0000755 0000000 0000000 00000000000 12571621073 012666 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/Aeson/ 0000755 0000000 0000000 00000000000 12623647202 013733 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/Attoparsec/ 0000755 0000000 0000000 00000000000 12623647202 014773 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/Binary/ 0000755 0000000 0000000 00000000000 12623647202 014112 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/IORef/ 0000755 0000000 0000000 00000000000 12571621073 013632 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/Maybe/ 0000755 0000000 0000000 00000000000 12623647202 013723 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Data/Set/ 0000755 0000000 0000000 00000000000 12546477354 013436 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Distribution/ 0000755 0000000 0000000 00000000000 12601012655 014466 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Distribution/Version/ 0000755 0000000 0000000 00000000000 12601012655 016113 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Network/ 0000755 0000000 0000000 00000000000 12546477354 013463 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Network/HTTP/ 0000755 0000000 0000000 00000000000 12623647202 014225 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Network/HTTP/Download/ 0000755 0000000 0000000 00000000000 12630352213 015765 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Options/ 0000755 0000000 0000000 00000000000 12546477354 013465 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Options/Applicative/ 0000755 0000000 0000000 00000000000 12630352213 015702 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Options/Applicative/Builder/ 0000755 0000000 0000000 00000000000 12623647202 017277 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Path/ 0000755 0000000 0000000 00000000000 12623647202 012711 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/ 0000755 0000000 0000000 00000000000 12630352213 013053 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Build/ 0000755 0000000 0000000 00000000000 12630352213 014112 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Config/ 0000755 0000000 0000000 00000000000 12630352213 014260 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Docker/ 0000755 0000000 0000000 00000000000 12607713542 014274 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Setup/ 0000755 0000000 0000000 00000000000 12623647202 014162 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Sig/ 0000755 0000000 0000000 00000000000 12630352213 013575 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Stack/Types/ 0000755 0000000 0000000 00000000000 12630352213 014157 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/System/ 0000755 0000000 0000000 00000000000 12546477354 013316 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/System/Process/ 0000755 0000000 0000000 00000000000 12630352213 014710 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/main/ 0000755 0000000 0000000 00000000000 12630352213 012732 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/ 0000755 0000000 0000000 00000000000 12546477354 013011 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/Network/ 0000755 0000000 0000000 00000000000 12546477354 014442 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/Network/HTTP/ 0000755 0000000 0000000 00000000000 12546477354 015221 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/Network/HTTP/Download/ 0000755 0000000 0000000 00000000000 12607713542 016756 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/Stack/ 0000755 0000000 0000000 00000000000 12630352213 014032 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/test/Stack/Build/ 0000755 0000000 0000000 00000000000 12571621073 015100 5 ustar 00 0000000 0000000 stack-0.1.10.0/test/ 0000755 0000000 0000000 00000000000 12546477354 012222 5 ustar 00 0000000 0000000 stack-0.1.10.0/test/integration/ 0000755 0000000 0000000 00000000000 12623647202 014530 5 ustar 00 0000000 0000000 stack-0.1.10.0/test/integration/lib/ 0000755 0000000 0000000 00000000000 12630352213 015267 5 ustar 00 0000000 0000000 stack-0.1.10.0/test/package-dump/ 0000755 0000000 0000000 00000000000 12546477354 014560 5 ustar 00 0000000 0000000 stack-0.1.10.0/src/Options/Applicative/Builder/Extra.hs 0000644 0000000 0000000 00000014723 12623647202 020725 0 ustar 00 0000000 0000000 -- | Extra functions for optparse-applicative.
module Options.Applicative.Builder.Extra
(boolFlags
,boolFlagsNoDefault
,maybeBoolFlags
,enableDisableFlags
,enableDisableFlagsNoDefault
,extraHelpOption
,execExtraHelp
,textOption
,textArgument)
where
import Control.Monad (when)
import Options.Applicative
import Options.Applicative.Types (readerAsk)
import System.Environment (withArgs)
import System.FilePath (takeBaseName)
import Data.Text (Text)
import qualified Data.Text as T
-- | Enable/disable flags for a 'Bool'.
boolFlags :: Bool -- ^ Default value
-> String -- ^ Flag name
-> String -- ^ Help suffix
-> Mod FlagFields Bool
-> Parser Bool
boolFlags defaultValue = enableDisableFlags defaultValue True False
-- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>').
boolFlagsNoDefault :: Maybe Bool -- ^ Hide the enabling or disabling flag from the
-- brief description?
-> String -- ^ Flag name
-> String -- ^ Help suffix
-> Mod FlagFields Bool
-> Parser Bool
boolFlagsNoDefault = enableDisableFlagsNoDefault True False
-- | Enable/disable flags for a @('Maybe' 'Bool')@.
maybeBoolFlags :: String -- ^ Flag name
-> String -- ^ Help suffix
-> Mod FlagFields (Maybe Bool)
-> Parser (Maybe Bool)
maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
-- | Enable/disable flags for any type.
enableDisableFlags :: (Eq a)
=> a -- ^ Default value
-> a -- ^ Enabled value
-> a -- ^ Disabled value
-> String -- ^ Name
-> String -- ^ Help suffix
-> Mod FlagFields a
-> Parser a
enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|>
pure defaultValue
-- | Enable/disable flags for any type, without a default (to allow chaining with '<|>')
enableDisableFlagsNoDefault :: (Eq a)
=> a -- ^ Enabled value
-> a -- ^ Disabled value
-> Maybe a -- ^ Hide the enabling or disabling flag
-- from the brief description??
-> String -- ^ Name
-> String -- ^ Help suffix
-> Mod FlagFields a
-> Parser a
enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods =
last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods)
enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> Maybe a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods =
let hideEnabled = Just enabledValue == maybeHideValue
hideDisabled = Just disabledValue == maybeHideValue
in flag'
enabledValue
((if hideEnabled
then hidden <> internal
else idm) <>
long name <>
help
(concat $ concat
[ ["Enable ", helpSuffix]
, [" (--no-" ++ name ++ " to disable)" | hideDisabled]]) <>
mods) <|>
flag'
enabledValue
(hidden <> internal <> long ("enable-" ++ name) <> mods) <|>
flag'
disabledValue
((if hideDisabled
then hidden <> internal
else idm) <>
long ("no-" ++ name) <>
help
(concat $ concat
[ ["Disable ", helpSuffix]
, [" (--" ++ name ++ " to enable)" | hideEnabled]]) <>
mods) <|>
flag'
disabledValue
(hidden <> internal <> long ("disable-" ++ name) <> mods)
-- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
--
-- To actually have that help appear, use 'execExtraHelp' before executing the main parser.
extraHelpOption :: Bool -- ^ Hide from the brief description?
-> String -- ^ Program name, e.g. @"stack"@
-> String -- ^ Option glob expression, e.g. @"docker*"@
-> String -- ^ Help option name, e.g. @"docker-help"@
-> Parser (a -> a)
extraHelpOption hide progName fakeName helpName =
infoOption (optDesc' ++ ".") (long helpName <> hidden <> internal) <*>
infoOption (optDesc' ++ ".") (long fakeName <>
help optDesc' <>
(if hide then hidden <> internal else idm))
where optDesc' = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"]
-- | Display extra help if extra help option passed in arguments.
--
-- Since optparse-applicative doesn't allow an arbitrary IO action for an 'abortOption', this
-- was the best way I found that doesn't require manually formatting the help.
execExtraHelp :: [String] -- ^ Command line arguments
-> String -- ^ Extra help option name, e.g. @"docker-help"@
-> Parser a -- ^ Option parser for the relevant command
-> String -- ^ Option description
-> IO ()
execExtraHelp args helpOpt parser pd =
when (args == ["--" ++ helpOpt]) $
withArgs ["--help"] $ do
_ <- execParser (info (hiddenHelper <*>
((,) <$>
parser <*>
some (strArgument (metavar "OTHER ARGUMENTS"))))
(fullDesc <> progDesc pd))
return ()
where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal)
-- | 'option', specialized to 'Text'.
textOption :: Mod OptionFields Text -> Parser Text
textOption = option (T.pack <$> readerAsk)
-- | 'argument', specialized to 'Text'.
textArgument :: Mod ArgumentFields Text -> Parser Text
textArgument = argument (T.pack <$> readerAsk)
stack-0.1.10.0/src/Options/Applicative/Args.hs 0000644 0000000 0000000 00000002767 12562412301 017145 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- | Accepting arguments to be passed through to a sub-process.
module Options.Applicative.Args
(argsArgument
,argsOption
,cmdOption
,parseArgsFromString)
where
import Data.Attoparsec.Args
import qualified Data.Attoparsec.Text as P
import qualified Data.Text as T
import qualified Options.Applicative as O
-- | An argument which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.
argsArgument :: O.Mod O.ArgumentFields [String] -> O.Parser [String]
argsArgument =
O.argument
(do string <- O.str
either O.readerError return (parseArgsFromString string))
-- | An option which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.
argsOption :: O.Mod O.OptionFields [String] -> O.Parser [String]
argsOption =
O.option
(do string <- O.str
either O.readerError return (parseArgsFromString string))
-- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@
cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String])
cmdOption =
O.option
(do string <- O.str
xs <- either O.readerError return (parseArgsFromString string)
case xs of
[] -> O.readerError "Must provide a command"
x:xs' -> return (x, xs'))
-- | Parse from a string.
parseArgsFromString :: String -> Either String [String]
parseArgsFromString = P.parseOnly (argsParser Escaping) . T.pack
stack-0.1.10.0/src/Options/Applicative/Complicated.hs 0000644 0000000 0000000 00000012370 12630352213 020465 0 ustar 00 0000000 0000000 -- | Simple interface to complicated program arguments.
--
-- This is a "fork" of the @optparse-simple@ package that has some workarounds for
-- optparse-applicative issues that become problematic with programs that have many options and
-- subcommands. Because it makes the interface more complex, these workarounds are not suitable for
-- pushing upstream to optparse-applicative.
module Options.Applicative.Complicated
( addCommand
, addSubCommands
, complicatedOptions
, complicatedParser
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Writer
import Data.Monoid
import Data.Version
import Options.Applicative
import Options.Applicative.Types
import Options.Applicative.Builder.Internal
import System.Environment
-- | Generate and execute a complicated options parser.
complicatedOptions
:: Monoid a
=> Version
-- ^ numeric version
-> Maybe String
-- ^ version string
-> String
-- ^ header
-> String
-- ^ program description
-> Parser a
-- ^ common settings
-> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a)))
-- ^ optional handler for parser failure; 'handleParseResult' is called by
-- default
-> EitherT b (Writer (Mod CommandFields (b,a))) ()
-- ^ commands (use 'addCommand')
-> IO (a,b)
complicatedOptions numericVersion versionString h pd commonParser mOnFailure commandParser =
do args <- getArgs
(a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of
Failure _ | null args -> withArgs ["--help"] (execParser parser)
-- call onFailure handler if it's present and parsing options failed
Failure f | Just onFailure <- mOnFailure -> onFailure f args
parseResult -> handleParseResult parseResult
return (mappend c a,b)
where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc
desc = fullDesc <> header h <> progDesc pd
versionOptions =
case versionString of
Nothing -> versionOption (showVersion numericVersion)
Just s -> versionOption s <*> numericVersionOption
versionOption s =
infoOption
s
(long "version" <>
help "Show version")
numericVersionOption =
infoOption
(showVersion numericVersion)
(long "numeric-version" <>
help "Show only version number")
-- | Add a command to the options dispatcher.
addCommand :: String -- ^ command string
-> String -- ^ title of command
-> String -- ^ footer of command help
-> (a -> b) -- ^ constructor to wrap up command in common data type
-> Parser c -- ^ common parser
-> Parser a -- ^ command parser
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addCommand cmd title footerStr constr =
addCommand' cmd title footerStr (\a c -> (constr a,c))
-- | Add a command that takes sub-commands to the options dispatcher.
addSubCommands
:: Monoid c
=> String
-- ^ command string
-> String
-- ^ title of command
-> String
-- ^ footer of command help
-> Parser c
-- ^ common parser
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
-- ^ sub-commands (use 'addCommand')
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addSubCommands cmd title footerStr commonParser commandParser =
addCommand' cmd
title
footerStr
(\(c1,(a,c2)) c3 -> (a,mconcat [c3, c2, c1]))
commonParser
(complicatedParser commonParser commandParser)
-- | Add a command to the options dispatcher.
addCommand' :: String -- ^ command string
-> String -- ^ title of command
-> String -- ^ footer of command help
-> (a -> c -> (b,c)) -- ^ constructor to wrap up command in common data type
-> Parser c -- ^ common parser
-> Parser a -- ^ command parser
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addCommand' cmd title footerStr constr commonParser inner =
lift (tell (command cmd
(info (constr <$> inner <*> commonParser)
(progDesc title <> footer footerStr))))
-- | Generate a complicated options parser.
complicatedParser
:: Monoid a
=> Parser a
-- ^ common settings
-> EitherT b (Writer (Mod CommandFields (b,a))) ()
-- ^ commands (use 'addCommand')
-> Parser (a,(b,a))
complicatedParser commonParser commandParser =
(,) <$>
commonParser <*>
case runWriter (runEitherT commandParser) of
(Right (),d) -> hsubparser' d
(Left b,_) -> pure (b,mempty)
-- way to do in 'addCommand' | Subparser with @--help@ argument. Borrowed with slight modification
-- from Options.Applicative.Extra.
hsubparser' :: Mod CommandFields a -> Parser a
hsubparser' m = mkParser d g rdr
where
Mod _ d g = m `mappend` metavar "COMMAND"
(cmds, subs) = mkCommand m
rdr = CmdReader cmds (fmap add_helper . subs)
add_helper pinfo = pinfo
{ infoParser = infoParser pinfo <**> helpOption }
-- | Non-hidden help option.
helpOption :: Parser (a -> a)
helpOption =
abortOption ShowHelpText $
long "help" <>
help "Show this help text"
stack-0.1.10.0/src/Stack/BuildPlan.hs 0000644 0000000 0000000 00000074716 12623647202 015307 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
-- | Resolving a build plan for a set of packages in a given Stackage
-- snapshot.
module Stack.BuildPlan
( BuildPlanException (..)
, MiniBuildPlan(..)
, MiniPackageInfo(..)
, Snapshots (..)
, getSnapshots
, loadMiniBuildPlan
, resolveBuildPlan
, findBuildPlan
, ToolMap
, getToolMap
, shadowMiniBuildPlan
, parseCustomMiniBuildPlan
) where
import Control.Applicative
import Control.Exception (assert)
import Control.Monad (liftM, forM)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (State, execState, get, modify,
put)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Crypto.Hash.SHA256 as SHA256
import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:), (.:?), (.!=))
import Data.Binary.VersionTagged (taggedDecodeOrLoad)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time (Day)
import qualified Data.Traversable as Tr
import Data.Typeable (Typeable)
import Data.Yaml (decodeEither', decodeFileEither)
import Distribution.PackageDescription (GenericPackageDescription,
flagDefault, flagManual,
flagName, genPackageFlags,
executables, exeName, library, libBuildInfo, buildable)
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.Version as C
import Distribution.Text (display)
import Network.HTTP.Download
import Network.HTTP.Types (Status(..))
import Network.HTTP.Client (checkStatus)
import Path
import Path.IO
import Prelude -- Fix AMP warning
import Stack.Constants
import Stack.Fetch
import Stack.Package
import Stack.Types
import Stack.Types.StackT
import System.Directory (canonicalizePath)
import qualified System.FilePath as FP
data BuildPlanException
= UnknownPackages
(Path Abs File) -- stack.yaml file
(Map PackageName (Maybe Version, (Set PackageName))) -- truly unknown
(Map PackageName (Set PackageIdentifier)) -- shadowed
| SnapshotNotFound SnapName
deriving (Typeable)
instance Exception BuildPlanException
instance Show BuildPlanException where
show (SnapshotNotFound snapName) = unlines
[ "SnapshotNotFound " ++ snapName'
, "Non existing resolver: " ++ snapName' ++ "."
, "For a complete list of available snapshots see https://www.stackage.org/snapshots"
]
where snapName' = show $ renderSnapName snapName
show (UnknownPackages stackYaml unknown shadowed) =
unlines $ unknown' ++ shadowed'
where
unknown' :: [String]
unknown'
| Map.null unknown = []
| otherwise = concat
[ ["The following packages do not exist in the build plan:"]
, map go (Map.toList unknown)
, case mapMaybe goRecommend $ Map.toList unknown of
[] -> []
rec ->
("Recommended action: modify the extra-deps field of " ++
toFilePath stackYaml ++
" to include the following:")
: (rec
++ ["Note: further dependencies may need to be added"])
, case mapMaybe getNoKnown $ Map.toList unknown of
[] -> []
noKnown ->
[ "There are no known versions of the following packages:"
, intercalate ", " $ map packageNameString noKnown
]
]
where
go (dep, (_, users)) | Set.null users = packageNameString dep
go (dep, (_, users)) = concat
[ packageNameString dep
, " (used by "
, intercalate ", " $ map packageNameString $ Set.toList users
, ")"
]
goRecommend (name, (Just version, _)) =
Just $ "- " ++ packageIdentifierString (PackageIdentifier name version)
goRecommend (_, (Nothing, _)) = Nothing
getNoKnown (name, (Nothing, _)) = Just name
getNoKnown (_, (Just _, _)) = Nothing
shadowed' :: [String]
shadowed'
| Map.null shadowed = []
| otherwise = concat
[ ["The following packages are shadowed by local packages:"]
, map go (Map.toList shadowed)
, ["Recommended action: modify the extra-deps field of " ++
toFilePath stackYaml ++
" to include the following:"]
, extraDeps
, ["Note: further dependencies may need to be added"]
]
where
go (dep, users) | Set.null users = concat
[ packageNameString dep
, " (internal stack error: this should never be null)"
]
go (dep, users) = concat
[ packageNameString dep
, " (used by "
, intercalate ", "
$ map (packageNameString . packageIdentifierName)
$ Set.toList users
, ")"
]
extraDeps = map (\ident -> "- " ++ packageIdentifierString ident)
$ Set.toList
$ Set.unions
$ Map.elems shadowed
-- | Determine the necessary packages to install to have the given set of
-- packages available.
--
-- This function will not provide test suite and benchmark dependencies.
--
-- This may fail if a target package is not present in the @BuildPlan@.
resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m)
=> MiniBuildPlan
-> (PackageName -> Bool) -- ^ is it shadowed by a local package?
-> Map PackageName (Set PackageName) -- ^ required packages, and users of it
-> m ( Map PackageName (Version, Map FlagName Bool)
, Map PackageName (Set PackageName)
)
resolveBuildPlan mbp isShadowed packages
| Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs)
| otherwise = do
bconfig <- asks getBuildConfig
let maxVer =
Map.fromListWith max $
map toTuple $
Map.keys (bcPackageCaches bconfig)
unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x ->
(Map.lookup ident maxVer, x)
throwM $ UnknownPackages
(bcStackYaml bconfig)
unknown
(rsShadowed rs)
where
rs = getDeps mbp isShadowed packages
data ResolveState = ResolveState
{ rsVisited :: Map PackageName (Set PackageName) -- ^ set of shadowed dependencies
, rsUnknown :: Map PackageName (Set PackageName)
, rsShadowed :: Map PackageName (Set PackageIdentifier)
, rsToInstall :: Map PackageName (Version, Map FlagName Bool)
, rsUsedBy :: Map PackageName (Set PackageName)
}
toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)
=> CompilerVersion -- ^ Compiler version
-> Map PackageName Version -- ^ cores
-> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages
-> m MiniBuildPlan
toMiniBuildPlan compilerVersion corePackages packages = do
$logInfo "Caching build plan"
-- Determine the dependencies of all of the packages in the build plan. We
-- handle core packages specially, because some of them will not be in the
-- package index. For those, we allow missing packages to exist, and then
-- remove those from the list of dependencies, since there's no way we'll
-- ever reinstall them anyway.
(cores, missingCores) <- addDeps True compilerVersion
$ fmap (, Map.empty) corePackages
(extras, missing) <- addDeps False compilerVersion packages
assert (Set.null missing) $ return MiniBuildPlan
{ mbpCompilerVersion = compilerVersion
, mbpPackages = Map.unions
[ fmap (removeMissingDeps (Map.keysSet cores)) cores
, extras
, Map.fromList $ map goCore $ Set.toList missingCores
]
}
where
goCore (PackageIdentifier name version) = (name, MiniPackageInfo
{ mpiVersion = version
, mpiFlags = Map.empty
, mpiPackageDeps = Set.empty
, mpiToolDeps = Set.empty
, mpiExes = Set.empty
, mpiHasLibrary = True
})
removeMissingDeps cores mpi = mpi
{ mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi)
}
-- | Add in the resolved dependencies from the package index
addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)
=> Bool -- ^ allow missing
-> CompilerVersion -- ^ Compiler version
-> Map PackageName (Version, Map FlagName Bool)
-> m (Map PackageName MiniPackageInfo, Set PackageIdentifier)
addDeps allowMissing compilerVersion toCalc = do
menv <- getMinimalEnvOverride
platform <- asks $ configPlatform . getConfig
(resolvedMap, missingIdents) <-
if allowMissing
then do
(missingNames, missingIdents, m) <-
resolvePackagesAllowMissing menv (Map.keysSet idents0) Set.empty
assert (Set.null missingNames)
$ return (m, missingIdents)
else do
m <- resolvePackages menv (Map.keysSet idents0) Set.empty
return (m, Set.empty)
let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap)
$ \(ident, rp) ->
(indexName $ rpIndex rp,
[( ident
, rpCache rp
, maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc
)])
res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs
$ \ident flags cabalBS -> do
(_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS
let packageConfig = PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = flags
, packageConfigCompilerVersion = compilerVersion
, packageConfigPlatform = platform
}
name = packageIdentifierName ident
pd = resolvePackageDescription packageConfig gpd
exes = Set.fromList $ map (ExeName . S8.pack . exeName) $ executables pd
notMe = Set.filter (/= name) . Map.keysSet
return (name, MiniPackageInfo
{ mpiVersion = packageIdentifierVersion ident
, mpiFlags = flags
, mpiPackageDeps = notMe $ packageDependencies pd
, mpiToolDeps = Map.keysSet $ packageToolDependencies pd
, mpiExes = exes
, mpiHasLibrary = maybe
False
(buildable . libBuildInfo)
(library pd)
})
return (Map.fromList $ concat res, missingIdents)
where
idents0 = Map.fromList
$ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f))
$ Map.toList toCalc
-- | Resolve all packages necessary to install for
getDeps :: MiniBuildPlan
-> (PackageName -> Bool) -- ^ is it shadowed by a local package?
-> Map PackageName (Set PackageName)
-> ResolveState
getDeps mbp isShadowed packages =
execState (mapM_ (uncurry goName) $ Map.toList packages) ResolveState
{ rsVisited = Map.empty
, rsUnknown = Map.empty
, rsShadowed = Map.empty
, rsToInstall = Map.empty
, rsUsedBy = Map.empty
}
where
toolMap = getToolMap mbp
-- | Returns a set of shadowed packages we depend on.
goName :: PackageName -> Set PackageName -> State ResolveState (Set PackageName)
goName name users = do
-- Even though we could check rsVisited first and short-circuit things
-- earlier, lookup in mbpPackages first so that we can produce more
-- usable error information on missing dependencies
rs <- get
put rs
{ rsUsedBy = Map.insertWith Set.union name users $ rsUsedBy rs
}
case Map.lookup name $ mbpPackages mbp of
Nothing -> do
modify $ \rs' -> rs'
{ rsUnknown = Map.insertWith Set.union name users $ rsUnknown rs'
}
return Set.empty
Just mpi -> case Map.lookup name (rsVisited rs) of
Just shadowed -> return shadowed
Nothing -> do
put rs { rsVisited = Map.insert name Set.empty $ rsVisited rs }
let depsForTools = Set.unions $ mapMaybe (flip Map.lookup toolMap) (Set.toList $ mpiToolDeps mpi)
let deps = Set.filter (/= name) (mpiPackageDeps mpi <> depsForTools)
shadowed <- fmap F.fold $ Tr.forM (Set.toList deps) $ \dep ->
if isShadowed dep
then do
modify $ \rs' -> rs'
{ rsShadowed = Map.insertWith
Set.union
dep
(Set.singleton $ PackageIdentifier name (mpiVersion mpi))
(rsShadowed rs')
}
return $ Set.singleton dep
else do
shadowed <- goName dep (Set.singleton name)
let m = Map.fromSet (\_ -> Set.singleton $ PackageIdentifier name (mpiVersion mpi)) shadowed
modify $ \rs' -> rs'
{ rsShadowed = Map.unionWith Set.union m $ rsShadowed rs'
}
return shadowed
modify $ \rs' -> rs'
{ rsToInstall = Map.insert name (mpiVersion mpi, mpiFlags mpi) $ rsToInstall rs'
, rsVisited = Map.insert name shadowed $ rsVisited rs'
}
return shadowed
-- | Look up with packages provide which tools.
type ToolMap = Map ByteString (Set PackageName)
-- | Map from tool name to package providing it
getToolMap :: MiniBuildPlan -> Map ByteString (Set PackageName)
getToolMap mbp =
Map.unionsWith Set.union
{- We no longer do this, following discussion at:
https://github.com/commercialhaskell/stack/issues/308#issuecomment-112076704
-- First grab all of the package names, for times where a build tool is
-- identified by package name
$ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps))
-}
-- And then get all of the explicit executable names
$ concatMap goPair (Map.toList ps)
where
ps = mbpPackages mbp
goPair (pname, mpi) =
map (flip Map.singleton (Set.singleton pname) . unExeName)
$ Set.toList
$ mpiExes mpi
-- | Download the 'Snapshots' value from stackage.org.
getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)
=> m Snapshots
getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON
-- | Most recent Nightly and newest LTS version per major release.
data Snapshots = Snapshots
{ snapshotsNightly :: !Day
, snapshotsLts :: !(IntMap Int)
}
deriving Show
instance FromJSON Snapshots where
parseJSON = withObject "Snapshots" $ \o -> Snapshots
<$> (o .: "nightly" >>= parseNightly)
<*> (fmap IntMap.unions
$ mapM parseLTS
$ map snd
$ filter (isLTS . fst)
$ HM.toList o)
where
parseNightly t =
case parseSnapName t of
Left e -> fail $ show e
Right (LTS _ _) -> fail "Unexpected LTS value"
Right (Nightly d) -> return d
isLTS = ("lts-" `T.isPrefixOf`)
parseLTS = withText "LTS" $ \t ->
case parseSnapName t of
Left e -> fail $ show e
Right (LTS x y) -> return $ IntMap.singleton x y
Right (Nightly _) -> fail "Unexpected nightly value"
-- | Load up a 'MiniBuildPlan', preferably from cache
loadMiniBuildPlan
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m)
=> SnapName
-> m MiniBuildPlan
loadMiniBuildPlan name = do
path <- configMiniBuildPlanCache name
taggedDecodeOrLoad path $ liftM buildPlanFixes $ do
bp <- loadBuildPlan name
toMiniBuildPlan
(siCompilerVersion $ bpSystemInfo bp)
(siCorePackages $ bpSystemInfo bp)
(fmap goPP $ bpPackages bp)
where
goPP pp =
( ppVersion pp
, pcFlagOverrides $ ppConstraints pp
)
-- | Some hard-coded fixes for build plans, hopefully to be irrelevant over
-- time.
buildPlanFixes :: MiniBuildPlan -> MiniBuildPlan
buildPlanFixes mbp = mbp
{ mbpPackages = Map.fromList $ map go $ Map.toList $ mbpPackages mbp
}
where
go (name, mpi) =
(name, mpi
{ mpiFlags = goF (packageNameString name) (mpiFlags mpi)
})
goF "persistent-sqlite" = Map.insert $(mkFlagName "systemlib") False
goF "yaml" = Map.insert $(mkFlagName "system-libyaml") False
goF _ = id
-- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy
-- if available, otherwise downloading from Github.
loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env)
=> SnapName
-> m BuildPlan
loadBuildPlan name = do
env <- ask
let stackage = getStackRoot env
file' <- parseRelFile $ T.unpack file
let fp = buildPlanDir stackage file'
$logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)
eres <- liftIO $ decodeFileEither $ toFilePath fp
case eres of
Right bp -> return bp
Left e -> do
$logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)
createTree (parent fp)
req <- parseUrl $ T.unpack url
$logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."
$logDebug $ "Downloading build plan from: " <> url
_ <- download req { checkStatus = handle404 } fp
$logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan."
liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return
where
file = renderSnapName name <> ".yaml"
reponame =
case name of
LTS _ _ -> "lts-haskell"
Nightly _ -> "stackage-nightly"
url = rawGithubUrl "fpco" reponame "master" file
handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name
handle404 _ _ _ = Nothing
-- | Find the set of @FlagName@s necessary to get the given
-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will
-- only modify non-manual flags, and will prefer default values for flags.
-- Returns @Nothing@ if no combination exists.
checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)
=> Map PackageName Version -- ^ locally available packages
-> MiniBuildPlan
-> GenericPackageDescription
-> m (Either DepErrors (Map PackageName (Map FlagName Bool)))
checkBuildPlan locals mbp gpd = do
platform <- asks (configPlatform . getConfig)
return $ loop platform flagOptions
where
packages = Map.union locals $ fmap mpiVersion $ mbpPackages mbp
loop _ [] = assert False $ Left Map.empty
loop platform (flags:rest)
| Map.null errs = Right $
if Map.null flags
then Map.empty
else Map.singleton (packageName pkg) flags
| null rest = Left errs
| otherwise = loop platform rest
where
errs = checkDeps (packageName pkg) (packageDeps pkg) packages
pkg = resolvePackage pkgConfig gpd
pkgConfig = PackageConfig
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = True
, packageConfigFlags = flags
, packageConfigCompilerVersion = compilerVersion
, packageConfigPlatform = platform
}
compilerVersion = mbpCompilerVersion mbp
flagName' = fromCabalFlagName . flagName
-- Avoid exponential complexity in flag combinations making us sad pandas.
-- See: https://github.com/commercialhaskell/stack/issues/543
maxFlagOptions = 128
flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd
getOptions f
| flagManual f = [(flagName' f, flagDefault f)]
| flagDefault f =
[ (flagName' f, True)
, (flagName' f, False)
]
| otherwise =
[ (flagName' f, False)
, (flagName' f, True)
]
-- | Checks if the given package dependencies can be satisfied by the given set
-- of packages. Will fail if a package is either missing or has a version
-- outside of the version range.
checkDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkDeps myName deps packages =
Map.unionsWith mappend $ map go $ Map.toList deps
where
go :: (PackageName, VersionRange) -> DepErrors
go (name, range) =
case Map.lookup name packages of
Nothing -> Map.singleton name DepError
{ deVersion = Nothing
, deNeededBy = Map.singleton myName range
}
Just v
| withinRange v range -> Map.empty
| otherwise -> Map.singleton name DepError
{ deVersion = Just v
, deNeededBy = Map.singleton myName range
}
type DepErrors = Map PackageName DepError
data DepError = DepError
{ deVersion :: !(Maybe Version)
, deNeededBy :: !(Map PackageName VersionRange)
}
instance Monoid DepError where
mempty = DepError Nothing Map.empty
mappend (DepError a x) (DepError b y) = DepError
(maybe a Just b)
(Map.unionWith C.intersectVersionRanges x y)
-- | Find a snapshot and set of flags that is compatible with the given
-- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.
findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)
=> [GenericPackageDescription]
-> [SnapName]
-> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))
findBuildPlan gpds0 =
loop
where
loop [] = return Nothing
loop (name:names') = do
mbp <- loadMiniBuildPlan name
$logInfo $ "Checking against build plan " <> renderSnapName name
res <- mapM (checkBuildPlan localNames mbp) gpds0
case partitionEithers res of
([], flags) -> return $ Just (name, Map.unions flags)
(errs, _) -> do
$logInfo ""
$logInfo "* Build plan did not match your requirements:"
displayDepErrors $ Map.unionsWith mappend errs
$logInfo ""
loop names'
localNames = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds0
fromCabalIdent (C.PackageIdentifier name version) =
(fromCabalPackageName name, fromCabalVersion version)
displayDepErrors :: MonadLogger m => DepErrors -> m ()
displayDepErrors errs =
F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do
$logInfo $ T.concat
[ " "
, T.pack $ packageNameString depName
, case mversion of
Nothing -> " not found"
Just version -> T.concat
[ " version "
, T.pack $ versionString version
, " found"
]
]
F.forM_ (Map.toList neededBy) $ \(user, range) -> $logInfo $ T.concat
[ " - "
, T.pack $ packageNameString user
, " requires "
, T.pack $ display range
]
$logInfo ""
shadowMiniBuildPlan :: MiniBuildPlan
-> Set PackageName
-> (MiniBuildPlan, Map PackageName MiniPackageInfo)
shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed =
(MiniBuildPlan cv $ Map.fromList met, Map.fromList unmet)
where
pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed
depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1)
check visited name
| name `Set.member` visited =
error $ "shadowMiniBuildPlan: cycle detected, your MiniBuildPlan is broken: " ++ show (visited, name)
| otherwise = do
m <- get
case Map.lookup name m of
Just x -> return x
Nothing ->
case Map.lookup name pkgs1 of
Nothing
| name `Set.member` shadowed -> return False
-- In this case, we have to assume that we're
-- constructing a build plan on a different OS or
-- architecture, and therefore different packages
-- are being chosen. The common example of this is
-- the Win32 package.
| otherwise -> return True
Just mpi -> do
let visited' = Set.insert name visited
ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi)
let res = and ress
modify $ \m' -> Map.insert name res m'
return res
(met, unmet) = partitionEithers $ map toEither $ Map.toList pkgs1
toEither pair@(name, _) =
wrapper pair
where
wrapper =
case Map.lookup name depsMet of
Just True -> Left
Just False -> Right
Nothing -> assert False Right
parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
=> Path Abs File -- ^ stack.yaml file location
-> T.Text -> m MiniBuildPlan
parseCustomMiniBuildPlan stackYamlFP url0 = do
yamlFP <- getYamlFP url0
yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP
let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS
binaryFilename <- parseRelFile $ yamlHash ++ ".bin"
customPlanDir <- getCustomPlanDir
let binaryFP = customPlanDir $(mkRelDir "bin") binaryFilename
taggedDecodeOrLoad binaryFP $ do
cs <- either throwM return $ decodeEither' yamlBS
let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool))
addFlags (PackageIdentifier name ver) =
(name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs))
toMiniBuildPlan
(csCompilerVersion cs)
Map.empty
(Map.fromList $ map addFlags $ Set.toList $ csPackages cs)
where
getCustomPlanDir = do
root <- asks $ configStackRoot . getConfig
return $ root $(mkRelDir "custom-plan")
-- Get the path to the YAML file
getYamlFP url =
case parseUrl $ T.unpack url of
Just req -> getYamlFPFromReq url req
Nothing -> getYamlFPFromFile url
getYamlFPFromReq url req = do
let hashStr = S8.unpack $ B16.encode $ SHA256.hash $ encodeUtf8 url
hashFP <- parseRelFile $ hashStr ++ ".yaml"
customPlanDir <- getCustomPlanDir
let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP
_ <- download req cacheFP
return cacheFP
getYamlFPFromFile url = do
fp <- liftIO $ canonicalizePath $ toFilePath (parent stackYamlFP) FP. T.unpack (fromMaybe url $
T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)
parseAbsFile fp
data CustomSnapshot = CustomSnapshot
{ csCompilerVersion :: !CompilerVersion
, csPackages :: !(Set PackageIdentifier)
, csFlags :: !(Map PackageName (Map FlagName Bool))
}
instance FromJSON CustomSnapshot where
parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot
<$> ((o .: "compiler") >>= \t ->
case parseCompilerVersion t of
Nothing -> fail $ "Invalid compiler: " ++ T.unpack t
Just compilerVersion -> return compilerVersion)
<*> o .: "packages"
<*> o .:? "flags" .!= Map.empty
stack-0.1.10.0/src/Stack/Clean.hs 0000644 0000000 0000000 00000004374 12623647202 014450 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
-- | Clean a project.
module Stack.Clean
(clean
,CleanOpts(..)
,StackCleanException(..)
) where
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow,throwM)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader)
import Data.Foldable (forM_)
import Data.List ((\\),intercalate)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Typeable (Typeable)
import Path.IO (removeTreeIfExists)
import Stack.Build.Source (getLocalPackageViews)
import Stack.Build.Target (LocalPackageView(..))
import Stack.Constants (distDirFromDir)
import Stack.Types (HasEnvConfig,PackageName)
-- | Reset the build, i.e. remove the @dist@ directory
-- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@)
-- for all targets.
--
-- Throws 'StackCleanException'.
clean
:: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> CleanOpts
-> m ()
clean (CleanOpts targets) = do
locals <- getLocalPackageViews
case targets \\ Map.keys locals of
[] -> do
let lpvs =
if null targets
then Map.elems locals -- default to cleaning all local packages
else mapMaybe (`Map.lookup` locals) targets
forM_ lpvs $ \(LocalPackageView{lpvRoot = pkgDir},_) -> do
distDir <- distDirFromDir pkgDir
removeTreeIfExists distDir
pkgs -> throwM (NonLocalPackages pkgs)
-- | Options for cleaning a project.
newtype CleanOpts = CleanOpts
{ cleanOptsTargets :: [PackageName]
-- ^ Names of the packages to clean.
-- If the list is empty, every local package should be cleaned.
}
-- | Exceptions during cleanup.
newtype StackCleanException
= NonLocalPackages [PackageName]
deriving (Typeable)
instance Show StackCleanException where
show (NonLocalPackages pkgs) =
"The following packages are not part of this project: " ++
intercalate ", " (map show pkgs)
instance Exception StackCleanException
stack-0.1.10.0/src/Stack/Config.hs 0000644 0000000 0000000 00000070324 12630352213 014622 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
-- | The general Stack configuration that starts everything off. This should
-- be smart to falback if there is no stack.yaml, instead relying on
-- whatever files are available.
--
-- If there is no stack.yaml, and there is a cabal.config, we
-- read in those constraints, and if there's a cabal.sandbox.config,
-- we read any constraints from there and also find the package
-- database from there, etc. And if there's nothing, we should
-- probably default to behaving like cabal, possibly with spitting out
-- a warning that "you should run `stk init` to make things better".
module Stack.Config
(MiniConfig
,loadConfig
,loadMiniConfig
,packagesParser
,resolvePackageEntry
,getImplicitGlobalProjectDir
,getIsGMP4
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM)
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (Loc)
import Control.Monad.Reader (MonadReader, ask, runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Crypto.Hash.SHA256 as SHA256
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Yaml as Yaml
import Distribution.System (OS (..), Platform (..), buildPlatform)
import qualified Distribution.Text
import Distribution.Version (simplifyVersionRange)
import GHC.Conc (getNumProcessors)
import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)
import Network.HTTP.Download (download)
import Options.Applicative (Parser, strOption, long, help)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import qualified Paths_stack as Meta
import Safe (headMay)
import Stack.BuildPlan
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Constants
import qualified Stack.Image as Image
import Stack.Init
import Stack.PackageIndex
import Stack.Types
import Stack.Types.Internal
import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath)
import System.Environment
import System.IO
import System.Process.Read
-- | Get the latest snapshot resolver available.
getLatestResolver
:: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)
=> m Resolver
getLatestResolver = do
snapshots <- getSnapshots
let mlts = do
(x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
return (LTS x y)
snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts
return (ResolverSnapshot snap)
-- Interprets ConfigMonoid options.
configFromConfigMonoid
:: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)
=> Path Abs Dir -- ^ stack root, e.g. ~/.stack
-> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml
-> Maybe AbstractResolver
-> Maybe (Project, Path Abs File)
-> ConfigMonoid
-> m Config
configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject configMonoid@ConfigMonoid{..} = do
configWorkDir <- parseRelDir (fromMaybe ".stack-work" configMonoidWorkDir)
let configConnectionCount = fromMaybe 8 configMonoidConnectionCount
configHideTHLoading = fromMaybe True configMonoidHideTHLoading
configLatestSnapshotUrl = fromMaybe
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
configMonoidLatestSnapshotUrl
configPackageIndices = fromMaybe
[PackageIndex
{ indexName = IndexName "Hackage"
, indexLocation = ILGitHttp
"https://github.com/commercialhaskell/all-cabal-hashes.git"
"https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz"
, indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
, indexGpgVerify = False
, indexRequireHashes = False
}]
configMonoidPackageIndices
configGHCVariant0 = configMonoidGHCVariant
configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC
configInstallGHC = fromMaybe False configMonoidInstallGHC
configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck
configSkipMsys = fromMaybe False configMonoidSkipMsys
configExtraIncludeDirs = configMonoidExtraIncludeDirs
configExtraLibDirs = configMonoidExtraLibDirs
-- Only place in the codebase where platform is hard-coded. In theory
-- in the future, allow it to be configured.
(Platform defArch defOS) = buildPlatform
arch = fromMaybe defArch
$ configMonoidArch >>= Distribution.Text.simpleParse
os = fromMaybe defOS
$ configMonoidOS >>= Distribution.Text.simpleParse
configPlatform = Platform arch os
configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion
configConfigMonoid = configMonoid
configImage = Image.imgOptsFromMonoid configMonoidImageOpts
configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
configPlatformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
configDocker <-
dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts
configNix <- nixOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidNixOpts
rawEnv <- liftIO getEnvironment
origEnv <- mkEnvOverride configPlatform
$ augmentPathMap (map toFilePath configMonoidExtraPath)
$ Map.fromList
$ map (T.pack *** T.pack) rawEnv
let configEnvOverride _ = return origEnv
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform,configPlatformVariant)
configLocalProgramsBase <-
case configPlatform of
Platform _ Windows -> do
progsDir <- getWindowsProgsDir configStackRoot origEnv
return $ progsDir $(mkRelDir stackProgName)
_ ->
return $
configStackRoot $(mkRelDir "programs")
let configLocalPrograms = configLocalProgramsBase platformOnlyDir
configLocalBin <-
case configMonoidLocalBinPath of
Nothing -> do
localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
return $ localDir $(mkRelDir "bin")
Just userPath ->
(case mproject of
-- Not in a project
Nothing -> parseRelAsAbsDir userPath
-- Resolves to the project dir and appends the user path if it is relative
Just (_, configYaml) -> resolveDir (parent configYaml) userPath)
-- TODO: Either catch specific exceptions or add a
-- parseRelAsAbsDirMaybe utility and use it along with
-- resolveDirMaybe.
`catchAll`
const (throwM (NoSuchDirectory userPath))
configJobs <-
case configMonoidJobs of
Nothing -> liftIO getNumProcessors
Just i -> return i
let configConcurrentTests = fromMaybe True configMonoidConcurrentTests
let configTemplateParams = configMonoidTemplateParameters
configScmInit = configMonoidScmInit
configGhcOptions = configMonoidGhcOptions
configSetupInfoLocations = configMonoidSetupInfoLocations
configPvpBounds = fromMaybe PvpBoundsNone configMonoidPvpBounds
configModifyCodePage = fromMaybe True configMonoidModifyCodePage
configExplicitSetupDeps = configMonoidExplicitSetupDeps
configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions
configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions
configAllowNewer = fromMaybe False configMonoidAllowNewer
return Config {..}
-- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'GHCGMP4'.
getDefaultGHCVariant
:: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
=> EnvOverride -> Platform -> m GHCVariant
getDefaultGHCVariant menv (Platform _ Linux) = do
isGMP4 <- getIsGMP4 menv
return (if isGMP4 then GHCGMP4 else GHCStandard)
getDefaultGHCVariant _ _ = return GHCStandard
-- Determine whether 'stack' is linked with libgmp4 (libgmp.so.3)
getIsGMP4
:: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
=> EnvOverride -> m Bool
getIsGMP4 menv = do
executablePath <- liftIO getExecutablePath
elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]
return $
case elddOut of
Left _ -> False
Right lddOut -> hasLineWithFirstWord "libgmp.so.3" lddOut
where
hasLineWithFirstWord w =
elem (Just w) .
map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode
-- | Get the directory on Windows where we should install extra programs. For
-- more information, see discussion at:
-- https://github.com/fpco/minghc/issues/43#issuecomment-99737383
getWindowsProgsDir :: MonadThrow m
=> Path Abs Dir
-> EnvOverride
-> m (Path Abs Dir)
getWindowsProgsDir stackRoot m =
case Map.lookup "LOCALAPPDATA" $ unEnvOverride m of
Just t -> do
lad <- parseAbsDir $ T.unpack t
return $ lad $(mkRelDir "Programs")
Nothing -> return $ stackRoot $(mkRelDir "Programs")
-- | An environment with a subset of BuildConfig used for setup.
data MiniConfig = MiniConfig Manager GHCVariant Config
instance HasConfig MiniConfig where
getConfig (MiniConfig _ _ c) = c
instance HasStackRoot MiniConfig
instance HasHttpManager MiniConfig where
getHttpManager (MiniConfig man _ _) = man
instance HasPlatform MiniConfig
instance HasGHCVariant MiniConfig where
getGHCVariant (MiniConfig _ v _) = v
-- | Load the 'MiniConfig'.
loadMiniConfig
:: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
=> Config -> m MiniConfig
loadMiniConfig config = do
menv <- liftIO $ configEnvOverride config minimalEnvSettings
manager <- getHttpManager <$> ask
ghcVariant <-
case configGHCVariant0 config of
Just ghcVariant -> return ghcVariant
Nothing -> getDefaultGHCVariant menv (configPlatform config)
return (MiniConfig manager ghcVariant config)
-- | Load the configuration, using current directory, environment variables,
-- and defaults as necessary.
loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)
=> ConfigMonoid
-- ^ Config monoid from parsed command-line arguments
-> Maybe (Path Abs File)
-- ^ Override stack.yaml
-> Maybe (AbstractResolver)
-- ^ Override resolver
-> m (LoadConfig m)
loadConfig configArgs mstackYaml mresolver = do
stackRoot <- determineStackRoot
userConfigPath <- getDefaultUserConfigPath stackRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml
let extraConfigs =
-- non-project config files' existence of a docker section should never default docker
-- to enabled, so make it look like they didn't exist
map (\c -> c {configMonoidDockerOpts =
(configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}})
extraConfigs0
mproject <- loadProjectConfig mstackYaml
let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject
config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $
case mproject of
Nothing -> configArgs : extraConfigs
Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs
unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
return LoadConfig
{ lcConfig = config
, lcLoadBuildConfig = loadBuildConfig mproject config mresolver
, lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject
}
-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
-- values.
loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)
=> Maybe (Project, Path Abs File, ConfigMonoid)
-> Config
-> Maybe AbstractResolver -- override resolver
-> Maybe CompilerVersion -- override compiler
-> m BuildConfig
loadBuildConfig mproject config mresolver mcompiler = do
env <- ask
miniConfig <- loadMiniConfig config
(project', stackYamlFP) <- case mproject of
Just (project, fp, _) -> return (project, fp)
Nothing -> do
$logInfo "Run from outside a project, using implicit global project config"
destDir <- getImplicitGlobalProjectDir config
let dest :: Path Abs File
dest = destDir stackDotYaml
dest' :: FilePath
dest' = toFilePath dest
createTree destDir
exists <- fileExists dest
if exists
then do
ProjectAndConfigMonoid project _ <- loadYaml dest
when (getTerminal env) $
case mresolver of
Nothing ->
$logInfo ("Using resolver: " <> resolverName (projectResolver project) <>
" from implicit global project's config file: " <> T.pack dest')
Just aresolver -> do
let name =
case aresolver of
ARResolver resolver -> resolverName resolver
ARLatestNightly -> "nightly"
ARLatestLTS -> "lts"
ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x
ARGlobal -> "global"
$logInfo ("Using resolver: " <> name <>
" specified on command line")
return (project, dest)
else do
r <- runReaderT getLatestResolver miniConfig
$logInfo ("Using latest snapshot resolver: " <> resolverName r)
$logInfo ("Writing implicit global project config file to: " <> T.pack dest')
$logInfo "Note: You can change the snapshot via the resolver field there."
let p = Project
{ projectPackages = mempty
, projectExtraDeps = mempty
, projectFlags = mempty
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
}
liftIO $ do
S.writeFile dest' $ S.concat
[ "# This is the implicit global project's config file, which is only used when\n"
, "# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
, "# defaults for all projects. To change stack's default settings, edit\n"
, "# '", encodeUtf8 (T.pack $ toFilePath $ configUserConfigPath config), "' instead.\n"
, "#\n"
, "# For more information about stack's configuration, see\n"
, "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n"
, "#\n"
, Yaml.encode p]
S.writeFile (toFilePath $ parent dest $(mkRelFile "README.txt")) $ S.concat
[ "This is the implicit global project, which is used only when 'stack' is run\n"
, "outside of a real project.\n" ]
return (p, dest)
resolver <-
case mresolver of
Nothing -> return $ projectResolver project'
Just aresolver ->
runReaderT (makeConcreteResolver aresolver) miniConfig
let project = project'
{ projectResolver = resolver
, projectCompiler = mcompiler <|> projectCompiler project'
}
wantedCompiler <-
case projectCompiler project of
Just wantedCompiler -> return wantedCompiler
Nothing -> case projectResolver project of
ResolverSnapshot snapName -> do
mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig
return $ mbpCompilerVersion mbp
ResolverCustom _name url -> do
mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig
return $ mbpCompilerVersion mbp
ResolverCompiler wantedCompiler -> return wantedCompiler
extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project)
packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig
return BuildConfig
{ bcConfig = config
, bcResolver = projectResolver project
, bcWantedCompiler = wantedCompiler
, bcPackageEntries = projectPackages project
, bcExtraDeps = projectExtraDeps project
, bcExtraPackageDBs = extraPackageDBs
, bcStackYaml = stackYamlFP
, bcFlags = projectFlags project
, bcImplicitGlobal = isNothing mproject
, bcGHCVariant = getGHCVariant miniConfig
, bcPackageCaches = packageCaches
}
-- | Resolve a PackageEntry into a list of paths, downloading and cloning as
-- necessary.
resolvePackageEntry
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
,MonadBaseControl IO m, HasConfig env)
=> EnvOverride
-> Path Abs Dir -- ^ project root
-> PackageEntry
-> m [(Path Abs Dir, Bool)]
resolvePackageEntry menv projRoot pe = do
entryRoot <- resolvePackageLocation menv projRoot (peLocation pe)
paths <-
case peSubdirs pe of
[] -> return [entryRoot]
subs -> mapM (resolveDir entryRoot) subs
case peValidWanted pe of
Nothing -> return ()
Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md#packages"
return $ map (, not $ peExtraDep pe) paths
-- | Resolve a PackageLocation into a path, downloading and cloning as
-- necessary.
resolvePackageLocation
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
,MonadBaseControl IO m, HasConfig env)
=> EnvOverride
-> Path Abs Dir -- ^ project root
-> PackageLocation
-> m (Path Abs Dir)
resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
workDir <- getWorkDir
let nameBeforeHashing = case remotePackageType of
RPTHttpTarball -> url
RPTGit commit -> T.unwords [url, commit]
RPTHg commit -> T.unwords [url, commit, "hg"]
name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing
root = projRoot workDir $(mkRelDir "downloaded")
fileExtension = case remotePackageType of
RPTHttpTarball -> ".tar.gz"
_ -> ".unused"
fileRel <- parseRelFile $ name ++ fileExtension
dirRel <- parseRelDir name
dirRelTmp <- parseRelDir $ name ++ ".tmp"
let file = root fileRel
dir = root dirRel
dirTmp = root dirRelTmp
exists <- dirExists dir
unless exists $ do
removeTreeIfExists dirTmp
let cloneAndExtract commandName resetCommand commit = do
createTree (parent dirTmp)
readInNull (parent dirTmp) commandName menv
[ "clone"
, T.unpack url
, toFilePathNoTrailingSep dirTmp
]
Nothing
readInNull dirTmp commandName menv
(resetCommand ++ [T.unpack commit])
Nothing
case remotePackageType of
RPTHttpTarball -> do
req <- parseUrl $ T.unpack url
_ <- download req file
liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do
lbs <- L.hGetContents h
let entries = Tar.read $ GZip.decompress lbs
Tar.unpack (toFilePath dirTmp) entries
RPTGit commit -> cloneAndExtract "git" ["reset", "--hard"] commit
RPTHg commit -> cloneAndExtract "hg" ["update", "-C"] commit
renameDir dirTmp dir
case remotePackageType of
RPTHttpTarball -> do
x <- listDirectory dir
case x of
([dir'], []) -> return dir'
(dirs, files) -> do
removeFileIfExists file
removeTreeIfExists dir
throwM $ UnexpectedTarballContents dirs files
_ -> return dir
-- | Get the stack root, e.g. ~/.stack
determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)
determineStackRoot = do
env <- liftIO getEnvironment
case lookup stackRootEnvVar env of
Nothing -> do
x <- liftIO $ getAppUserDataDirectory stackProgName
parseAbsDir x
Just x -> do
y <- liftIO $ do
createDirectoryIfMissing True x
canonicalizePath x
parseAbsDir y
-- | Determine the extra config file locations which exist.
--
-- Returns most local first
getExtraConfigs :: (MonadIO m, MonadLogger m)
=> Path Abs File -- ^ use config path
-> m [Path Abs File]
getExtraConfigs userConfigPath = do
defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath
liftIO $ do
env <- getEnvironment
mstackConfig <-
maybe (return Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_CONFIG" env
mstackGlobalConfig <-
maybe (return Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_GLOBAL_CONFIG" env
filterM fileExists
$ fromMaybe userConfigPath mstackConfig
: maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath)
-- | Load and parse YAML from the given file.
loadYaml :: (FromJSON (a, [JSONWarning]), MonadIO m, MonadLogger m) => Path Abs File -> m a
loadYaml path = do
(result,warnings) <-
liftIO $
Yaml.decodeFileEither (toFilePath path) >>=
either (throwM . ParseConfigFileException path) return
logJSONWarnings (toFilePath path) warnings
return result
-- | Get the location of the project config file, if it exists.
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Maybe (Path Abs File)
-- ^ Override stack.yaml
-> m (Maybe (Path Abs File))
getProjectConfig (Just stackYaml) = return $ Just stackYaml
getProjectConfig Nothing = do
env <- liftIO getEnvironment
case lookup "STACK_YAML" env of
Just fp -> do
$logInfo "Getting project config file from STACK_YAML environment"
liftM Just $ case parseAbsFile fp of
Left _ -> do
currDir <- getWorkingDir
resolveFile currDir fp
Right path -> return path
Nothing -> do
currDir <- getWorkingDir
search currDir
where
search dir = do
let fp = dir stackDotYaml
fp' = toFilePath fp
$logDebug $ "Checking for project config at: " <> T.pack fp'
exists <- fileExists fp
if exists
then return $ Just fp
else do
let dir' = parent dir
if dir == dir'
-- fully traversed, give up
then return Nothing
else search dir'
-- | Find the project config file location, respecting environment variables
-- and otherwise traversing parents. If no config is found, we supply a default
-- based on current directory.
loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Maybe (Path Abs File)
-- ^ Override stack.yaml
-> m (Maybe (Project, Path Abs File, ConfigMonoid))
loadProjectConfig mstackYaml = do
mfp <- getProjectConfig mstackYaml
case mfp of
Just fp -> do
currDir <- getWorkingDir
$logDebug $ "Loading project config file " <>
T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp))
load fp
Nothing -> do
$logDebug $ "No project config file found, using defaults."
return Nothing
where
load fp = do
ProjectAndConfigMonoid project config <- loadYaml fp
return $ Just (project, fp, config)
-- | Get the location of the default stack configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getDefaultGlobalConfigPath
:: (MonadIO m, MonadLogger m)
=> m (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of
(Just new,Just old) ->
liftM (Just . fst ) $
tryDeprecatedPath
(Just "non-project global configuration file")
fileExists
new
old
(Just new,Nothing) -> return (Just new)
_ -> return Nothing
-- | Get the location of the default user configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getDefaultUserConfigPath
:: (MonadIO m, MonadLogger m)
=> Path Abs Dir -> m (Path Abs File)
getDefaultUserConfigPath stackRoot = do
(path, exists) <- tryDeprecatedPath
(Just "non-project configuration file")
fileExists
(defaultUserConfigPath stackRoot)
(defaultUserConfigPathDeprecated stackRoot)
unless exists $ do
createTree (parent path)
liftIO $ S.writeFile (toFilePath path) $ S.concat
[ "# This file contains default non-project-specific settings for 'stack', used\n"
, "# in all projects. For more information about stack's configuration, see\n"
, "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n"
, "#\n"
, Yaml.encode (mempty :: Object) ]
return path
packagesParser :: Parser [String]
packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
stack-0.1.10.0/src/Stack/Config/Docker.hs 0000644 0000000 0000000 00000011103 12630352213 016017 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-}
-- | Docker configuration
module Stack.Config.Docker where
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Catch (throwM, MonadThrow)
import Data.List (find)
import Data.Maybe
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Distribution.Version (simplifyVersionRange)
import Path
import Stack.Types
-- | Interprets DockerOptsMonoid options.
dockerOptsFromMonoid
:: MonadThrow m
=> Maybe Project
-> Path Abs Dir
-> Maybe AbstractResolver
-> DockerOptsMonoid
-> m DockerOpts
dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do
let dockerEnable =
fromMaybe dockerMonoidDefaultEnable dockerMonoidEnable
dockerImage =
let mresolver =
case maresolver of
Just (ARResolver resolver) ->
Just resolver
Just aresolver ->
throw
(ResolverNotSupportedException $
show aresolver)
Nothing ->
fmap projectResolver mproject
defaultTag =
case mresolver of
Nothing -> ""
Just resolver ->
case resolver of
ResolverSnapshot n@(LTS _ _) ->
":" ++ T.unpack (renderSnapName n)
_ ->
throw
(ResolverNotSupportedException $
show resolver)
in case dockerMonoidRepoOrImage of
Nothing -> "fpco/stack-build" ++ defaultTag
Just (DockerMonoidImage image) -> image
Just (DockerMonoidRepo repo) ->
case find (`elem` (":@" :: String)) repo of
Just _ -- Repo already specified a tag or digest, so don't append default
->
repo
Nothing -> repo ++ defaultTag
dockerRegistryLogin =
fromMaybe
(isJust (emptyToNothing dockerMonoidRegistryUsername))
dockerMonoidRegistryLogin
dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername
dockerRegistryPassword = emptyToNothing dockerMonoidRegistryPassword
dockerAutoPull = fromMaybe False dockerMonoidAutoPull
dockerDetach = fromMaybe False dockerMonoidDetach
dockerPersist = fromMaybe False dockerMonoidPersist
dockerContainerName = emptyToNothing dockerMonoidContainerName
dockerRunArgs = dockerMonoidRunArgs
dockerMount = dockerMonoidMount
dockerEnv = dockerMonoidEnv
dockerSetUser = dockerMonoidSetUser
dockerRequireDockerVersion = simplifyVersionRange dockerMonoidRequireDockerVersion
dockerDatabasePath <-
case dockerMonoidDatabasePath of
Nothing -> return $ stackRoot $(mkRelFile "docker.db")
Just fp ->
case parseAbsFile fp of
Left e -> throwM (InvalidDatabasePathException e)
Right p -> return p
dockerStackExe <-
case dockerMonoidStackExe of
Just e -> liftM Just (parseDockerStackExe e)
Nothing -> return Nothing
return DockerOpts{..}
where emptyToNothing Nothing = Nothing
emptyToNothing (Just s) | null s = Nothing
| otherwise = Just s
-- | Exceptions thrown by Stack.Docker.Config.
data StackDockerConfigException
= ResolverNotSupportedException String
-- ^ Only LTS resolvers are supported for default image tag.
| InvalidDatabasePathException SomeException
-- ^ Invalid global database path.
deriving (Typeable)
-- | Exception instance for StackDockerConfigException.
instance Exception StackDockerConfigException
-- | Show instance for StackDockerConfigException.
instance Show StackDockerConfigException where
show (ResolverNotSupportedException resolver) =
concat
[ "Resolver not supported for Docker images:\n "
, resolver
, "\nUse an LTS resolver, or set the '"
, T.unpack dockerImageArgName
, "' explicitly, in your configuration file."]
show (InvalidDatabasePathException ex) =
concat ["Invalid database path: ", show ex]
stack-0.1.10.0/src/Stack/Config/Nix.hs 0000644 0000000 0000000 00000003134 12630352213 015353 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}
-- | Nix configuration
module Stack.Config.Nix
(nixOptsFromMonoid
,StackNixException(..)
) where
import Data.Text (pack)
import Data.Maybe
import Data.Typeable
import Path
import Stack.Types
import Control.Exception.Lifted
import Control.Monad.Catch (throwM,MonadCatch)
-- | Interprets NixOptsMonoid options.
nixOptsFromMonoid :: (Monad m, MonadCatch m) => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts
nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do
let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable
nixPackages = case mproject of
Nothing -> nixMonoidPackages
Just p -> nixMonoidPackages ++ [case projectResolver p of
ResolverSnapshot (LTS x y) ->
pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")
_ -> pack "ghc"]
nixInitFile = nixMonoidInitFile
nixShellOptions = nixMonoidShellOptions
if not (null nixMonoidPackages) && isJust nixInitFile then
throwM NixCannotUseShellFileAndPackagesException
else return ()
return NixOpts{..}
-- Exceptions thown specifically by Stack.Nix
data StackNixException
= NixCannotUseShellFileAndPackagesException
-- ^ Nix can't be given packages and a shell file at the same time
deriving (Typeable)
instance Exception StackNixException
instance Show StackNixException where
show NixCannotUseShellFileAndPackagesException =
"You cannot have packages and a shell-file filled at the same time in your nix-shell configuration."
stack-0.1.10.0/src/Stack/ConfigCmd.hs 0000644 0000000 0000000 00000004164 12623647202 015254 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Make changes to the stack yaml file
module Stack.ConfigCmd
(ConfigCmdSet(..)
,cfgCmdSet
,cfgCmdSetName
,cfgCmdName) where
import Control.Monad.Catch (MonadMask, throwM, MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString as S
import qualified Data.HashMap.Strict as HMap
import qualified Data.Yaml as Yaml
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Stack.BuildPlan
import Stack.Init
import Stack.Types
data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver
cfgCmdSet :: ( MonadIO m
, MonadBaseControl IO m
, MonadMask m
, MonadReader env m
, HasConfig env
, HasBuildConfig env
, HasHttpManager env
, HasGHCVariant env
, MonadThrow m
, MonadLogger m)
=> ConfigCmdSet -> m ()
cfgCmdSet (ConfigCmdSetResolver newResolver) = do
stackYaml <- fmap bcStackYaml (asks getBuildConfig)
let stackYamlFp =
toFilePath stackYaml
-- We don't need to worry about checking for a valid yaml here
(projectYamlConfig :: Yaml.Object) <-
liftIO (Yaml.decodeFileEither stackYamlFp) >>=
either throwM return
newResolverText <- fmap resolverName (makeConcreteResolver newResolver)
-- We checking here that the snapshot actually exists
snap <- parseSnapName newResolverText
_ <- loadMiniBuildPlan snap
let projectYamlConfig' =
HMap.insert
"resolver"
(Yaml.String newResolverText)
projectYamlConfig
liftIO
(S.writeFile
stackYamlFp
(Yaml.encode projectYamlConfig'))
return ()
cfgCmdName :: String
cfgCmdName = "config"
cfgCmdSetName :: String
cfgCmdSetName = "set"
stack-0.1.10.0/src/Stack/Constants.hs 0000644 0000000 0000000 00000031542 12630352213 015370 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Constants used throughout the project.
module Stack.Constants
(builtConfigFileFromDir
,builtFileFromDir
,buildPlanDir
,configuredFileFromDir
,defaultShakeThreads
,distDirFromDir
,distRelativeDir
,haskellModuleExts
,imageStagingDir
,projectDockerSandboxDir
,rawGithubUrl
,stackDotYaml
,stackRootEnvVar
,userDocsDir
,configCacheFile
,configCabalMod
,buildCacheFile
,testSuccessFile
,testBuiltFile
,benchBuiltFile
,stackProgName
,stackProgNameUpper
,wiredInPackages
,ghcjsBootPackages
,cabalPackageName
,implicitGlobalProjectDirDeprecated
,implicitGlobalProjectDir
,hpcRelativeDir
,hpcDirFromDir
,objectInterfaceDir
,templatesDir
,defaultUserConfigPathDeprecated
,defaultUserConfigPath
,defaultGlobalConfigPathDeprecated
,defaultGlobalConfigPath
,platformVariantEnvVar
)
where
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Reader
import Data.Char (toUpper)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Text (Text)
import qualified Data.Text as T
import Path as FL
import Prelude
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
-- | Extensions for anything that can be a Haskell module.
haskellModuleExts :: [Text]
haskellModuleExts = haskellFileExts ++ haskellPreprocessorExts
-- | Extensions used for Haskell modules. Excludes preprocessor ones.
haskellFileExts :: [Text]
haskellFileExts = ["hs", "hsc", "lhs"]
-- | Extensions for modules that are preprocessed by common preprocessors.
haskellPreprocessorExts :: [Text]
haskellPreprocessorExts = ["gc", "chs", "hsc", "x", "y", "ly", "cpphs"]
-- | The filename used for completed build indicators.
builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir
-> m (Path Abs File)
builtFileFromDir fp = do
dist <- distDirFromDir fp
return (dist $(mkRelFile "stack.gen"))
-- | The filename used for completed configure indicators.
configuredFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir
-> m (Path Abs File)
configuredFileFromDir fp = do
dist <- distDirFromDir fp
return (dist $(mkRelFile "setup-config"))
-- | The filename used for completed build indicators.
builtConfigFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir
-> m (Path Abs File)
builtConfigFileFromDir fp =
liftM (fp ) builtConfigRelativeFile
-- | Relative location of completed build indicators.
builtConfigRelativeFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> m (Path Rel File)
builtConfigRelativeFile = do
dist <- distRelativeDir
return (dist $(mkRelFile "stack.config"))
-- | Default shake thread count for parallel builds.
defaultShakeThreads :: Int
defaultShakeThreads = 4
-- -- | Hoogle database file.
-- hoogleDatabaseFile :: Path Abs Dir -> Path Abs File
-- hoogleDatabaseFile docLoc =
-- docLoc
-- $(mkRelFile "default.hoo")
-- -- | Extension for hoogle databases.
-- hoogleDbExtension :: String
-- hoogleDbExtension = "hoo"
-- -- | Extension of haddock files
-- haddockExtension :: String
-- haddockExtension = "haddock"
-- | User documentation directory.
userDocsDir :: Config -> Path Abs Dir
userDocsDir config = configStackRoot config $(mkRelDir "doc/")
-- | Output .o/.hi directory.
objectInterfaceDir :: (MonadReader env m, HasConfig env)
=> BuildConfig -> m (Path Abs Dir)
objectInterfaceDir bconfig = do
bcwd <- bcWorkDir bconfig
return (bcwd $(mkRelDir "odir/"))
-- | The filename used for dirtiness check of source files.
buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
-> m (Path Abs File)
buildCacheFile dir =
liftM
( $(mkRelFile "stack-build-cache"))
(distDirFromDir dir)
-- | The filename used to mark tests as having succeeded
testSuccessFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory
-> m (Path Abs File)
testSuccessFile dir =
liftM
( $(mkRelFile "stack-test-success"))
(distDirFromDir dir)
-- | The filename used to mark tests as having built
testBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory
-> m (Path Abs File)
testBuiltFile dir =
liftM
( $(mkRelFile "stack-test-built"))
(distDirFromDir dir)
-- | The filename used to mark benchmarks as having built
benchBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory
-> m (Path Abs File)
benchBuiltFile dir =
liftM
( $(mkRelFile "stack-bench-built"))
(distDirFromDir dir)
-- | The filename used for dirtiness check of config.
configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
-> m (Path Abs File)
configCacheFile dir =
liftM
( $(mkRelFile "stack-config-cache"))
(distDirFromDir dir)
-- | The filename used for modification check of .cabal
configCabalMod :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
-> m (Path Abs File)
configCabalMod dir =
liftM
( $(mkRelFile "stack-cabal-mod"))
(distDirFromDir dir)
-- | Directory for HPC work.
hpcDirFromDir
:: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
-> m (Path Abs Dir)
hpcDirFromDir fp =
liftM (fp ) hpcRelativeDir
-- | Relative location of directory for HPC work.
hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> m (Path Rel Dir)
hpcRelativeDir =
liftM ( $(mkRelDir "hpc")) distRelativeDir
-- | Package's build artifacts directory.
distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> Path Abs Dir
-> m (Path Abs Dir)
distDirFromDir fp =
liftM (fp ) distRelativeDir
-- | Directory for project templates.
templatesDir :: Config -> Path Abs Dir
templatesDir config = configStackRoot config $(mkRelDir "templates")
-- | Relative location of build artifacts.
distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> m (Path Rel Dir)
distRelativeDir = do
cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
platform <- platformVariantRelDir
wc <- getWhichCompiler
-- Cabal version, suffixed with "_ghcjs" if we're using GHCJS.
envDir <-
parseRelDir $
(if wc == Ghcjs then (++ "_ghcjs") else id) $
packageIdentifierString $
PackageIdentifier cabalPackageName cabalPkgVer
platformAndCabal <- useShaPathOnWindows (platform envDir)
workDir <- getWorkDir
return $
workDir
$(mkRelDir "dist")
platformAndCabal
-- | Get a URL for a raw file on Github
rawGithubUrl :: Text -- ^ user/org name
-> Text -- ^ repo name
-> Text -- ^ branch name
-> Text -- ^ filename
-> Text
rawGithubUrl org repo branch file = T.concat
[ "https://raw.githubusercontent.com/"
, org
, "/"
, repo
, "/"
, branch
, "/"
, file
]
-- -- | Hoogle database file.
-- hoogleDatabaseFile :: Path Abs Dir -> Path Abs File
-- hoogleDatabaseFile docLoc =
-- docLoc
-- $(mkRelFile "default.hoo")
-- -- | Extension for hoogle databases.
-- hoogleDbExtension :: String
-- hoogleDbExtension = "hoo"
-- -- | Extension of haddock files
-- haddockExtension :: String
-- haddockExtension = "haddock"
-- | Docker sandbox from project root.
projectDockerSandboxDir :: (MonadReader env m, HasConfig env)
=> Path Abs Dir -- ^ Project root
-> m (Path Abs Dir) -- ^ Docker sandbox
projectDockerSandboxDir projectRoot = do
workDir <- getWorkDir
return $ projectRoot workDir $(mkRelDir "docker/")
-- | Image staging dir from project root.
imageStagingDir :: (MonadReader env m, HasConfig env)
=> Path Abs Dir -- ^ Project root
-> m (Path Abs Dir) -- ^ Docker sandbox
imageStagingDir projectRoot = do
workDir <- getWorkDir
return $ projectRoot workDir $(mkRelDir "image/")
-- | Name of the 'stack' program, uppercased
stackProgNameUpper :: String
stackProgNameUpper = map toUpper stackProgName
-- | Name of the 'stack' program.
stackProgName :: String
stackProgName = "stack"
-- | The filename used for the stack config file.
stackDotYaml :: Path Rel File
stackDotYaml = $(mkRelFile "stack.yaml")
-- | Environment variable used to override the '~/.stack' location.
stackRootEnvVar :: String
stackRootEnvVar = "STACK_ROOT"
-- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey
wiredInPackages :: HashSet PackageName
wiredInPackages =
maybe (error "Parse error in wiredInPackages") HashSet.fromList mparsed
where
mparsed = mapM parsePackageName
[ "ghc-prim"
, "integer-gmp"
, "integer-simple"
, "base"
, "rts"
, "template-haskell"
, "dph-seq"
, "dph-par"
, "ghc"
, "interactive"
]
-- TODO: Get this unwieldy list out of here and into a datafile
-- generated by GHCJS! See https://github.com/ghcjs/ghcjs/issues/434
ghcjsBootPackages :: HashSet PackageName
ghcjsBootPackages =
maybe (error "Parse error in ghcjsBootPackages") HashSet.fromList mparsed
where
mparsed = mapM parsePackageName
-- stage1a
[ "array"
, "base"
, "binary"
, "bytestring"
, "containers"
, "deepseq"
, "integer-gmp"
, "pretty"
, "primitive"
, "integer-gmp"
, "pretty"
, "primitive"
, "template-haskell"
, "transformers"
-- stage1b
, "directory"
, "filepath"
, "old-locale"
, "process"
, "time"
-- stage2
, "async"
, "aeson"
, "attoparsec"
, "case-insensitive"
, "dlist"
, "extensible-exceptions"
, "hashable"
, "mtl"
, "old-time"
, "parallel"
, "scientific"
, "stm"
, "syb"
, "text"
, "unordered-containers"
, "vector"
]
-- | Just to avoid repetition and magic strings.
cabalPackageName :: PackageName
cabalPackageName =
$(mkPackageName "Cabal")
-- | Deprecated implicit global project directory used when outside of a project.
implicitGlobalProjectDirDeprecated :: Path Abs Dir -- ^ Stack root.
-> Path Abs Dir
implicitGlobalProjectDirDeprecated p =
p
$(mkRelDir "global")
-- | Implicit global project directory used when outside of a project.
-- Normally, @getImplicitGlobalProjectDir@ should be used instead.
implicitGlobalProjectDir :: Path Abs Dir -- ^ Stack root.
-> Path Abs Dir
implicitGlobalProjectDir p =
p
$(mkRelDir "global-project")
-- | Deprecated default global config path.
defaultUserConfigPathDeprecated :: Path Abs Dir -> Path Abs File
defaultUserConfigPathDeprecated = ( $(mkRelFile "stack.yaml"))
-- | Default global config path.
-- Normally, @getDefaultUserConfigPath@ should be used instead.
defaultUserConfigPath :: Path Abs Dir -> Path Abs File
defaultUserConfigPath = ( $(mkRelFile "config.yaml"))
-- | Deprecated default global config path.
-- Note that this will be @Nothing@ on Windows, which is by design.
defaultGlobalConfigPathDeprecated :: Maybe (Path Abs File)
defaultGlobalConfigPathDeprecated = parseAbsFile "/etc/stack/config"
-- | Default global config path.
-- Normally, @getDefaultGlobalConfigPath@ should be used instead.
-- Note that this will be @Nothing@ on Windows, which is by design.
defaultGlobalConfigPath :: Maybe (Path Abs File)
defaultGlobalConfigPath = parseAbsFile "/etc/stack/config.yaml"
-- | Path where build plans are stored.
buildPlanDir :: Path Abs Dir -- ^ Stack root
-> Path Abs Dir
buildPlanDir = ( $(mkRelDir "build-plan"))
-- | Environment variable that stores a variant to append to platform-specific directory
-- names. Used to ensure incompatible binaries aren't shared between Docker builds and host
platformVariantEnvVar :: String
platformVariantEnvVar = stackProgNameUpper ++ "_PLATFORM_VARIANT"
stack-0.1.10.0/src/Stack/Coverage.hs 0000644 0000000 0000000 00000050317 12630352213 015150 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Generate HPC (Haskell Program Coverage) reports
module Stack.Coverage
( deleteHpcReports
, updateTixFile
, testExeName
, generateHpcReport
, HpcReportOpts(..)
, generateHpcReportForTargets
, generateHpcUnifiedReport
, generateHpcMarkupIndex
) where
import Control.Applicative
import Control.Exception.Lifted
import Control.Monad (liftM, when, unless, void)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import qualified Data.ByteString.Char8 as S8
import Data.Foldable (forM_, asum, toList)
import Data.Function
import Data.List
import Data.List.Extra (stripSuffix)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (mapMaybeM)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import Data.Traversable (forM)
import Distribution.System (OS (Windows), Platform (Platform))
import Network.HTTP.Download (HasHttpManager)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Source (parseTargetsFromBuildOpts)
import Stack.Build.Target
import Stack.Constants
import Stack.Package
import Stack.Types
import qualified System.Directory as D
import System.FilePath (isPathSeparator)
import System.Process.Read
import Text.Hastache (htmlEscape)
import Trace.Hpc.Tix
-- | Invoked at the beginning of running with "--coverage"
deleteHpcReports :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m ()
deleteHpcReports = do
hpcDir <- hpcReportDir
removeTreeIfExists hpcDir
-- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is
-- present.
updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> PackageName -> Path Abs File -> m ()
updateTixFile pkgName tixSrc = do
case stripSuffix ".tix" (toFilePath (filename tixSrc)) of
Nothing -> error "Invariant violated: updateTixFile expected a tix filepath."
Just testName -> do
exists <- fileExists tixSrc
when exists $ do
tixDest <- tixFilePath pkgName testName
removeFileIfExists tixDest
createTree (parent tixDest)
-- Remove exe modules because they are problematic. This could be revisited if there's a GHC
-- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853
mtix <- readTixOrLog tixSrc
case mtix of
Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc)
Just tix -> do
liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)
removeFileIfExists tixSrc
testExeName :: (MonadReader env m,HasConfig env) => String -> m String
testExeName testName = do
config <- asks getConfig
let exeExtension =
case configPlatform config of
Platform _ Windows -> ".exe"
_ -> ""
return $ testName ++ exeExtension
-- | Get the directory used for hpc reports for the given pkgId.
hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> PackageName -> m (Path Abs Dir)
hpcPkgPath pkgName = do
outputDir <- hpcReportDir
pkgNameRel <- parseRelDir (packageNameString pkgName)
return (outputDir pkgNameRel)
-- | Get the tix file location, given the name of the file (without extension), and the package
-- identifier string.
tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> PackageName -> String -> m (Path Abs File)
tixFilePath pkgName testName = do
pkgPath <- hpcPkgPath pkgName
exeName <- testExeName testName
tixRel <- parseRelFile (testName ++ "/" ++ exeName ++ ".tix")
return (pkgPath tixRel)
-- | Generates the HTML coverage report and shows a textual coverage summary for a package.
generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> Path Abs Dir -> Package -> [Text] -> m ()
generateHpcReport pkgDir package tests = do
-- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See
-- https://github.com/commercialhaskell/stack/issues/785
let pkgName = packageNameText (packageName package)
pkgId = packageIdentifierString (packageIdentifier package)
compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
eincludeName <-
-- Pre-7.8 uses plain PKG-version in tix files.
if getGhcVersion compilerVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId
-- We don't expect to find a package key if there is no library.
else if not (packageHasLibrary package) then return $ Right Nothing
-- Look in the inplace DB for the package key.
-- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986
else do
mghcPkgKey <- findPackageKeyForBuiltPackage pkgDir (packageIdentifier package)
case mghcPkgKey of
Nothing -> do
let msg = "Failed to find GHC package key for " <> pkgName
$logError msg
return $ Left msg
Just ghcPkgKey -> return $ Right $ Just $ T.unpack ghcPkgKey
forM_ tests $ \testName -> do
tixSrc <- tixFilePath (packageName package) (T.unpack testName)
let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\""
reportDir = parent tixSrc
case eincludeName of
Left err -> generateHpcErrorReport reportDir (sanitize (T.unpack err))
-- Restrict to just the current library code, if there is a library in the package (see
-- #634 - this will likely be customizable in the future)
Right mincludeName -> do
let extraArgs = case mincludeName of
Just includeName -> ["--include", includeName ++ ":"]
Nothing -> []
generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m ()
generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do
-- If a .tix file exists, move it to the HPC output directory and generate a report for it.
tixFileExists <- fileExists tixSrc
if not tixFileExists
then $logError $ T.concat
[ "Didn't find .tix for "
, report
, " - expected to find it at "
, T.pack (toFilePath tixSrc)
, "."
]
else (`catch` \err -> do
let msg = show (err :: ReadProcessException)
$logError (T.pack msg)
generateHpcErrorReport reportDir $ sanitize msg) $
(`onException` $logError ("Error occurred while producing " <> report)) $ do
-- Directories for .mix files.
hpcRelDir <- hpcRelativeDir
-- Compute arguments used for both "hpc markup" and "hpc report".
pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig
let args =
-- Use index files from all packages (allows cross-package coverage results).
concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++
-- Look for index files in the correct dir (relative to each pkgdir).
["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
menv <- getMinimalEnvOverride
$logInfo $ "Generating " <> report
outputLines <- liftM S8.lines $ readProcessStdout Nothing menv "hpc"
( "report"
: toFilePath tixSrc
: (args ++ extraReportArgs)
)
if all ("(0/0)" `S8.isSuffixOf`) outputLines
then do
let msg html = T.concat
[ "Error: The "
, report
, " did not consider any code. One possible cause of this is"
, " if your test-suite builds the library code (see stack "
, if html then "" else ""
, "issue #1008"
, if html then "" else ""
, "). It may also indicate a bug in stack or"
, " the hpc program. Please report this issue if you think"
, " your coverage report should have meaningful results."
]
$logError (msg False)
generateHpcErrorReport reportDir (msg True)
else do
-- Print output, stripping @\r@ characters because Windows.
forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))
$logInfo
("The " <> report <> " is available at " <>
T.pack (toFilePath (reportDir $(mkRelFile "hpc_index.html"))))
-- Generate the markup.
void $ readProcessStdout Nothing menv "hpc"
( "markup"
: toFilePath tixSrc
: ("--destdir=" ++ toFilePathNoTrailingSep reportDir)
: (args ++ extraMarkupArgs)
)
data HpcReportOpts = HpcReportOpts
{ hroptsInputs :: [Text]
, hroptsAll :: Bool
, hroptsDestDir :: Maybe String
} deriving (Show)
generateHpcReportForTargets :: (MonadIO m, HasHttpManager env, MonadReader env m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasEnvConfig env)
=> HpcReportOpts -> m ()
generateHpcReportForTargets opts = do
let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)
targetTixFiles <-
-- When there aren't any package component arguments, then
-- don't default to all package components.
if not (hroptsAll opts) && null targetNames
then return []
else do
when (hroptsAll opts && not (null targetNames)) $
$logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames)
(_,_,targets) <- parseTargetsFromBuildOpts
AllowNoTargets
defaultBuildOpts
{ boptsTargets = if hroptsAll opts then [] else targetNames
}
liftM concat $ forM (Map.toList targets) $ \(name, target) ->
case target of
STUnknown -> fail $
packageNameString name ++ " isn't a known local page"
STNonLocal -> fail $
"Expected a local package, but " ++
packageNameString name ++
" is either an extra-dep or in the snapshot."
STLocalComps comps -> do
pkgPath <- hpcPkgPath name
forM (toList comps) $ \nc ->
case nc of
CTest testName ->
liftM (pkgPath ) $ parseRelFile (T.unpack testName ++ ".tix")
_ -> fail $
"Can't specify anything except test-suites as hpc report targets (" ++
packageNameString name ++
" is used with a non test-suite target)"
STLocalAll -> do
pkgPath <- hpcPkgPath name
exists <- dirExists pkgPath
if exists
then do
(_, files) <- listDirectory pkgPath
return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
else return []
tixPaths <- liftM (++ targetTixFiles) $ mapM (parseRelAsAbsFile . T.unpack) tixFiles
when (null tixPaths) $
fail "Not generating combined report, because no targets or tix files are specified."
reportDir <- case hroptsDestDir opts of
Nothing -> liftM ( $(mkRelDir "combined/custom")) hpcReportDir
Just destDir -> do
liftIO $ D.createDirectoryIfMissing True destDir
parseRelAsAbsDir destDir
generateUnionReport "combined report" reportDir tixPaths
generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> m ()
generateHpcUnifiedReport = do
outputDir <- hpcReportDir
createTree outputDir
(dirs, _) <- listDirectory outputDir
tixFiles <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do
(dirs', _) <- listDirectory dir
forM dirs' $ \dir' -> do
(_, files) <- listDirectory dir'
return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
let reportDir = outputDir $(mkRelDir "combined/all")
if length tixFiles < 2
then $logInfo $ T.concat
[ if null tixFiles then "No tix files" else "Only one tix file"
, " found in "
, T.pack (toFilePath outputDir)
, ", so not generating a unified coverage report."
]
else generateUnionReport "unified report" reportDir tixFiles
generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
=> Text -> Path Abs Dir -> [Path Abs File] -> m ()
generateUnionReport report reportDir tixFiles = do
(errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles)
$logDebug $ "Using the following tix files: " <> T.pack (show tixFiles)
unless (null errs) $ $logWarn $ T.concat $
"The following modules are left out of the " : report : " due to version mismatches: " :
intersperse ", " (map T.pack errs)
tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix")
createTree (parent tixDest)
liftIO $ writeTix (toFilePath tixDest) tix
generateHpcReportInternal tixDest reportDir report [] []
readTixOrLog :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Path b File -> m (Maybe Tix)
readTixOrLog path = do
mtix <- liftIO (readTix (toFilePath path)) `catch` \(ErrorCall err) -> do
$logError $ "Error while reading tix: " <> T.pack err
return Nothing
when (isNothing mtix) $
$logError $ "Failed to read tix file " <> T.pack (toFilePath path)
return mtix
-- | Module names which contain '/' have a package name, and so they weren't built into the
-- executable.
removeExeModules :: Tix -> Tix
removeExeModules (Tix ms) = Tix (filter (\(TixModule name _ _ _) -> '/' `elem` name) ms)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs))
where
(errs, outputs) = Map.mapEither id $ Map.unionsWith merge $ map toMap tixes
toMap (Tix ms) = Map.fromList (map (\x@(TixModule k _ _ _) -> (k, Right x)) ms)
merge (Right (TixModule k hash1 len1 tix1))
(Right (TixModule _ hash2 len2 tix2))
| hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2))
merge _ _ = Left ()
generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)
=> m ()
generateHpcMarkupIndex = do
outputDir <- hpcReportDir
let outputFile = outputDir $(mkRelFile "index.html")
createTree outputDir
(dirs, _) <- listDirectory outputDir
rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do
(subdirs, _) <- listDirectory dir
forM subdirs $ \subdir -> do
let indexPath = subdir $(mkRelFile "hpc_index.html")
exists' <- fileExists indexPath
if not exists' then return Nothing else do
relPath <- stripDir outputDir indexPath
let package = dirname dir
testsuite = dirname subdir
return $ Just $ T.concat
[ "| "
, pathToHtml package
, " | "
, pathToHtml testsuite
, " |
"
]
liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $
[ ""
-- Part of the css from HPC's output HTML
, ""
, ""
, ""
] ++
(if null rows
then
[ "No hpc_index.html files found in \""
, pathToHtml outputDir
, "\"."
]
else
[ ""
, "NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.
"
, "| Package | TestSuite | Modification Time |
|---|
"
] ++
rows ++
["
"]) ++
[""]
unless (null rows) $
$logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>
T.pack (toFilePath outputFile)
generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m ()
generateHpcErrorReport dir err = do
createTree dir
liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat
[ ""
, "HPC Report Generation Error
"
, ""
, err
, "
"
, ""
]
pathToHtml :: Path b t -> Text
pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath
sanitize :: String -> Text
sanitize = LT.toStrict . htmlEscape . LT.pack
dirnameString :: Path r Dir -> String
dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname
findPackageKeyForBuiltPackage :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)
=> Path Abs Dir -> PackageIdentifier -> m (Maybe Text)
findPackageKeyForBuiltPackage pkgDir pkgId = do
distDir <- distDirFromDir pkgDir
path <- liftM (distDir ) $
parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf")
exists <- fileExists path
if exists
then do
contents <- liftIO $ T.readFile (toFilePath path)
return $ asum (map (T.stripPrefix "key: ") (T.lines contents))
else return Nothing
stack-0.1.10.0/src/Stack/Docker.hs 0000644 0000000 0000000 00000133776 12630352213 014637 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables,
TemplateHaskell, TupleSections #-}
-- | Run commands in Docker containers
module Stack.Docker
(cleanup
,CleanupOpts(..)
,CleanupAction(..)
,dockerCleanupCmdName
,dockerCmdName
,dockerPullCmdName
,entrypoint
,preventInContainer
,pull
,reexecWithOptionalContainer
,reset
,reExecArgName
,StackDockerException(..)
) where
import Control.Applicative
import Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar)
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Catch (MonadThrow,throwM,MonadCatch,MonadMask)
import Control.Monad.IO.Class (MonadIO,liftIO)
import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn)
import Control.Monad.Reader (MonadReader,asks,runReaderT)
import Control.Monad.Writer (execWriter,runWriter,tell)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified "cryptohash" Crypto.Hash as Hash
import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char (isSpace,toUpper,isAscii,isDigit)
import Data.Conduit.List (sinkNull)
import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf,foldl')
import Data.List.Extra (trim,nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Ord (Down(..))
import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Distribution.System (Platform (Platform),Arch (X86_64),OS (Linux))
import Distribution.Text (display)
import GHC.Exts (sortWith)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import qualified Paths_stack as Meta
import Prelude -- Fix redundant import warnings
import Stack.Constants
import Stack.Docker.GlobalDB
import Stack.Types
import Stack.Types.Internal
import Stack.Setup (ensureDockerStackExe)
import System.Directory (canonicalizePath,getModificationTime)
import System.Environment (getEnv,getProgName,getArgs,getExecutablePath,lookupEnv)
import System.Exit (exitSuccess, exitWith)
import qualified System.FilePath as FP
import qualified System.FilePath.Posix as Posix
import System.IO (stderr,stdin,stdout,hIsTerminalDevice)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.PosixCompat.User as User
import System.Process.PagerEditor (editByteString)
import System.Process.Read
import System.Process.Run
import System.Process (CreateProcess(delegate_ctlc))
import Text.Printf (printf)
#ifndef WINDOWS
import Control.Concurrent (threadDelay)
import Control.Monad.Trans.Control (liftBaseWith)
import System.Posix.Signals
#endif
-- | If Docker is enabled, re-runs the currently running OS command in a Docker container.
-- Otherwise, runs the inner action.
--
-- This takes an optional release action which should be taken IFF control is
-- transfering away from the current process to the intra-container one. The main use
-- for this is releasing a lock. After launching reexecution, the host process becomes
-- nothing but an manager for the call into docker and thus may not hold the lock.
reexecWithOptionalContainer
:: M env m
=> Maybe (Path Abs Dir)
-> Maybe (m ())
-> IO ()
-> Maybe (m ())
-> Maybe (m ())
-> m ()
reexecWithOptionalContainer mprojectRoot =
execWithOptionalContainer mprojectRoot getCmdArgs
where
getCmdArgs docker envOverride imageInfo isRemoteDocker = do
config <- asks getConfig
deUidGid <-
if fromMaybe (not isRemoteDocker) (dockerSetUser docker)
then liftIO $ Just <$>
((,) <$> User.getEffectiveUserID <*> User.getEffectiveGroupID)
else return Nothing
args <-
fmap
(["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version
,"--" ++ dockerEntrypointArgName
,show DockerEntrypoint{..}] ++)
(liftIO getArgs)
case dockerStackExe (configDocker config) of
Just DockerStackExeHost
| configPlatform config == dockerContainerPlatform -> do
exePath <- liftIO getExecutablePath
cmdArgs args exePath
| otherwise -> throwM UnsupportedStackExeHostPlatformException
Just DockerStackExeImage -> do
progName <- liftIO getProgName
return (FP.takeBaseName progName, args, [], [])
Just (DockerStackExePath path) -> do
exePath <- liftIO $ canonicalizePath (toFilePath path)
cmdArgs args exePath
Just DockerStackExeDownload -> exeDownload args
Nothing
| configPlatform config == dockerContainerPlatform -> do
(exePath,exeTimestamp,misCompatible) <-
liftIO $
do exePath <- liftIO getExecutablePath
exeTimestamp <- liftIO (getModificationTime exePath)
isKnown <-
liftIO $
getDockerImageExe
config
(iiId imageInfo)
exePath
exeTimestamp
return (exePath, exeTimestamp, isKnown)
case misCompatible of
Just True -> cmdArgs args exePath
Just False -> exeDownload args
Nothing -> do
e <-
try $
sinkProcessStderrStdout
Nothing
envOverride
"docker"
[ "run"
, "-v"
, exePath ++ ":" ++ "/tmp/stack"
, iiId imageInfo
, "/tmp/stack"
, "--version"]
sinkNull
sinkNull
let compatible =
case e of
Left (ProcessExitedUnsuccessfully _ _) ->
False
Right _ -> True
liftIO $
setDockerImageExe
config
(iiId imageInfo)
exePath
exeTimestamp
compatible
if compatible
then cmdArgs args exePath
else exeDownload args
Nothing -> exeDownload args
exeDownload args = do
exePath <- ensureDockerStackExe dockerContainerPlatform
cmdArgs args (toFilePath exePath)
cmdArgs args exePath = do
let mountPath = hostBinDir FP. FP.takeBaseName exePath
return (mountPath, args, [], [Mount exePath mountPath])
-- | If Docker is enabled, re-runs the OS command returned by the second argument in a
-- Docker container. Otherwise, runs the inner action.
--
-- This takes an optional release action just like `reexecWithOptionalContainer`.
execWithOptionalContainer
:: M env m
=> Maybe (Path Abs Dir)
-> GetCmdArgs env m
-> Maybe (m ())
-> IO ()
-> Maybe (m ())
-> Maybe (m ())
-> m ()
execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease =
do config <- asks getConfig
inContainer <- getInContainer
isReExec <- asks getReExec
if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->
throwM OnlyOnHostException
| inContainer ->
liftIO (do inner
exitSuccess)
| not (dockerEnable (configDocker config)) ->
do fromMaybeAction mbefore
liftIO inner
fromMaybeAction mafter
liftIO exitSuccess
| otherwise ->
do fromMaybeAction mrelease
runContainerAndExit
getCmdArgs
mprojectRoot
(fromMaybeAction mbefore)
(fromMaybeAction mafter)
where
fromMaybeAction Nothing = return ()
fromMaybeAction (Just hook) = hook
-- | Error if running in a container.
preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()
preventInContainer inner =
do inContainer <- getInContainer
if inContainer
then throwM OnlyOnHostException
else inner
-- | 'True' if we are currently running inside a Docker container.
getInContainer :: (MonadIO m) => m Bool
getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
-- | Run a command in a new Docker container, then exit the process.
runContainerAndExit :: M env m
=> GetCmdArgs env m
-> Maybe (Path Abs Dir) -- ^ Project root (maybe)
-> m () -- ^ Action to run before
-> m () -- ^ Action to run after
-> m ()
runContainerAndExit getCmdArgs
mprojectRoot
before
after =
do config <- asks getConfig
let docker = configDocker config
envOverride <- getEnvOverride (configPlatform config)
checkDockerVersion envOverride docker
(dockerHost,dockerCertPath,bamboo,jenkins) <-
liftIO ((,,,) <$> lookupEnv "DOCKER_HOST"
<*> lookupEnv "DOCKER_CERT_PATH"
<*> lookupEnv "bamboo_buildKey"
<*> lookupEnv "JENKINS_HOME")
let isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost
isStdoutTerminal <- asks getTerminal
(isStdinTerminal,isStderrTerminal) <-
liftIO ((,) <$> hIsTerminalDevice stdin
<*> hIsTerminalDevice stderr)
when (isRemoteDocker &&
maybe False (isInfixOf "boot2docker") dockerCertPath)
($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
let image = dockerImage docker
maybeImageInfo <- inspect envOverride image
imageInfo@Inspect{..} <- case maybeImageInfo of
Just ii -> return ii
Nothing
| dockerAutoPull docker ->
do pullImage envOverride docker image
mii2 <- inspect envOverride image
case mii2 of
Just ii2 -> return ii2
Nothing -> throwM (InspectFailedException image)
| otherwise -> throwM (NotPulledException image)
sandboxDir <- projectDockerSandboxDir projectRoot
let ImageConfig {..} = iiConfig
imageEnvVars = map (break (== '=')) icEnv
platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image
stackRoot = configStackRoot config
sandboxHomeDir = sandboxDir homeDirName
isTerm = not (dockerDetach docker) &&
isStdinTerminal &&
isStdoutTerminal &&
isStderrTerminal
keepStdinOpen = not (dockerDetach docker) &&
-- Workaround for https://github.com/docker/docker/issues/12319
-- This is fixed in Docker 1.9.1, but will leave the workaround
-- in place for now, for users who haven't upgraded yet.
(isTerm || (isNothing bamboo && isNothing jenkins))
newPathEnv = intercalate [Posix.searchPathSeparator] $
nubOrd $
[hostBinDir
,toFilePathNoTrailingSep $ sandboxHomeDir $(mkRelDir ".local/bin")] ++
maybe [] Posix.splitSearchPath (lookupImageEnv "PATH" imageEnvVars)
(cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker
pwd <- getWorkingDir
liftIO
(do updateDockerImageLastUsed config iiId (toFilePath projectRoot)
mapM_ createTree ([sandboxHomeDir, stackRoot]))
containerID <- (trim . decodeUtf8) <$> readDockerProcess
envOverride
(concat
[["create"
,"--net=host"
,"-e",inContainerEnvVar ++ "=1"
,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant
,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
,"-e","PATH=" ++ newPathEnv
,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot
,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot
,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir
,"-w",toFilePathNoTrailingSep pwd]
-- Disable the deprecated entrypoint in FP Complete-generated images
,["--entrypoint=/usr/bin/env"
| isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&
(icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||
icEntrypoint == ["/root/entrypoint.sh"])]
,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
,concatMap mountArg (extraMount ++ dockerMount docker)
,concatMap (\nv -> ["-e", nv]) (dockerEnv docker)
,case dockerContainerName docker of
Just name -> ["--name=" ++ name]
Nothing -> []
,["-t" | isTerm]
,["-i" | keepStdinOpen]
,dockerRunArgs docker
,[image]
,[cmnd]
,args])
before
#ifndef WINDOWS
runInBase <- liftBaseWith $ \run -> return (void . run)
oldHandlers <- forM ([sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2]) $ \sig -> do
let sigHandler = runInBase $ do
readProcessNull Nothing envOverride "docker"
["kill","--signal=" ++ show sig,containerID]
when (sig `elem` [sigTERM,sigABRT]) $ do
-- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it
liftIO $ threadDelay 30000000
readProcessNull Nothing envOverride "docker" ["kill",containerID]
oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
return (sig, oldHandler)
#endif
let cmd = Cmd Nothing
"docker"
envOverride
(concat [["start"]
,["-a" | not (dockerDetach docker)]
,["-i" | keepStdinOpen]
,[containerID]])
e <- finally
(try $ callProcess'
(\cp -> cp { delegate_ctlc = False })
cmd)
(do unless (dockerPersist docker || dockerDetach docker) $
catch
(readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])
(\(_::ReadProcessException) -> return ())
#ifndef WINDOWS
forM_ oldHandlers $ \(sig,oldHandler) ->
liftIO $ installHandler sig oldHandler Nothing
#endif
)
case e of
Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
Right () -> do after
liftIO exitSuccess
where
-- This is using a hash of the Docker repository (without tag or digest) to ensure
-- binaries/libraries aren't shared between Docker and host (or incompatible Docker images)
hashRepoName :: String -> Hash.Digest Hash.MD5
hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
lookupImageEnv name vars =
case lookup name vars of
Just ('=':val) -> Just val
_ -> Nothing
mountArg (Mount host container) = ["-v",host ++ ":" ++ container]
projectRoot = fromMaybeProjectRoot mprojectRoot
-- | Clean-up old docker images and containers.
cleanup :: M env m
=> CleanupOpts -> m ()
cleanup opts =
do config <- asks getConfig
let docker = configDocker config
envOverride <- getEnvOverride (configPlatform config)
checkDockerVersion envOverride docker
let runDocker = readDockerProcess envOverride
imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"]
danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"]
runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"]
restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"]
exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"]
pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"]
let imageRepos = parseImagesOut imagesOut
danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut)
runningContainers = parseContainersOut runningContainersOut ++
parseContainersOut restartingContainersOut
stoppedContainers = parseContainersOut exitedContainersOut ++
parseContainersOut pausedContainersOut
inspectMap <- inspects envOverride
(Map.keys imageRepos ++
danglingImageHashes ++
map fst stoppedContainers ++
map fst runningContainers)
(imagesLastUsed,curTime) <-
liftIO ((,) <$> getDockerImagesLastUsed config
<*> getZonedTime)
let planWriter = buildPlan curTime
imagesLastUsed
imageRepos
danglingImageHashes
stoppedContainers
runningContainers
inspectMap
plan = toLazyByteString (execWriter planWriter)
plan' <- case dcAction opts of
CleanupInteractive ->
liftIO (editByteString (intercalate "-" [stackProgName
,dockerCmdName
,dockerCleanupCmdName
,"plan"])
plan)
CleanupImmediate -> return plan
CleanupDryRun -> do liftIO (LBS.hPut stdout plan)
return LBS.empty
mapM_ (performPlanLine envOverride)
(reverse (filter filterPlanLine (lines (LBS.unpack plan'))))
allImageHashesOut <- runDocker ["images","-aq","--no-trunc"]
liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut)))
where
filterPlanLine line =
case line of
c:_ | isSpace c -> False
_ -> True
performPlanLine envOverride line =
case filter (not . null) (words (takeWhile (/= '#') line)) of
[] -> return ()
(c:_):t:v:_ ->
do args <- if | toUpper c == 'R' && t == imageStr ->
do $logInfo (concatT ["Removing image: '",v,"'"])
return ["rmi",v]
| toUpper c == 'R' && t == containerStr ->
do $logInfo (concatT ["Removing container: '",v,"'"])
return ["rm","-f",v]
| otherwise -> throwM (InvalidCleanupCommandException line)
e <- try (readDockerProcess envOverride args)
case e of
Left ex@ReadProcessException{} ->
$logError (concatT ["Could not remove: '",v,"': ", show ex])
Left e' -> throwM e'
Right _ -> return ()
_ -> throwM (InvalidCleanupCommandException line)
parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8
where parseImageRepo :: String -> (String, [String])
parseImageRepo line =
case words line of
repo:tag:hash:_
| repo == "" -> (hash,[])
| tag == "" -> (hash,[repo])
| otherwise -> (hash,[repo ++ ":" ++ tag])
_ -> throw (InvalidImagesOutputException line)
parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8
where parseContainer line =
case words line of
hash:image:rest -> (hash,(image,last rest))
_ -> throw (InvalidPSOutputException line)
buildPlan curTime
imagesLastUsed
imageRepos
danglingImageHashes
stoppedContainers
runningContainers
inspectMap =
do case dcAction opts of
CleanupInteractive ->
do buildStrLn
(concat
["# STACK DOCKER CLEANUP PLAN"
,"\n#"
,"\n# When you leave the editor, the lines in this plan will be processed."
,"\n#"
,"\n# Lines that begin with 'R' denote an image or container that will be."
,"\n# removed. You may change the first character to/from 'R' to remove/keep"
,"\n# and image or container that would otherwise be kept/removed."
,"\n#"
,"\n# To cancel the cleanup, delete all lines in this file."
,"\n#"
,"\n# By default, the following images/containers will be removed:"
,"\n#"])
buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used"
buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created"
buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created"
buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created"
buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created"
buildStrLn
(concat
["#"
,"\n# The default plan can be adjusted using command-line arguments."
,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] ++
" --help' for details."
,"\n#"])
_ -> buildStrLn
(unlines
["# Lines that begin with 'R' denote an image or container that will be."
,"# removed."])
buildSection "KNOWN IMAGES (pulled/used by stack)"
imagesLastUsed
buildKnownImage
buildSection "UNKNOWN IMAGES (not managed by stack)"
(sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m)
imageRepos
imagesLastUsed)))
buildUnknownImage
buildSection "DANGLING IMAGES (no named references and not depended on by other images)"
(sortCreated (map (,()) danglingImageHashes))
buildDanglingImage
buildSection "STOPPED CONTAINERS"
(sortCreated stoppedContainers)
(buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts))
buildSection "RUNNING CONTAINERS"
(sortCreated runningContainers)
(buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts))
where
buildDefault accessor description =
case accessor opts of
Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".")
Nothing -> return ()
sortCreated =
sortWith (\(_,_,x) -> Down x) .
(mapMaybe (\(h,r) ->
case Map.lookup h inspectMap of
Nothing -> Nothing
Just ii -> Just (h,r,iiCreated ii)))
buildSection sectionHead items itemBuilder =
do let (anyWrote,b) = runWriter (forM items itemBuilder)
when (or anyWrote) $
do buildSectionHead sectionHead
tell b
buildKnownImage (imageHash,lastUsedProjects) =
case Map.lookup imageHash imageRepos of
Just repos@(_:_) ->
do case lastUsedProjects of
(l,_):_ -> forM_ repos (buildImageTime (dcRemoveKnownImagesLastUsedDaysAgo opts) l)
_ -> forM_ repos buildKeepImage
forM_ lastUsedProjects buildProject
buildInspect imageHash
return True
_ -> return False
buildUnknownImage (hash, repos, created) =
case repos of
[] -> return False
_ -> do forM_ repos (buildImageTime (dcRemoveUnknownImagesCreatedDaysAgo opts) created)
buildInspect hash
return True
buildDanglingImage (hash, (), created) =
do buildImageTime (dcRemoveDanglingImagesCreatedDaysAgo opts) created hash
buildInspect hash
return True
buildContainer removeAge (hash,(image,name),created) =
do let disp = name ++ " (image: " ++ image ++ ")"
buildTime containerStr removeAge created disp
buildInspect hash
return True
buildProject (lastUsedTime, projectPath) =
buildInfo ("Last used " ++
showDaysAgo lastUsedTime ++
" in " ++
projectPath)
buildInspect hash =
case Map.lookup hash inspectMap of
Just (Inspect{iiCreated,iiVirtualSize}) ->
buildInfo ("Created " ++
showDaysAgo iiCreated ++
maybe ""
(\s -> " (size: " ++
printf "%g" (fromIntegral s / 1024.0 / 1024.0 :: Float) ++
"M)")
iiVirtualSize)
Nothing -> return ()
showDays days =
case days of
0 -> "today"
1 -> "yesterday"
n -> show n ++ " days ago"
showDaysAgo oldTime = showDays (daysAgo oldTime)
daysAgo oldTime =
let ZonedTime (LocalTime today _) zone = curTime
LocalTime oldDay _ = utcToLocalTime zone oldTime
in diffDays today oldDay
buildImageTime = buildTime imageStr
buildTime t removeAge time disp =
case removeAge of
Just d | daysAgo time >= d -> buildStrLn ("R " ++ t ++ " " ++ disp)
_ -> buildKeep t disp
buildKeep t d = buildStrLn (" " ++ t ++ " " ++ d)
buildKeepImage = buildKeep imageStr
buildSectionHead s = buildStrLn ("\n#\n# " ++ s ++ "\n#\n")
buildInfo = buildStrLn . (" # " ++)
buildStrLn l = do buildStr l
tell (charUtf8 '\n')
buildStr = tell . stringUtf8
imageStr = "image"
containerStr = "container"
-- | Inspect Docker image or container.
inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m,MonadCatch m)
=> EnvOverride -> String -> m (Maybe Inspect)
inspect envOverride image =
do results <- inspects envOverride [image]
case Map.toList results of
[] -> return Nothing
[(_,i)] -> return (Just i)
_ -> throwM (InvalidInspectOutputException "expect a single result")
-- | Inspect multiple Docker images and/or containers.
inspects :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride -> [String] -> m (Map String Inspect)
inspects _ [] = return Map.empty
inspects envOverride images =
do maybeInspectOut <-
try (readDockerProcess envOverride ("inspect" : images))
case maybeInspectOut of
Right inspectOut ->
-- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8
case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of
Left msg -> throwM (InvalidInspectOutputException msg)
Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))
Left e -> throwM (e :: ReadProcessException)
-- | Pull latest version of configured Docker image from registry.
pull :: M env m => m ()
pull =
do config <- asks getConfig
let docker = configDocker config
envOverride <- getEnvOverride (configPlatform config)
checkDockerVersion envOverride docker
pullImage envOverride docker (dockerImage docker)
-- | Pull Docker image from registry.
pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)
=> EnvOverride -> DockerOpts -> String -> m ()
pullImage envOverride docker image =
do $logInfo (concatT ["Pulling image from registry: '",image,"'"])
when (dockerRegistryLogin docker)
(do $logInfo "You may need to log in."
callProcess $ Cmd
Nothing
"docker"
envOverride
(concat
[["login"]
,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)
,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
,[takeWhile (/= '/') image]]))
e <- try (callProcess (Cmd Nothing "docker" envOverride ["pull",image]))
case e of
Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image)
Right () -> return ()
-- | Check docker version (throws exception if incorrect)
checkDockerVersion
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride -> DockerOpts -> m ()
checkDockerVersion envOverride docker =
do dockerExists <- doesExecutableExist envOverride "docker"
unless dockerExists (throwM DockerNotInstalledException)
dockerVersionOut <- readDockerProcess envOverride ["--version"]
case words (decodeUtf8 dockerVersionOut) of
(_:_:v:_) ->
case parseVersionFromString (dropWhileEnd (not . isDigit) v) of
Just v'
| v' < minimumDockerVersion ->
throwM (DockerTooOldException minimumDockerVersion v')
| v' `elem` prohibitedDockerVersions ->
throwM (DockerVersionProhibitedException prohibitedDockerVersions v')
| not (v' `withinRange` dockerRequireDockerVersion docker) ->
throwM (BadDockerVersionException (dockerRequireDockerVersion docker) v')
| otherwise ->
return ()
_ -> throwM InvalidVersionOutputException
_ -> throwM InvalidVersionOutputException
where minimumDockerVersion = $(mkVersion "1.6.0")
prohibitedDockerVersions = []
-- | Remove the project's Docker sandbox.
reset :: (MonadIO m, MonadReader env m, HasConfig env)
=> Maybe (Path Abs Dir) -> Bool -> m ()
reset maybeProjectRoot keepHome = do
dockerSandboxDir <- projectDockerSandboxDir projectRoot
liftIO (removeDirectoryContents
dockerSandboxDir
[homeDirName | keepHome]
[])
where projectRoot = fromMaybeProjectRoot maybeProjectRoot
-- | The Docker container "entrypoint": special actions performed when first entering
-- a container, such as switching the UID/GID to the "outside-Docker" user's.
entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
=> Config -> DockerEntrypoint -> m ()
entrypoint config@Config{..} DockerEntrypoint{..} =
modifyMVar_ entrypointMVar $ \alreadyRan -> do
-- Only run the entrypoint once
unless alreadyRan $ do
envOverride <- getEnvOverride configPlatform
homeDir <- parseAbsDir =<< liftIO (getEnv "HOME")
-- Get the UserEntry for the 'stack' user in the image, if it exists
estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $
User.getUserEntryForName stackUserName
-- Switch UID/GID if needed, and update user's home directory
case deUidGid of
Nothing -> return ()
Just (0,_) -> return ()
Just (uid,gid) -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir uid gid
case estackUserEntry0 of
Left _ -> return ()
Right ue -> do
-- If the 'stack' user exists in the image, copy any build plans and package indices from
-- its original home directory to the host's stack root, to avoid needing to download them
origStackHomeDir <- parseAbsDir (User.homeDirectory ue)
let origStackRoot = origStackHomeDir $(mkRelDir ("." ++ stackProgName))
buildPlanDirExists <- dirExists (buildPlanDir origStackRoot)
when buildPlanDirExists $ do
(_, buildPlans) <- listDirectory (buildPlanDir origStackRoot)
forM_ buildPlans $ \srcBuildPlan -> do
let destBuildPlan = buildPlanDir configStackRoot filename srcBuildPlan
exists <- fileExists destBuildPlan
unless exists $ do
createTree (parent destBuildPlan)
copyFile srcBuildPlan destBuildPlan
forM_ configPackageIndices $ \pkgIdx -> do
msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do
srcIndex <- configPackageIndex (indexName pkgIdx)
exists <- fileExists srcIndex
return $ if exists
then Just srcIndex
else Nothing
case msrcIndex of
Nothing -> return ()
Just srcIndex -> do
flip runReaderT config $ do
destIndex <- configPackageIndex (indexName pkgIdx)
exists <- fileExists destIndex
unless exists $ do
createTree (parent destIndex)
copyFile srcIndex destIndex
return True
where
updateOrCreateStackUser envOverride estackUserEntry homeDir uid gid = do
case estackUserEntry of
Left _ -> do
-- If no 'stack' user in image, create one with correct UID/GID and home directory
readProcessNull Nothing envOverride "groupadd"
["-o"
,"--gid",show gid
,stackUserName]
readProcessNull Nothing envOverride "useradd"
["-oN"
,"--uid",show uid
,"--gid",show gid
,"--home",toFilePathNoTrailingSep homeDir
,stackUserName]
Right _ -> do
-- If there is already a 'stack' user in thr image, adjust its UID/GID and home directory
readProcessNull Nothing envOverride "usermod"
["-o"
,"--uid",show uid
,"--home",toFilePathNoTrailingSep homeDir
,stackUserName]
readProcessNull Nothing envOverride "groupmod"
["-o"
,"--gid",show gid
,stackUserName]
-- 'setuid' to the wanted UID and GID
liftIO $ do
User.setGroupID gid
User.setUserID uid
stackUserName = "stack"::String
-- | MVar used to ensure the Docker entrypoint is performed exactly once
entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar = unsafePerformIO (newMVar False)
-- | Remove the contents of a directory, without removing the directory itself.
-- This is used instead of 'FS.removeTree' to clear bind-mounted directories, since
-- removing the root of the bind-mount won't work.
removeDirectoryContents :: Path Abs Dir -- ^ Directory to remove contents of
-> [Path Rel Dir] -- ^ Top-level directory names to exclude from removal
-> [Path Rel File] -- ^ Top-level file names to exclude from removal
-> IO ()
removeDirectoryContents path excludeDirs excludeFiles =
do isRootDir <- dirExists path
when isRootDir
(do (lsd,lsf) <- listDirectory path
forM_ lsd
(\d -> unless (dirname d `elem` excludeDirs)
(removeTree d))
forM_ lsf
(\f -> unless (filename f `elem` excludeFiles)
(removeFile f)))
-- | Produce a strict 'S.ByteString' from the stdout of a
-- process. Throws a 'ReadProcessException' exception if the
-- process fails. Logs process's stderr using @$logError@.
readDockerProcess
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride -> [String] -> m BS.ByteString
readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker"
-- | Name of home directory within docker sandbox.
homeDirName :: Path Rel Dir
homeDirName = $(mkRelDir "_home/")
-- | Directory where 'stack' executable is bind-mounted in Docker container
hostBinDir :: FilePath
hostBinDir = "/opt/host/bin"
-- | Convenience function to decode ByteString to String.
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 bs = T.unpack (T.decodeUtf8 bs)
-- | Convenience function constructing message for @$log*@.
concatT :: [String] -> Text
concatT = T.pack . concat
-- | Fail with friendly error if project root not set.
fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
-- | Environment variable that contained the old sandbox ID.
-- | Use of this variable is deprecated, and only used to detect old images.
oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
-- | Environment variable used to indicate stack is running in container.
inContainerEnvVar :: String
inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
-- | Command-line argument for "docker"
dockerCmdName :: String
dockerCmdName = "docker"
-- | Command-line argument for @docker pull@.
dockerPullCmdName :: String
dockerPullCmdName = "pull"
-- | Command-line argument for @docker cleanup@.
dockerCleanupCmdName :: String
dockerCleanupCmdName = "cleanup"
-- | Command-line option for @--internal-re-exec-version@.
reExecArgName :: String
reExecArgName = "internal-re-exec-version"
-- | Platform that Docker containers run
dockerContainerPlatform :: Platform
dockerContainerPlatform = Platform X86_64 Linux
-- | Options for 'cleanup'.
data CleanupOpts = CleanupOpts
{ dcAction :: !CleanupAction
, dcRemoveKnownImagesLastUsedDaysAgo :: !(Maybe Integer)
, dcRemoveUnknownImagesCreatedDaysAgo :: !(Maybe Integer)
, dcRemoveDanglingImagesCreatedDaysAgo :: !(Maybe Integer)
, dcRemoveStoppedContainersCreatedDaysAgo :: !(Maybe Integer)
, dcRemoveRunningContainersCreatedDaysAgo :: !(Maybe Integer) }
deriving (Show)
-- | Cleanup action.
data CleanupAction = CleanupInteractive
| CleanupImmediate
| CleanupDryRun
deriving (Show)
-- | Parsed result of @docker inspect@.
data Inspect = Inspect
{iiConfig :: ImageConfig
,iiCreated :: UTCTime
,iiId :: String
,iiVirtualSize :: Maybe Integer}
deriving (Show)
-- | Parse @docker inspect@ output.
instance FromJSON Inspect where
parseJSON v =
do o <- parseJSON v
Inspect <$> o .: "Config"
<*> o .: "Created"
<*> o .: "Id"
<*> o .:? "VirtualSize"
-- | Parsed @Config@ section of @docker inspect@ output.
data ImageConfig = ImageConfig
{icEnv :: [String]
,icEntrypoint :: [String]}
deriving (Show)
-- | Parse @Config@ section of @docker inspect@ output.
instance FromJSON ImageConfig where
parseJSON v =
do o <- parseJSON v
ImageConfig
<$> o .:? "Env" .!= []
<*> o .:? "Entrypoint" .!= []
-- | Exceptions thrown by Stack.Docker.
data StackDockerException
= DockerMustBeEnabledException
-- ^ Docker must be enabled to use the command.
| OnlyOnHostException
-- ^ Command must be run on host OS (not in a container).
| InspectFailedException String
-- ^ @docker inspect@ failed.
| NotPulledException String
-- ^ Image does not exist.
| InvalidCleanupCommandException String
-- ^ Input to @docker cleanup@ has invalid command.
| InvalidImagesOutputException String
-- ^ Invalid output from @docker images@.
| InvalidPSOutputException String
-- ^ Invalid output from @docker ps@.
| InvalidInspectOutputException String
-- ^ Invalid output from @docker inspect@.
| PullFailedException String
-- ^ Could not pull a Docker image.
| DockerTooOldException Version Version
-- ^ Installed version of @docker@ below minimum version.
| DockerVersionProhibitedException [Version] Version
-- ^ Installed version of @docker@ is prohibited.
| BadDockerVersionException VersionRange Version
-- ^ Installed version of @docker@ is out of range specified in config file.
| InvalidVersionOutputException
-- ^ Invalid output from @docker --version@.
| HostStackTooOldException Version (Maybe Version)
-- ^ Version of @stack@ on host is too old for version in image.
| ContainerStackTooOldException Version Version
-- ^ Version of @stack@ in container/image is too old for version on host.
| CannotDetermineProjectRootException
-- ^ Can't determine the project root (where to put docker sandbox).
| DockerNotInstalledException
-- ^ @docker --version@ failed.
| UnsupportedStackExeHostPlatformException
-- ^ Using host stack-exe on unsupported platform.
deriving (Typeable)
-- | Exception instance for StackDockerException.
instance Exception StackDockerException
-- | Show instance for StackDockerException.
instance Show StackDockerException where
show DockerMustBeEnabledException =
"Docker must be enabled in your configuration file to use this command."
show OnlyOnHostException =
"This command must be run on host OS (not in a Docker container)."
show (InspectFailedException image) =
concat ["'docker inspect' failed for image after pull: ",image,"."]
show (NotPulledException image) =
concat ["The Docker image referenced by your configuration file"
," has not\nbeen downloaded:\n "
,image
,"\n\nRun '"
,unwords [stackProgName, dockerCmdName, dockerPullCmdName]
,"' to download it, then try again."]
show (InvalidCleanupCommandException line) =
concat ["Invalid line in cleanup commands: '",line,"'."]
show (InvalidImagesOutputException line) =
concat ["Invalid 'docker images' output line: '",line,"'."]
show (InvalidPSOutputException line) =
concat ["Invalid 'docker ps' output line: '",line,"'."]
show (InvalidInspectOutputException msg) =
concat ["Invalid 'docker inspect' output: ",msg,"."]
show (PullFailedException image) =
concat ["Could not pull Docker image:\n "
,image
,"\nThere may not be an image on the registry for your resolver's LTS version in\n"
,"your configuration file."]
show (DockerTooOldException minVersion haveVersion) =
concat ["Minimum docker version '"
,versionString minVersion
,"' is required by "
,stackProgName
," (you have '"
,versionString haveVersion
,"')."]
show (DockerVersionProhibitedException prohibitedVersions haveVersion) =
concat ["These Docker versions are incompatible with "
,stackProgName
," (you have '"
,versionString haveVersion
,"'): "
,intercalate ", " (map versionString prohibitedVersions)
,"."]
show (BadDockerVersionException requiredRange haveVersion) =
concat ["The version of 'docker' you are using ("
,show haveVersion
,") is outside the required\n"
,"version range specified in stack.yaml ("
,T.unpack (versionRangeText requiredRange)
,")."]
show InvalidVersionOutputException =
"Cannot get Docker version (invalid 'docker --version' output)."
show (HostStackTooOldException minVersion (Just hostVersion)) =
concat ["The host's version of '"
,stackProgName
,"' is too old for this Docker image.\nVersion "
,versionString minVersion
," is required; you have "
,versionString hostVersion
,"."]
show (HostStackTooOldException minVersion Nothing) =
concat ["The host's version of '"
,stackProgName
,"' is too old.\nVersion "
,versionString minVersion
," is required."]
show (ContainerStackTooOldException requiredVersion containerVersion) =
concat ["The Docker container's version of '"
,stackProgName
,"' is too old.\nVersion "
,versionString requiredVersion
," is required; the container has "
,versionString containerVersion
,"."]
show CannotDetermineProjectRootException =
"Cannot determine project root directory for Docker sandbox."
show DockerNotInstalledException =
"Cannot find 'docker' in PATH. Is Docker installed?"
show UnsupportedStackExeHostPlatformException = concat
[ "Using host's "
, stackProgName
, " executable in Docker container is only supported on "
, display dockerContainerPlatform
, " platform" ]
-- | Function to get command and arguments to run in Docker container
type GetCmdArgs env m
= M env m
=> DockerOpts
-> EnvOverride
-> Inspect
-> Bool
-> m (FilePath,[String],[(String,String)],[Mount])
type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m
,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m)
stack-0.1.10.0/src/Stack/Docker/GlobalDB.hs 0000644 0000000 0000000 00000012116 12607713542 016237 0 ustar 00 0000000 0000000 {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings,
GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving,
RankNTypes, NamedFieldPuns #-}
-- | Global sqlite database shared by all projects.
-- Warning: this is currently only accessible from __outside__ a Docker container.
module Stack.Docker.GlobalDB
(updateDockerImageLastUsed
,getDockerImagesLastUsed
,pruneDockerImagesLastUsed
,DockerImageLastUsed
,DockerImageProjectId
,getDockerImageExe
,setDockerImageExe
,DockerImageExeId)
where
import Control.Exception (IOException,catch,throwIO)
import Control.Monad (forM_)
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Trans.Resource (ResourceT)
import Data.List (sortBy, isInfixOf, stripPrefix)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime,getCurrentTime)
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Path (toFilePath, parent)
import Path.IO (createTree)
import Stack.Types.Config
import Stack.Types.Docker
share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase|
DockerImageProject
imageHash String
projectPath FilePath
lastUsedTime UTCTime
DockerImageProjectPathKey imageHash projectPath
deriving Show
DockerImageExe
imageHash String
exePath FilePath
exeTimestamp UTCTime
compatible Bool
DockerImageExeUnique imageHash exePath exeTimestamp
deriving Show
|]
-- | Update last used time and project for a Docker image hash.
updateDockerImageLastUsed :: Config -> String -> FilePath -> IO ()
updateDockerImageLastUsed config imageId projectPath =
do curTime <- getCurrentTime
_ <- withGlobalDB config (upsert (DockerImageProject imageId projectPath curTime) [])
return ()
-- | Get a list of Docker image hashes and when they were last used.
getDockerImagesLastUsed :: Config -> IO [DockerImageLastUsed]
getDockerImagesLastUsed config =
do imageProjects <- withGlobalDB config (selectList [] [Asc DockerImageProjectLastUsedTime])
return (sortBy (flip sortImage)
(Map.toDescList (Map.fromListWith (++)
(map mapImageProject imageProjects))))
where
mapImageProject (Entity _ imageProject) =
(dockerImageProjectImageHash imageProject
,[(dockerImageProjectLastUsedTime imageProject
,dockerImageProjectProjectPath imageProject)])
sortImage (_,(a,_):_) (_,(b,_):_) = compare a b
sortImage _ _ = EQ
-- | Given a list of all existing Docker images, remove any that no longer exist from
-- the database.
pruneDockerImagesLastUsed :: Config -> [String] -> IO ()
pruneDockerImagesLastUsed config existingHashes =
withGlobalDB config go
where go = do l <- selectList [] []
forM_ l (\(Entity k (DockerImageProject{dockerImageProjectImageHash = h})) ->
if h `elem` existingHashes
then return ()
else delete k)
-- | Get the record of whether an executable is compatible with a Docker image
getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool)
getDockerImageExe config imageId exePath exeTimestamp =
withGlobalDB config $ do
mentity <- getBy (DockerImageExeUnique imageId exePath exeTimestamp)
return (fmap (dockerImageExeCompatible . entityVal) mentity)
-- | Seet the record of whether an executable is compatible with a Docker image
setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO ()
setDockerImageExe config imageId exePath exeTimestamp compatible =
withGlobalDB config $
do _ <- upsert (DockerImageExe imageId exePath exeTimestamp compatible) []
return ()
-- | Run an action with the global database. This performs any needed migrations as well.
withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a
withGlobalDB config action =
do let db = dockerDatabasePath (configDocker config)
createTree (parent db)
runSqlite (T.pack (toFilePath db))
(do _ <- runMigrationSilent migrateTables
action)
`catch` \ex -> do
let str = show ex
stripSuffix x = fmap reverse . stripPrefix x . reverse
str' = fromMaybe str $ stripPrefix "user error (" $
fromMaybe str $ stripSuffix ")" str
if "ErrorReadOnly" `isInfixOf` str
then fail $ str' ++
" This likely indicates that your DB file, " ++
toFilePath db ++ ", has incorrect permissions or ownership."
else throwIO (ex :: IOException)
-- | Date and project path where Docker image hash last used.
type DockerImageLastUsed = (String, [(UTCTime, FilePath)])
stack-0.1.10.0/src/Stack/Dot.hs 0000644 0000000 0000000 00000026113 12623647202 014147 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Dot (dot
,listDependencies
,DotOpts(..)
,resolveDependencies
,printGraph
,pruneGraph
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad (liftM, void)
import Control.Monad.Catch (MonadCatch,MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
import Network.HTTP.Client.Conduit (HasHttpManager)
import Prelude -- Fix redundant import warnings
import Stack.Build (withLoadPackage)
import Stack.Build.Installed (getInstalled, GetInstalledOpts(..))
import Stack.Build.Source
import Stack.Build.Target
import Stack.Constants
import Stack.Package
import Stack.Types
import Stack.Types.Internal (HasLogLevel)
-- | Options record for @stack dot@
data DotOpts = DotOpts
{ dotIncludeExternal :: Bool
-- ^ Include external dependencies
, dotIncludeBase :: Bool
-- ^ Include dependencies on base
, dotDependencyDepth :: Maybe Int
-- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint
, dotPrune :: Set String
-- ^ Package names to prune from the graph
}
-- | Visualize the project's dependencies as a graphviz graph
dot :: (HasEnvConfig env
,HasHttpManager env
,HasLogLevel env
,MonadBaseControl IO m
,MonadCatch m
,MonadLogger m
,MonadIO m
,MonadMask m
,MonadReader env m
)
=> DotOpts
-> m ()
dot dotOpts = do
localNames <- liftM Map.keysSet getLocalPackageViews
resultGraph <- createDependencyGraph dotOpts
let pkgsToPrune = if dotIncludeBase dotOpts
then dotPrune dotOpts
else Set.insert "base" (dotPrune dotOpts)
prunedGraph = pruneGraph localNames pkgsToPrune resultGraph
printGraph dotOpts localNames prunedGraph
-- | Create the dependency graph, the result is a map from a package
-- name to a tuple of dependencies and a version if available. This
-- function mainly gathers the required arguments for
-- @resolveDependencies@.
createDependencyGraph :: (HasEnvConfig env
,HasHttpManager env
,HasLogLevel env
,MonadLogger m
,MonadBaseControl IO m
,MonadCatch m
,MonadIO m
,MonadMask m
,MonadReader env m)
=> DotOpts
-> m (Map PackageName (Set PackageName, Maybe Version))
createDependencyGraph dotOpts = do
(_,_,locals,_,sourceMap) <- loadSourceMap NeedTargets defaultBuildOpts
let graph = Map.fromList (localDependencies dotOpts locals)
menv <- getMinimalEnvOverride
installedMap <- fmap snd . fst4 <$> getInstalled menv
(GetInstalledOpts False False)
sourceMap
withLoadPackage menv (\loader -> do
let depLoader =
createDepLoader sourceMap
installedMap
(fmap3 (packageAllDeps &&& (Just . packageVersion)) loader)
liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)
where -- fmap a function over the result of a function with 3 arguments
fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e
fmap3 f g a b c = f <$> g a b c
fst4 :: (a,b,c,d) -> a
fst4 (x,_,_,_) = x
listDependencies :: (HasEnvConfig env
,HasHttpManager env
,HasLogLevel env
,MonadBaseControl IO m
,MonadCatch m
,MonadLogger m
,MonadMask m
,MonadIO m
,MonadReader env m
)
=> Text
-> m ()
listDependencies sep = do
let dotOpts = DotOpts True True Nothing Set.empty
resultGraph <- createDependencyGraph dotOpts
void (Map.traverseWithKey go (snd <$> resultGraph))
where go name v = liftIO (Text.putStrLn $
Text.pack (packageNameString name) <>
sep <>
maybe "" (Text.pack . show) v)
-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
-- @graph@ with a name in @toPrune@ and removes resulting orphans
-- unless they are in @dontPrune@
pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
=> f PackageName
-> g String
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph dontPrune names =
pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) ->
if show pkg `F.elem` names
then Nothing
else let filtered = Set.filter (\n -> show n `F.notElem` names) pkgDeps
in if Set.null filtered && not (Set.null pkgDeps)
then Nothing
else Just (filtered,x))
-- | Make sure that all unreachable nodes (orphans) are pruned
pruneUnreachable :: (Eq a, F.Foldable f)
=> f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable dontPrune = fixpoint prune
where fixpoint :: Eq a => (a -> a) -> a -> a
fixpoint f v = if f v == v then v else fixpoint f (f v)
prune graph' = Map.filterWithKey (\k _ -> reachable k) graph'
where reachable k = k `F.elem` dontPrune || k `Set.member` reachables
reachables = F.fold (fst <$> graph')
-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached
resolveDependencies :: (Applicative m, Monad m)
=> Maybe Int
-> Map PackageName (Set PackageName,Maybe Version)
-> (PackageName -> m (Set PackageName, Maybe Version))
-> m (Map PackageName (Set PackageName,Maybe Version))
resolveDependencies (Just 0) graph _ = return graph
resolveDependencies limit graph loadPackageDeps = do
let values = Set.unions (fst <$> Map.elems graph)
keys = Map.keysSet graph
next = Set.difference values keys
if Set.null next
then return graph
else do
x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next)
resolveDependencies (subtract 1 <$> limit)
(Map.unionWith unifier graph (Map.fromList x))
loadPackageDeps
where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)
-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
createDepLoader :: Applicative m
=> Map PackageName PackageSource
-> Map PackageName Installed
-> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName,Maybe Version))
-> PackageName
-> m (Set PackageName, Maybe Version)
createDepLoader sourceMap installed loadPackageDeps pkgName =
case Map.lookup pkgName sourceMap of
Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp))
Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags
Nothing -> pure (Set.empty, fmap installedVersion (Map.lookup pkgName installed))
-- | Resolve the direct (depth 0) external dependencies of the given local packages
localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))]
localDependencies dotOpts locals =
map (\lp -> (packageName (lpPackage lp), (deps lp,Just (lpVersion lp)))) locals
where deps lp = if dotIncludeExternal dotOpts
then Set.delete (lpName lp) (packageAllDeps (lpPackage lp))
else Set.intersection localNames (packageAllDeps (lpPackage lp))
lpName lp = packageName (lpPackage lp)
localNames = Set.fromList $ map (packageName . lpPackage) locals
lpVersion lp = packageVersion (lpPackage lp)
-- | Print a graphviz graph of the edges in the Map and highlight the given local packages
printGraph :: (Applicative m, MonadIO m)
=> DotOpts
-> Set PackageName -- ^ all locals
-> Map PackageName (Set PackageName, Maybe Version)
-> m ()
printGraph dotOpts locals graph = do
liftIO $ Text.putStrLn "strict digraph deps {"
printLocalNodes dotOpts filteredLocals
printLeaves graph
void (Map.traverseWithKey printEdges (fst <$> graph))
liftIO $ Text.putStrLn "}"
where filteredLocals = Set.filter (\local ->
packageNameString local `Set.notMember` dotPrune dotOpts) locals
-- | Print the local nodes with a different style depending on options
printLocalNodes :: (F.Foldable t, MonadIO m)
=> DotOpts
-> t PackageName
-> m ()
printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes)
where applyStyle :: Text -> Text
applyStyle n = if dotIncludeExternal dotOpts
then n <> " [style=dashed];"
else n <> " [style=solid];"
lpNodes :: [Text]
lpNodes = map (applyStyle . nodeName) (F.toList locals)
-- | Print nodes without dependencies
printLeaves :: (Applicative m, MonadIO m)
=> Map PackageName (Set PackageName,Maybe Version)
-> m ()
printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst
-- | @printDedges p ps@ prints an edge from p to every ps
printEdges :: (Applicative m, MonadIO m) => PackageName -> Set PackageName -> m ()
printEdges package deps = F.for_ deps (printEdge package)
-- | Print an edge between the two package names
printEdge :: MonadIO m => PackageName -> PackageName -> m ()
printEdge from to = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to, ";"])
-- | Convert a package name to a graph node name.
nodeName :: PackageName -> Text
nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""
-- | Print a node with no dependencies
printLeaf :: MonadIO m => PackageName -> m ()
printLeaf package = liftIO . Text.putStrLn . Text.concat $
if isWiredIn package
then ["{rank=max; ", nodeName package, " [shape=box]; };"]
else ["{rank=max; ", nodeName package, "; };"]
-- | Check if the package is wired in (shipped with) ghc
isWiredIn :: PackageName -> Bool
isWiredIn = (`HashSet.member` wiredInPackages)
stack-0.1.10.0/src/Stack/Fetch.hs 0000644 0000000 0000000 00000060123 12630352213 014442 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ViewPatterns #-}
-- | Functionality for downloading packages securely for cabal's usage.
module Stack.Fetch
( unpackPackages
, unpackPackageIdents
, fetchPackages
, resolvePackages
, resolvePackagesAllowMissing
, ResolvedPackage (..)
, withCabalFiles
, withCabalLoader
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Check as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import Codec.Compression.GZip (decompress)
import Control.Applicative
import Control.Concurrent.Async (Concurrently (..))
import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar)
import Control.Concurrent.STM (TVar, atomically, modifyTVar,
newTVarIO, readTVar,
readTVarIO, writeTVar)
import Control.Exception (assert)
import Control.Monad (join, liftM, unless, void,
when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (asks, runReaderT)
import Control.Monad.Trans.Control
import "cryptohash" Crypto.Hash (SHA512 (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import Data.Function (fix)
import Data.IORef (newIORef, readIORef,
writeIORef)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (maybeToList, catMaybes)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable (Typeable)
import Data.Word (Word64)
import Network.HTTP.Download
import Path
import Path.IO (dirExists, createTree)
import Prelude -- Fix AMP warning
import Stack.GhcPkg
import Stack.PackageIndex
import Stack.Types
import System.Directory (canonicalizePath,
createDirectoryIfMissing,
doesDirectoryExist,
renameDirectory)
import System.FilePath ((<.>))
import qualified System.FilePath as FP
import System.IO (IOMode (ReadMode),
SeekMode (AbsoluteSeek), hSeek,
withBinaryFile)
import System.PosixCompat (setFileMode)
import Text.EditDistance as ED
type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache)
data FetchException
= Couldn'tReadIndexTarball FilePath Tar.FormatError
| Couldn'tReadPackageTarball FilePath SomeException
| UnpackDirectoryAlreadyExists (Set FilePath)
| CouldNotParsePackageSelectors [String]
| UnknownPackageNames (Set PackageName)
| UnknownPackageIdentifiers (Set PackageIdentifier) String
deriving Typeable
instance Exception FetchException
instance Show FetchException where
show (Couldn'tReadIndexTarball fp err) = concat
[ "There was an error reading the index tarball "
, fp
, ": "
, show err
]
show (Couldn'tReadPackageTarball fp err) = concat
[ "There was an error reading the package tarball "
, fp
, ": "
, show err
]
show (UnpackDirectoryAlreadyExists dirs) = unlines
$ "Unable to unpack due to already present directories:"
: map (" " ++) (Set.toList dirs)
show (CouldNotParsePackageSelectors strs) =
"The following package selectors are not valid package names or identifiers: " ++
intercalate ", " strs
show (UnknownPackageNames names) =
"The following packages were not found in your indices: " ++
intercalate ", " (map packageNameString $ Set.toList names)
show (UnknownPackageIdentifiers idents suggestions) =
"The following package identifiers were not found in your indices: " ++
intercalate ", " (map packageIdentifierString $ Set.toList idents) ++
(if null suggestions then "" else "\n" ++ suggestions)
-- | Fetch packages into the cache without unpacking
fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)
=> EnvOverride
-> Set PackageIdentifier
-> m ()
fetchPackages menv idents = do
resolved <- resolvePackages menv idents Set.empty
ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved
assert (Map.null alreadyUnpacked) (return ())
nowUnpacked <- fetchPackages' Nothing toFetch
assert (Map.null nowUnpacked) (return ())
-- | Intended to work for the command line command.
unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)
=> EnvOverride
-> FilePath -- ^ destination
-> [String] -- ^ names or identifiers
-> m ()
unpackPackages menv dest input = do
dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir
(names, idents) <- case partitionEithers $ map parse input of
([], x) -> return $ partitionEithers x
(errs, _) -> throwM $ CouldNotParsePackageSelectors errs
resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)
ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved
unless (Map.null alreadyUnpacked) $
throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked
unpacked <- fetchPackages' Nothing toFetch
F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> $logInfo $ T.pack $ concat
[ "Unpacked "
, packageIdentifierString ident
, " to "
, toFilePath dest''
]
where
-- Possible future enhancement: parse names as name + version range
parse s =
case parsePackageNameFromString s of
Right x -> Right $ Left x
Left _ ->
case parsePackageIdentifierFromString s of
Left _ -> Left s
Right x -> Right $ Right x
-- | Ensure that all of the given package idents are unpacked into the build
-- unpack directory, and return the paths to all of the subdirectories.
unpackPackageIdents
:: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)
=> EnvOverride
-> Path Abs Dir -- ^ unpack directory
-> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157
-> Set PackageIdentifier
-> m (Map PackageIdentifier (Path Abs Dir))
unpackPackageIdents menv unpackDir mdistDir idents = do
resolved <- resolvePackages menv idents Set.empty
ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved
nowUnpacked <- fetchPackages' mdistDir toFetch
return $ alreadyUnpacked <> nowUnpacked
data ResolvedPackage = ResolvedPackage
{ rpCache :: !PackageCache
, rpIndex :: !PackageIndex
}
-- | Resolve a set of package names and identifiers into @FetchPackage@ values.
resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> Set PackageIdentifier
-> Set PackageName
-> m (Map PackageIdentifier ResolvedPackage)
resolvePackages menv idents0 names0 = do
eres <- go
case eres of
Left _ -> do
updateAllIndices menv
go >>= either throwM return
Right x -> return x
where
go = r <$> resolvePackagesAllowMissing menv idents0 names0
r (missingNames, missingIdents, idents)
| not $ Set.null missingNames = Left $ UnknownPackageNames missingNames
| not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents ""
| otherwise = Right idents
resolvePackagesAllowMissing
:: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> Set PackageIdentifier
-> Set PackageName
-> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)
resolvePackagesAllowMissing menv idents0 names0 = do
caches <- getPackageCaches menv
let versions = Map.fromListWith max $ map toTuple $ Map.keys caches
(missingNames, idents1) = partitionEithers $ map
(\name -> maybe (Left name ) (Right . PackageIdentifier name)
(Map.lookup name versions))
(Set.toList names0)
(missingIdents, resolved) = partitionEithers $ map (goIdent caches)
$ Set.toList
$ idents0 <> Set.fromList idents1
return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved)
where
goIdent caches ident =
case Map.lookup ident caches of
Nothing -> Left ident
Just (index, cache) -> Right (ident, ResolvedPackage
{ rpCache = cache
, rpIndex = index
})
data ToFetch = ToFetch
{ tfTarball :: !(Path Abs File)
, tfDestDir :: !(Maybe (Path Abs Dir))
, tfUrl :: !T.Text
, tfSize :: !(Maybe Word64)
, tfSHA512 :: !(Maybe ByteString)
, tfCabal :: !ByteString
-- ^ Contents of the .cabal file
}
data ToFetchResult = ToFetchResult
{ tfrToFetch :: !(Map PackageIdentifier ToFetch)
, tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir))
}
-- | Add the cabal files to a list of idents with their caches.
withCabalFiles
:: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
=> IndexName
-> [(PackageIdentifier, PackageCache, a)]
-> (PackageIdentifier -> a -> ByteString -> IO b)
-> m [b]
withCabalFiles name pkgs f = do
indexPath <- configPackageIndex name
liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->
mapM (goPkg h) pkgs
where
goPkg h (ident, pc, tf) = do
hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc
cabalBS <- S.hGet h $ fromIntegral $ pcSize pc
f ident tf cabalBS
-- | Provide a function which will load up a cabal @ByteString@ from the
-- package indices.
withCabalLoader
:: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> ((PackageIdentifier -> IO ByteString) -> m a)
-> m a
withCabalLoader menv inner = do
icaches <- getPackageCaches menv >>= liftIO . newIORef
env <- ask
-- Want to try updating the index once during a single run for missing
-- package identifiers. We also want to ensure we only update once at a
-- time
updateRef <- liftIO $ newMVar True
runInBase <- liftBaseWith $ \run -> return (void . run)
-- TODO in the future, keep all of the necessary @Handle@s open
let doLookup :: PackageIdentifier
-> IO ByteString
doLookup ident = do
cachesCurr <- liftIO $ readIORef icaches
eres <- lookupPackageIdentifierExact ident env cachesCurr
case eres of
Just bs -> return bs
-- Update the cache and try again
Nothing -> do
let fuzzy = fuzzyLookupCandidates ident cachesCurr
suggestions = case fuzzy of
Nothing ->
case typoCorrectionCandidates ident cachesCurr of
Nothing -> ""
Just cs -> "Perhaps you meant " <>
orSeparated cs <> "?"
Just cs -> "Possible candidates: " <>
commaSeparated (NE.map packageIdentifierString cs)
<> "."
join $ modifyMVar updateRef $ \toUpdate ->
if toUpdate then do
runInBase $ do
$logInfo $ T.concat
[ "Didn't see "
, T.pack $ packageIdentifierString ident
, " in your package indices.\n"
, "Updating and trying again."
]
updateAllIndices menv
caches <- getPackageCaches menv
liftIO $ writeIORef icaches caches
return (False, doLookup ident)
else return (toUpdate,
throwM $ UnknownPackageIdentifiers
(Set.singleton ident) suggestions)
inner doLookup
lookupPackageIdentifierExact
:: HasConfig env
=> PackageIdentifier
-> env
-> PackageCaches
-> IO (Maybe ByteString)
lookupPackageIdentifierExact ident env caches =
case Map.lookup ident caches of
Nothing -> return Nothing
Just (index, cache) -> do
[bs] <- flip runReaderT env
$ withCabalFiles (indexName index) [(ident, cache, ())]
$ \_ _ bs -> return bs
return $ Just bs
-- | Given package identifier and package caches, return list of packages
-- with the same name and the same two first version number components found
-- in the caches.
fuzzyLookupCandidates
:: PackageIdentifier
-> PackageCaches
-> Maybe (NonEmpty PackageIdentifier)
fuzzyLookupCandidates (PackageIdentifier name ver) caches =
let (_, zero, bigger) = Map.splitLookup zeroIdent caches
zeroIdent = PackageIdentifier name $(mkVersion "0.0")
sameName (PackageIdentifier n _) = n == name
sameMajor (PackageIdentifier _ v) = toMajorVersion v == toMajorVersion ver
in NE.nonEmpty . filter sameMajor $ maybe [] (pure . const zeroIdent) zero
<> takeWhile sameName (Map.keys bigger)
-- | Try to come up with typo corrections for given package identifier using
-- package caches. This should be called before giving up, i.e. when
-- 'fuzzyLookupCandidates' cannot return anything.
typoCorrectionCandidates
:: PackageIdentifier
-> PackageCaches
-> Maybe (NonEmpty String)
typoCorrectionCandidates ident =
let getName = packageNameString . packageIdentifierName
name = getName ident
in NE.nonEmpty
. Map.keys
. Map.filterWithKey (const . (== 1) . damerauLevenshtein name)
. Map.mapKeys getName
-- | Figure out where to fetch from.
getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
=> Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack
-> Map PackageIdentifier ResolvedPackage
-> m ToFetchResult
getToFetch mdest resolvedAll = do
(toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked $ Map.toList resolvedAll
toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0
return ToFetchResult
{ tfrToFetch = Map.unions toFetch1
, tfrAlreadyUnpacked = Map.fromList unpacked
}
where
checkUnpacked (ident, resolved) = do
dirRel <- parseRelDir $ packageIdentifierString ident
let mdestDir = ( dirRel) <$> mdest
mexists <-
case mdestDir of
Nothing -> return Nothing
Just destDir -> do
exists <- dirExists destDir
return $ if exists then Just destDir else Nothing
case mexists of
Just destDir -> return $ Right (ident, destDir)
Nothing -> do
let index = rpIndex resolved
d = pcDownload $ rpCache resolved
targz = T.pack $ packageIdentifierString ident ++ ".tar.gz"
tarball <- configPackageTarball (indexName index) ident
return $ Left (indexName index, [(ident, rpCache resolved, ToFetch
{ tfTarball = tarball
, tfDestDir = mdestDir
, tfUrl = case d of
Just d' -> decodeUtf8 $ pdUrl d'
Nothing -> indexDownloadPrefix index <> targz
, tfSize = fmap pdSize d
, tfSHA512 = fmap pdSHA512 d
, tfCabal = S.empty -- filled in by goIndex
})])
goIndex (name, pkgs) =
liftM Map.fromList $
withCabalFiles name pkgs $ \ident tf cabalBS ->
return (ident, tf { tfCabal = cabalBS })
-- | Download the given name,version pairs into the directory expected by cabal.
--
-- For each package it downloads, it will optionally unpack it to the given
-- @Path@ (if present). Note that unpacking is not simply a matter of
-- untarring, but also of grabbing the cabal file from the package index. The
-- destinations should not include package identifiers.
--
-- Returns the list of paths unpacked, including package identifiers. E.g.:
--
-- @
-- fetchPackages [("foo-1.2.3", Just "/some/dest")] ==> ["/some/dest/foo-1.2.3"]
-- @
--
-- Since 0.1.0.0
fetchPackages' :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)
=> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157
-> Map PackageIdentifier ToFetch
-> m (Map PackageIdentifier (Path Abs Dir))
fetchPackages' mdistDir toFetchAll = do
connCount <- asks $ configConnectionCount . getConfig
outputVar <- liftIO $ newTVarIO Map.empty
runInBase <- liftBaseWith $ \run -> return (void . run)
parMapM_
connCount
(go outputVar runInBase)
(Map.toList toFetchAll)
liftIO $ readTVarIO outputVar
where
go :: (MonadIO m,Functor m,MonadThrow m,MonadLogger m,MonadReader env m,HasHttpManager env)
=> TVar (Map PackageIdentifier (Path Abs Dir))
-> (m () -> IO ())
-> (PackageIdentifier, ToFetch)
-> m ()
go outputVar runInBase (ident, toFetch) = do
req <- parseUrl $ T.unpack $ tfUrl toFetch
let destpath = tfTarball toFetch
let toHashCheck bs = HashCheck SHA512 (CheckHexDigestByteString bs)
let downloadReq = DownloadRequest
{ drRequest = req
, drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch)
, drLengthCheck = fromIntegral <$> tfSize toFetch
, drRetryPolicy = drRetryPolicyDefault
}
let progressSink _ =
liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
_ <- verifiedDownload downloadReq destpath progressSink
let fp = toFilePath destpath
F.forM_ (tfDestDir toFetch) $ \destDir -> do
let dest = toFilePath $ parent destDir
innerDest = toFilePath destDir
liftIO $ createDirectoryIfMissing True dest
liftIO $ withBinaryFile fp ReadMode $ \h -> do
-- Avoid using L.readFile, which is more likely to leak
-- resources
lbs <- L.hGetContents h
let entries = fmap (either wrap wrap)
$ Tar.checkTarbomb identStr
$ Tar.read $ decompress lbs
wrap :: Exception e => e -> FetchException
wrap = Couldn'tReadPackageTarball fp . toException
identStr = packageIdentifierString ident
getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)
getPerms e = (dest FP. Tar.fromTarPath (Tar.entryTarPath e),
Tar.entryPermissions e)
filePerms :: [(FilePath, Tar.Permissions)]
filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))
[] (const []) entries
Tar.unpack dest entries
-- Reset file permissions as they were in the tarball
mapM_ (\(fp', perm) -> setFileMode
(FP.dropTrailingPathSeparator fp')
perm) filePerms
case mdistDir of
Nothing -> return ()
-- See: https://github.com/fpco/stack/issues/157
Just distDir -> do
let inner = dest FP. identStr
oldDist = inner FP. "dist"
newDist = inner FP. toFilePath distDir
exists <- doesDirectoryExist oldDist
when exists $ do
-- Previously used takeDirectory, but that got confused
-- by trailing slashes, see:
-- https://github.com/commercialhaskell/stack/issues/216
--
-- Instead, use Path which is a bit more resilient
createTree . parent =<< parseAbsDir newDist
renameDirectory oldDist newDist
let cabalFP =
innerDest FP.
packageNameString (packageIdentifierName ident)
<.> "cabal"
S.writeFile cabalFP $ tfCabal toFetch
atomically $ modifyTVar outputVar $ Map.insert ident destDir
parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m)
=> Int
-> (a -> m ())
-> f a
-> m ()
parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs
parMapM_ cnt f xs0 = do
var <- liftIO (newTVarIO $ F.toList xs0)
-- See comment on similar line in Stack.Build
runInBase <- liftBaseWith $ \run -> return (void . run)
let worker = fix $ \loop -> join $ atomically $ do
xs <- readTVar var
case xs of
[] -> return $ return ()
x:xs' -> do
writeTVar var xs'
return $ do
runInBase $ f x
loop
workers 1 = Concurrently worker
workers i = Concurrently worker *> workers (i - 1)
liftIO $ runConcurrently $ workers cnt
damerauLevenshtein :: String -> String -> Int
damerauLevenshtein = ED.restrictedDamerauLevenshteinDistance ED.defaultEditCosts
orSeparated :: NonEmpty String -> String
orSeparated xs
| NE.length xs == 1 = NE.head xs
| NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs
| otherwise = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
commaSeparated :: NonEmpty String -> String
commaSeparated = F.fold . NE.intersperse ", "
stack-0.1.10.0/src/Stack/Exec.hs 0000644 0000000 0000000 00000003613 12630352213 014276 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Execute commands within the properly configured Stack
-- environment.
module Stack.Exec where
import Control.Monad.Reader
import Control.Monad.Logger
import Control.Monad.Catch hiding (try)
import Control.Monad.Trans.Control (MonadBaseControl)
import Stack.Types
import System.Process.Log
import System.Process.Read (EnvOverride)
#ifdef WINDOWS
import Control.Exception.Lifted
import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import System.Exit
import System.Process.Run (callProcess, Cmd(..))
#else
import System.Process.Read (envHelper, preProcess)
import System.Posix.Process (executeFile)
#endif
-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH
defaultEnvSettings :: EnvSettings
defaultEnvSettings = EnvSettings
{ esIncludeLocals = True
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
}
-- | Environment settings which do not embellish the environment
plainEnvSettings :: EnvSettings
plainEnvSettings = EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
}
-- | Execute a process within the Stack configured environment.
exec :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
=> EnvOverride -> String -> [String] -> m b
exec menv cmd0 args = do
$logProcessRun cmd0 args
#ifdef WINDOWS
e <- try (callProcess (Cmd Nothing cmd0 menv args))
liftIO $ case e of
Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
Right () -> exitSuccess
#else
cmd <- preProcess Nothing menv cmd0
liftIO $ executeFile cmd True args (envHelper menv)
#endif
stack-0.1.10.0/src/Stack/FileWatch.hs 0000644 0000000 0000000 00000012527 12623647202 015273 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Stack.FileWatch
( fileWatch
, fileWatchPoll
, printExceptionStderr
) where
import Blaze.ByteString.Builder (toLazyByteString, copyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromShow)
import Control.Concurrent.Async (race_)
import Control.Concurrent.STM
import Control.Exception (Exception, fromException)
import Control.Exception.Enclosed (tryAny)
import Control.Monad (forever, unless, when)
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Traversable (forM)
import GHC.IO.Handle (hIsTerminalDevice)
import Path
import System.Console.ANSI
import System.Exit
import System.FSNotify
import System.IO (stdout, stderr)
-- | Print an exception to stderr
printExceptionStderr :: Exception e => e -> IO ()
printExceptionStderr e =
L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"
fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ())
-> IO ()
fileWatch = fileWatchConf defaultConfig
fileWatchPoll :: ((Set (Path Abs File) -> IO ()) -> IO ())
-> IO ()
fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }
-- | Run an action, watching for file changes
--
-- The action provided takes a callback that is used to set the files to be
-- watched. When any of those files are changed, we rerun the action again.
fileWatchConf :: WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> IO ())
-> IO ()
fileWatchConf cfg inner = withManagerConf cfg $ \manager -> do
allFiles <- newTVarIO Set.empty
dirtyVar <- newTVarIO True
watchVar <- newTVarIO Map.empty
let onChange event = atomically $ do
files <- readTVar allFiles
when (eventPath event `Set.member` files) (writeTVar dirtyVar True)
setWatched :: Set (Path Abs File) -> IO ()
setWatched files = do
atomically $ writeTVar allFiles $ Set.map toFilePath files
watch0 <- readTVarIO watchVar
let actions = Map.mergeWithKey
keepListening
stopListening
startListening
watch0
newDirs
watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
mv <- mmv
return $
case mv of
Nothing -> Map.empty
Just v -> Map.singleton k v
atomically $ writeTVar watchVar $ Map.unions watch1
where
newDirs = Map.fromList $ map (, ())
$ Set.toList
$ Set.map parent files
keepListening _dir listen () = Just $ return $ Just listen
stopListening = Map.map $ \f -> do
() <- f
return Nothing
startListening = Map.mapWithKey $ \dir () -> do
let dir' = fromString $ toFilePath dir
listen <- watchDir manager dir' (const True) onChange
return $ Just listen
let watchInput = do
line <- getLine
unless (line == "quit") $ do
case line of
"help" -> do
putStrLn ""
putStrLn "help: display this help"
putStrLn "quit: exit"
putStrLn "build: force a rebuild"
putStrLn "watched: display watched files"
"build" -> atomically $ writeTVar dirtyVar True
"watched" -> do
watch <- readTVarIO allFiles
mapM_ putStrLn (Set.toList watch)
"" -> atomically $ writeTVar dirtyVar True
_ -> putStrLn $ concat
[ "Unknown command: "
, show line
, ". Try 'help'"
]
watchInput
race_ watchInput $ forever $ do
atomically $ do
dirty <- readTVar dirtyVar
check dirty
eres <- tryAny $ inner setWatched
-- Clear dirtiness flag after the build to avoid an infinite
-- loop caused by the build itself triggering dirtiness. This
-- could be viewed as a bug, since files changed during the
-- build will not trigger an extra rebuild, but overall seems
-- like better behavior. See
-- https://github.com/commercialhaskell/stack/issues/822
atomically $ writeTVar dirtyVar False
let withColor color action = do
outputIsTerminal <- hIsTerminalDevice stdout
if outputIsTerminal
then do
setSGR [SetColor Foreground Dull color]
action
setSGR [Reset]
else action
case eres of
Left e -> do
let color = case fromException e of
Just ExitSuccess -> Green
_ -> Red
withColor color $ printExceptionStderr e
_ -> withColor Green $
putStrLn "Success! Waiting for next file change."
putStrLn "Type help for available commands. Press enter to force a rebuild."
stack-0.1.10.0/src/Stack/GhcPkg.hs 0000644 0000000 0000000 00000015016 12623647202 014564 0 ustar 00 0000000 0000000 -- FIXME See how much of this module can be deleted.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-unused-do-bind #-}
-- | Functions for the GHC package database.
module Stack.GhcPkg
(getGlobalDB
,EnvOverride
,envHelper
,createDatabase
,unregisterGhcPkgId
,getCabalPkgVer
,ghcPkgExeName
,mkGhcPackagePath)
where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import Data.Either
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO (dirExists, createTree)
import Prelude hiding (FilePath)
import Stack.Constants
import Stack.Types
import System.Directory (canonicalizePath)
import System.FilePath (searchPathSeparator)
import System.Process.Read
-- | Get the global package database
getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> WhichCompiler -> m (Path Abs Dir)
getGlobalDB menv wc = do
-- This seems like a strange way to get the global package database
-- location, but I don't know of a better one
bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO (canonicalizePath fp) >>= parseAbsDir
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
-- | Run the ghc-pkg executable
ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> [String]
-> m (Either ReadProcessException S8.ByteString)
ghcPkg menv wc pkgDbs args = do
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase menv wc) pkgDbs
go
Right _ -> return eres
where
go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args'
args' = packageDbFlags pkgDbs ++ args
-- | Create a package database in the given directory, if it doesn't exist.
createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> WhichCompiler -> Path Abs Dir -> m ()
createDatabase menv wc db = do
exists <- dirExists db
unless exists $ do
-- Creating the parent doesn't seem necessary, as ghc-pkg
-- seems to be sufficiently smart. But I don't feel like
-- finding out it isn't the hard way
createTree (parent db)
_ <- tryProcessStdout Nothing menv (ghcPkgExeName wc) ["init", toFilePath db]
return ()
-- | Get the name to use for "ghc-pkg", given the compiler version.
ghcPkgExeName :: WhichCompiler -> String
ghcPkgExeName Ghc = "ghc-pkg"
ghcPkgExeName Ghcjs = "ghcjs-pkg"
-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
-- | Get the value of a field of the package.
findGhcPkgField
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir] -- ^ package databases
-> String -- ^ package identifier, or GhcPkgId
-> Text
-> m (Maybe Text)
findGhcPkgField menv wc pkgDbs name field = do
result <-
ghcPkg
menv
wc
pkgDbs
["field", "--simple-output", name, T.unpack field]
return $
case result of
Left{} -> Nothing
Right lbs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs
where
stripCR t = fromMaybe t (T.stripSuffix "\r" t)
-- | Get the version of the package
findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir] -- ^ package databases
-> PackageName
-> m (Maybe Version)
findGhcPkgVersion menv wc pkgDbs name = do
mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version"
case mv of
Just !v -> return (parseVersion (T.encodeUtf8 v))
_ -> return Nothing
unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> CompilerVersion
-> Path Abs Dir -- ^ package database
-> GhcPkgId
-> PackageIdentifier
-> m ()
unregisterGhcPkgId menv wc cv pkgDb gid ident = do
eres <- ghcPkg menv wc [pkgDb] args
case eres of
Left e -> $logWarn $ T.pack $ show e
Right _ -> return ()
where
-- TODO ideally we'd tell ghc-pkg a GhcPkgId instead
args = "unregister" : "--user" : "--force" :
(case cv of
GhcVersion v | v < $(mkVersion "7.9") ->
[packageIdentifierString ident]
_ -> ["--ipid", ghcPkgIdString gid])
-- | Get the version of Cabal from the global package database.
getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride -> WhichCompiler -> m Version
getCabalPkgVer menv wc =
findGhcPkgVersion
menv
wc
[] -- global DB
cabalPackageName >>=
maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return
-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps extras globaldb =
T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSep localdb | locals]
, [toFilePathNoTrailingSep deps]
, [toFilePathNoTrailingSep db | db <- reverse extras]
, [toFilePathNoTrailingSep globaldb]
]
stack-0.1.10.0/src/Stack/Init.hs 0000644 0000000 0000000 00000035224 12630352213 014320 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Init
( findCabalFiles
, initProject
, InitOpts (..)
, SnapPref (..)
, Method (..)
, makeConcreteResolver
, tryDeprecatedPath
, getImplicitGlobalProjectDir
) where
import Control.Exception (assert)
import Control.Exception.Enclosed (catchAny, handleIO)
import Control.Monad (liftM, when, zipWithM_)
import Control.Monad.Catch (MonadMask, MonadThrow, throwM)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap as IntMap
import qualified Data.Foldable as F
import Data.List (isSuffixOf,sortBy)
import Data.List.Extra (nubOrd)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.Find
import Path.IO
import Stack.BuildPlan
import Stack.Constants
import Stack.Package
import Stack.Solver
import Stack.Types
import System.Directory (getDirectoryContents)
findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]
findCabalFiles recurse dir =
liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir))
where
isCabal path = ".cabal" `isSuffixOf` toFilePath path
isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs
-- | Special directories that we don't want to traverse for .cabal files
ignoredDirs :: Set FilePath
ignoredDirs = Set.fromList
[ ".git"
, "dist"
, ".stack-work"
]
-- | Generate stack.yaml
initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
=> Path Abs Dir
-> InitOpts
-> m ()
initProject currDir initOpts = do
let dest = currDir stackDotYaml
dest' = toFilePath dest
exists <- fileExists dest
when (not (forceOverwrite initOpts) && exists) $
error ("Refusing to overwrite existing stack.yaml, " <>
"please delete before running stack init " <>
"or if you are sure use \"--force\"")
cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir
$logInfo $ "Writing default config file to: " <> T.pack dest'
$logInfo $ "Basing on cabal files:"
mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps
$logInfo ""
when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"
(warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)
zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings
(r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts
let p = Project
{ projectPackages = pkgs
, projectExtraDeps = extraDeps
, projectFlags = flags
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
}
pkgs = map toPkg cabalfps
toPkg fp = PackageEntry
{ peValidWanted = Nothing
, peExtraDepMaybe = Nothing
, peLocation = PLFilePath $
case stripDir currDir $ parent fp of
Nothing
| currDir == parent fp -> "."
| otherwise -> assert False $ toFilePath $ parent fp
Just rel -> toFilePath rel
, peSubdirs = []
}
$logInfo $ "Selected resolver: " <> resolverName r
liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p
$logInfo $ "Wrote project config to: " <> T.pack dest'
-- | Render a stack.yaml file with comments, see:
-- https://github.com/commercialhaskell/stack/issues/226
renderStackYaml :: Project -> B.Builder
renderStackYaml p =
case Yaml.toJSON p of
Yaml.Object o -> renderObject o
_ -> assert False $ B.byteString $ Yaml.encode p
where
renderObject o =
B.byteString "# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n\n" <>
F.foldMap (goComment o) comments <>
goOthers (o `HM.difference` HM.fromList comments) <>
B.byteString
"# Control whether we use the GHC we find on the path\n\
\# system-ghc: true\n\n\
\# Require a specific version of stack, using version ranges\n\
\# require-stack-version: -any # Default\n\
\# require-stack-version: >= 0.1.10.0\n\n\
\# Override the architecture used by stack, especially useful on Windows\n\
\# arch: i386\n\
\# arch: x86_64\n\n\
\# Extra directories used by stack for building\n\
\# extra-include-dirs: [/path/to/dir]\n\
\# extra-lib-dirs: [/path/to/dir]\n"
comments =
[ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")
, ("packages", "Local packages, usually specified by relative directory name")
, ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)")
, ("flags", "Override default flag values for local packages and extra-deps")
, ("extra-package-dbs", "Extra package databases containing global packages")
]
goComment o (name, comment) =
case HM.lookup name o of
Nothing -> assert False mempty
Just v ->
B.byteString "# " <>
B.byteString comment <>
B.byteString "\n" <>
B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>
B.byteString "\n"
goOthers o
| HM.null o = mempty
| otherwise = assert False $ B.byteString $ Yaml.encode o
getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> m (Maybe Snapshots)
getSnapshots' =
liftM Just getSnapshots `catchAny` \e -> do
$logError $
"Unable to download snapshot list, and therefore could " <>
"not generate a stack.yaml file automatically"
$logError $
"This sometimes happens due to missing Certificate Authorities " <>
"on your system. For more information, see:"
$logError ""
$logError " https://github.com/commercialhaskell/stack/issues/234"
$logError ""
$logError "You can try again, or create your stack.yaml file by hand. See:"
$logError ""
$logError " https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md"
$logError ""
$logError $ "Exception was: " <> T.pack (show e)
return Nothing
-- | Get the default resolver value
getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
=> [Path Abs File] -- ^ cabal files
-> [C.GenericPackageDescription] -- ^ cabal descriptions
-> InitOpts
-> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)
getDefaultResolver cabalfps gpds initOpts =
case ioMethod initOpts of
MethodSnapshot snapPref -> do
msnapshots <- getSnapshots'
names <-
case msnapshots of
Nothing -> return []
Just snapshots -> getRecommendedSnapshots snapshots snapPref
mpair <- findBuildPlan gpds names
case mpair of
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> throwM $ NoMatchingSnapshot names
MethodResolver aresolver -> do
resolver <- makeConcreteResolver aresolver
mpair <-
case resolver of
ResolverSnapshot name -> findBuildPlan gpds [name]
ResolverCompiler _ -> return Nothing
ResolverCustom _ _ -> return Nothing
case mpair of
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> return (resolver, Map.empty, Map.empty)
MethodSolver -> do
(compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty Map.empty []
return
( ResolverCompiler compilerVersion
, Map.filter (not . Map.null) $ fmap snd extraDeps
, fmap fst extraDeps
)
getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
=> Snapshots
-> SnapPref
-> m [SnapName]
getRecommendedSnapshots snapshots pref = do
-- Get the most recent LTS and Nightly in the snapshots directory and
-- prefer them over anything else, since odds are high that something
-- already exists for them.
existing <-
liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $
snapshotsDir >>=
liftIO . handleIO (const $ return [])
. getDirectoryContents . toFilePath
let isLTS LTS{} = True
isLTS Nightly{} = False
isNightly Nightly{} = True
isNightly LTS{} = False
names = nubOrd $ concat
[ take 2 $ filter isLTS existing
, take 2 $ filter isNightly existing
, map (uncurry LTS)
(take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
, [Nightly $ snapshotsNightly snapshots]
]
namesLTS = filter isLTS names
namesNightly = filter isNightly names
case pref of
PrefNone -> return names
PrefLTS -> return $ namesLTS ++ namesNightly
PrefNightly -> return $ namesNightly ++ namesLTS
data InitOpts = InitOpts
{ ioMethod :: !Method
-- ^ Preferred snapshots
, forceOverwrite :: Bool
-- ^ Overwrite existing files
, includeSubDirs :: Bool
-- ^ If True, include all .cabal files found in any sub directories
}
data SnapPref = PrefNone | PrefLTS | PrefNightly
-- | Method of initializing
data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver | MethodSolver
-- | Turn an 'AbstractResolver' into a 'Resolver'.
makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m)
=> AbstractResolver
-> m Resolver
makeConcreteResolver (ARResolver r) = return r
makeConcreteResolver ar = do
snapshots <- getSnapshots
r <-
case ar of
ARResolver r -> assert False $ return r
ARGlobal -> do
config <- asks getConfig
implicitGlobalDir <- getImplicitGlobalProjectDir config
let fp = implicitGlobalDir stackDotYaml
(ProjectAndConfigMonoid project _, _warnings) <-
liftIO (Yaml.decodeFileEither $ toFilePath fp)
>>= either throwM return
return $ projectResolver project
ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots
ARLatestLTSMajor x ->
case IntMap.lookup x $ snapshotsLts snapshots of
Nothing -> error $ "No LTS release found with major version " ++ show x
Just y -> return $ ResolverSnapshot $ LTS x y
ARLatestLTS
| IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found"
| otherwise ->
let (x, y) = IntMap.findMax $ snapshotsLts snapshots
in return $ ResolverSnapshot $ LTS x y
$logInfo $ "Selected resolver: " <> resolverName r
return r
-- | Get the location of the implicit global project directory.
-- If the directory already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getImplicitGlobalProjectDir
:: (MonadIO m, MonadLogger m)
=> Config -> m (Path Abs Dir)
getImplicitGlobalProjectDir config =
--TEST no warning printed
liftM fst $ tryDeprecatedPath
Nothing
dirExists
(implicitGlobalProjectDir stackRoot)
(implicitGlobalProjectDirDeprecated stackRoot)
where
stackRoot = configStackRoot config
-- | If deprecated path exists, use it and print a warning.
-- Otherwise, return the new path.
tryDeprecatedPath
:: (MonadIO m, MonadLogger m)
=> Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)
-> (Path Abs a -> m Bool) -- ^ Test for existence
-> Path Abs a -- ^ New path
-> Path Abs a -- ^ Deprecated path
-> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)
tryDeprecatedPath mWarningDesc exists new old = do
newExists <- exists new
if newExists
then return (new, True)
else do
oldExists <- exists old
if oldExists
then do
case mWarningDesc of
Nothing -> return ()
Just desc ->
$logWarn $ T.concat
[ "Warning: Location of ", desc, " at '"
, T.pack (toFilePath old)
, "' is deprecated; rename it to '"
, T.pack (toFilePath new)
, "' instead" ]
return (old, True)
else return (new, False)
stack-0.1.10.0/src/Stack/New.hs 0000644 0000000 0000000 00000031203 12630352213 014137 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Create new a new project directory populated with a basic working
-- project.
module Stack.New
( new
, NewOpts(..)
, defaultTemplateName
, templateNameArgument
, getTemplates
, TemplateName
, listTemplates)
where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Writer.Strict
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Conduit
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe.Extra (mapMaybeM)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import Data.Typeable
import Network.HTTP.Client.Conduit hiding (path)
import Network.HTTP.Download
import Network.HTTP.Types.Status
import Path
import Path.IO
import Stack.Constants
import Stack.Types
import Stack.Types.TemplateName
import System.Process.Run
import Text.Hastache
import Text.Hastache.Context
import Text.ProjectTemplate
--------------------------------------------------------------------------------
-- Main project creation
-- | Options for creating a new project.
data NewOpts = NewOpts
{ newOptsProjectName :: PackageName
-- ^ Name of the project to create.
, newOptsCreateBare :: Bool
-- ^ Whether to create the project without a directory.
, newOptsTemplate :: TemplateName
-- ^ Name of the template to use.
, newOptsNonceParams :: Map Text Text
-- ^ Nonce parameters specified just for this invocation.
}
-- | Create a new project with the given options.
new
:: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r)
=> NewOpts -> m (Path Abs Dir)
new opts = do
pwd <- getWorkingDir
absDir <- if bare then return pwd
else do relDir <- parseRelDir (packageNameString project)
liftM (pwd ) (return relDir)
exists <- dirExists absDir
if exists && not bare
then throwM (AlreadyExists absDir)
else do
logUsing absDir
templateText <- loadTemplate template
files <-
applyTemplate
project
template
(newOptsNonceParams opts)
absDir
templateText
writeTemplateFiles files
runTemplateInits absDir
return absDir
where
template = newOptsTemplate opts
project = newOptsProjectName opts
bare = newOptsCreateBare opts
logUsing absDir =
$logInfo
("Downloading template \"" <> templateName template <>
"\" to create project \"" <>
packageNameText project <>
"\" in " <>
if bare then "the current directory"
else T.pack (toFilePath (dirname absDir)) <>
" ...")
-- | Download and read in a template's text content.
loadTemplate
:: forall m r.
(HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m)
=> TemplateName -> m Text
loadTemplate name =
case templatePath name of
Left absFile -> loadLocalFile absFile
Right relFile ->
catch
(loadLocalFile relFile)
(\(_ :: NewException) ->
downloadTemplate relFile)
where
loadLocalFile :: Path b File -> m Text
loadLocalFile path = do
exists <- fileExists path
if exists
then liftIO (T.readFile (toFilePath path))
else throwM (FailedToLoadTemplate name (toFilePath path))
downloadTemplate :: Path Rel File -> m Text
downloadTemplate rel = do
config <- asks getConfig
req <- parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel)
let path :: Path Abs File
path = templatesDir config rel
_ <-
catch
(redownload req path)
(throwM . FailedToDownloadTemplate name)
exists <- fileExists path
if exists
then liftIO (T.readFile (toFilePath path))
else throwM (FailedToLoadTemplate name (toFilePath path))
-- | Apply and unpack a template into a directory.
applyTemplate
:: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m)
=> PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> m (Map (Path Abs File) LB.ByteString)
applyTemplate project template nonceParams dir templateText = do
config <- asks getConfig
let context = M.union (M.union nonceParams name) configParams
where
name = M.fromList [("name", packageNameText project)]
configParams = configTemplateParams config
(applied,missingKeys) <-
runWriterT
(hastacheStr
defaultConfig
templateText
(mkStrContextM (contextFunction context)))
unless (S.null missingKeys)
($logInfo (T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config)))))
files :: Map FilePath LB.ByteString <-
execWriterT $
yield (T.encodeUtf8 (LT.toStrict applied)) $$
unpackTemplate receiveMem id
liftM
M.fromList
(mapM
(\(fp,bytes) ->
do path <- parseRelFile fp
return (dir path, bytes))
(M.toList files))
where
-- | Does a lookup in the context and returns a moustache value,
-- on the side, writes out a set of keys that were requested but
-- not found.
contextFunction
:: Monad m
=> Map Text Text
-> String
-> WriterT (Set String) m (MuType (WriterT (Set String) m))
contextFunction context key =
case M.lookup (T.pack key) context of
Nothing -> do
tell (S.singleton key)
return MuNothing
Just value -> return (MuVariable value)
-- | Write files to the new project directory.
writeTemplateFiles
:: MonadIO m
=> Map (Path Abs File) LB.ByteString -> m ()
writeTemplateFiles files =
forM_
(M.toList files)
(\(fp,bytes) ->
do createTree (parent fp)
liftIO (LB.writeFile (toFilePath fp) bytes))
-- | Run any initialization functions, such as Git.
runTemplateInits
:: (MonadIO m, MonadReader r m, HasConfig r, MonadLogger m, MonadCatch m)
=> Path Abs Dir -> m ()
runTemplateInits dir = do
menv <- getMinimalEnvOverride
config <- asks getConfig
case configScmInit config of
Nothing -> return ()
Just Git ->
catch (callProcess $ Cmd (Just dir) "git" menv ["init"])
(\(_ :: ProcessExitedUnsuccessfully) ->
$logInfo "git init failed to run, ignoring ...")
--------------------------------------------------------------------------------
-- Getting templates list
listTemplates
:: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m, MonadLogger m)
=> m ()
listTemplates = do
templates <- getTemplates
mapM_ ($logInfo . templateName) (S.toList templates)
-- | Get the set of templates.
getTemplates
:: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m)
=> m (Set TemplateName)
getTemplates = do
req <- liftM addHeaders (parseUrl defaultTemplatesList)
resp <- catch (httpLbs req) (throwM . FailedToDownloadTemplates)
case statusCode (responseStatus resp) of
200 ->
case eitherDecode (responseBody resp) >>=
parseEither parseTemplateSet of
Left err -> throwM (BadTemplatesJSON err (responseBody resp))
Right value -> return value
code -> throwM (BadTemplatesResponse code)
where
addHeaders req =
req
{ requestHeaders = [ ("User-Agent", "The Haskell Stack")
, ("Accept", "application/vnd.github.v3+json")] <>
requestHeaders req
}
-- | Parser the set of templates from the JSON.
parseTemplateSet :: Value -> Parser (Set TemplateName)
parseTemplateSet a = do
xs <- parseJSON a
fmap S.fromList (mapMaybeM parseTemplate xs)
where
parseTemplate v = do
o <- parseJSON v
name <- o .: "name"
if ".hsfiles" `isSuffixOf` name
then case parseTemplateNameFromString name of
Left{} ->
fail ("Unable to parse template name from " <> name)
Right template -> return (Just template)
else return Nothing
--------------------------------------------------------------------------------
-- Defaults
-- | The default template name you can use if you don't have one.
defaultTemplateName :: TemplateName
defaultTemplateName = $(mkTemplateName "new-template")
-- | Default web root URL to download from.
defaultTemplateUrl :: String
defaultTemplateUrl =
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master"
-- | Default web URL to list the repo contents.
defaultTemplatesList :: String
defaultTemplatesList =
"https://api.github.com/repos/commercialhaskell/stack-templates/contents/"
--------------------------------------------------------------------------------
-- Exceptions
-- | Exception that might occur when making a new project.
data NewException
= FailedToLoadTemplate !TemplateName
!FilePath
| FailedToDownloadTemplate !TemplateName
!DownloadException
| FailedToDownloadTemplates !HttpException
| BadTemplatesResponse !Int
| BadTemplatesJSON !String !LB.ByteString
| AlreadyExists !(Path Abs Dir)
| MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)
deriving (Typeable)
instance Exception NewException
instance Show NewException where
show (FailedToLoadTemplate name path) =
"Failed to load download template " <> T.unpack (templateName name) <>
" from " <>
path
show (FailedToDownloadTemplate name (RedownloadFailed _ _ resp)) =
case statusCode (responseStatus resp) of
404 ->
"That template doesn't exist. Run `stack templates' to see a list of available templates."
code ->
"Failed to download template " <> T.unpack (templateName name) <>
": unknown reason, status code was: " <>
show code
show (FailedToDownloadTemplate name _) =
"Failed to download template " <> T.unpack (templateName name) <>
", reason unknown."
show (AlreadyExists path) =
"Directory " <> toFilePath path <> " already exists. Aborting."
show (FailedToDownloadTemplates ex) =
"Failed to download templates. The HTTP error was: " <> show ex
show (BadTemplatesResponse code) =
"Unexpected status code while retrieving templates list: " <> show code
show (BadTemplatesJSON err bytes) =
"Github returned some JSON that couldn't be parsed: " <> err <> "\n\n" <>
L8.unpack bytes
show (MissingParameters name template missingKeys userConfigPath) =
intercalate
"\n"
[ "The following parameters were needed by the template but not provided: " <>
intercalate ", " (S.toList missingKeys)
, "You can provide them in " <>
toFilePath userConfigPath <>
", like this:"
, "templates:"
, " params:"
, intercalate
"\n"
(map
(\key ->
" " <> key <> ": value")
(S.toList missingKeys))
, "Or you can pass each one as parameters like this:"
, "stack new " <> packageNameString name <> " " <>
T.unpack (templateName template) <>
" " <>
unwords
(map
(\key ->
"-p \"" <> key <> ":value\"")
(S.toList missingKeys))]
stack-0.1.10.0/src/Stack/Nix.hs 0000644 0000000 0000000 00000012072 12630352213 014147 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
-- | Run commands in a nix-shell
module Stack.Nix
(reexecWithOptionalShell
,nixCmdName
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (try,MonadCatch)
import Control.Monad.IO.Class (MonadIO,liftIO)
import Control.Monad.Logger (MonadLogger,logDebug)
import Control.Monad.Reader (MonadReader,asks)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Char (toUpper)
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid
import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import qualified Data.Text as T
import Data.Version (showVersion)
import Network.HTTP.Client.Conduit (HasHttpManager)
import qualified Paths_stack as Meta
import Prelude -- Fix redundant import warnings
import Stack.Constants (stackProgName)
import Stack.Docker (reExecArgName)
import Stack.Exec (exec)
import System.Process.Read (getEnvOverride)
import Stack.Types
import Stack.Types.Internal
import System.Environment (lookupEnv,getArgs,getExecutablePath)
import System.Exit (exitSuccess, exitWith)
-- | If Nix is enabled, re-runs the currently running OS command in a Nix container.
-- Otherwise, runs the inner action.
reexecWithOptionalShell
:: M env m
=> IO ()
-> m ()
reexecWithOptionalShell inner =
do config <- asks getConfig
inShell <- getInShell
isReExec <- asks getReExec
if nixEnable (configNix config) && not inShell && not isReExec
then runShellAndExit getCmdArgs
else liftIO (inner >> exitSuccess)
where
getCmdArgs = do
args <-
fmap
(("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :)
(liftIO getArgs)
exePath <- liftIO getExecutablePath
return (exePath, args)
runShellAndExit :: M env m
=> m (String, [String])
-> m ()
runShellAndExit getCmdArgs = do
config <- asks getConfig
envOverride <- getEnvOverride (configPlatform config)
(cmnd,args) <- getCmdArgs
let mshellFile = nixInitFile (configNix config)
pkgsInConfig = nixPackages (configNix config)
nixopts = case mshellFile of
Just filePath -> [filePath]
Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat
[["with (import {});"
,"runCommand \"myEnv\" {"
,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgsInConfig,["];"
,T.pack inShellEnvVar,"=1 ;"
,"STACK_IN_NIX_EXTRA_ARGS=''"]
, (map (\p -> T.concat
["--extra-lib-dirs=${",p,"}/lib"
," --extra-include-dirs=${",p,"}/include "])
pkgsInConfig), ["'' ;"
,"} \"\""]]]
-- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.
fullArgs = concat [ -- ["--pure"],
map T.unpack (nixShellOptions (configNix config))
,nixopts
,["--command", intercalate " " (map escape (cmnd:args))
++ " $STACK_IN_NIX_EXTRA_ARGS"]
]
$logDebug $
"Using a nix-shell environment " <> (case mshellFile of
Just filePath -> "from file: " <> (T.pack filePath)
Nothing -> "with nix packages: " <> (T.intercalate ", " pkgsInConfig))
e <- try (exec envOverride "nix-shell" fullArgs)
case e of
Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
Right () -> liftIO exitSuccess
-- | Shell-escape quotes inside the string and enclose it in quotes.
escape :: String -> String
escape str = "'" ++ foldr (\c -> if c == '\'' then
("'\"'\"'"++)
else (c:)) "" str
++ "'"
-- | 'True' if we are currently running inside a Nix.
getInShell :: (MonadIO m) => m Bool
getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar)
-- | Environment variable used to indicate stack is running in container.
-- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions,
-- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty.
inShellEnvVar :: String
inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"]
-- | Command-line argument for "nix"
nixCmdName :: String
nixCmdName = "nix"
type M env m =
(MonadIO m
,MonadReader env m
,MonadLogger m
,MonadBaseControl IO m
,MonadCatch m
,HasConfig env
,HasTerminal env
,HasReExec env
,HasHttpManager env
)
stack-0.1.10.0/src/Stack/Options.hs 0000644 0000000 0000000 00000075203 12630352213 015051 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings,RecordWildCards #-}
module Stack.Options
(Command(..)
,benchOptsParser
,buildOptsParser
,cleanOptsParser
,configCmdSetParser
,configOptsParser
,dockerOptsParser
,dockerCleanupOptsParser
,dotOptsParser
,execOptsParser
,evalOptsParser
,globalOptsParser
,initOptsParser
,newOptsParser
,nixOptsParser
,logLevelOptsParser
,ghciOptsParser
,solverOptsParser
,testOptsParser
,hpcReportOptsParser
,pvpBoundsOption
,globalOptsFromMonoid
) where
import Control.Monad.Logger (LogLevel(..))
import Data.Char (isSpace, toLower)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Distribution.Version (anyVersion)
import Options.Applicative
import Options.Applicative.Args
import Options.Applicative.Builder.Extra
import Options.Applicative.Types (fromM, oneM, readerAsk)
import Stack.Clean (CleanOpts(..))
import Stack.Config (packagesParser)
import Stack.ConfigCmd
import Stack.Constants (stackProgName)
import Stack.Coverage (HpcReportOpts(..))
import Stack.Docker
import qualified Stack.Docker as Docker
import Stack.Dot
import Stack.Ghci (GhciOpts(..))
import Stack.Init
import Stack.New
import Stack.Nix
import Stack.Types
import Stack.Types.TemplateName
-- | Command sum type for conditional arguments.
data Command
= Build
| Test
| Haddock
| Bench
| Install
deriving (Eq)
-- | Parser for bench arguments.
benchOptsParser :: Parser BenchmarkOpts
benchOptsParser = BenchmarkOpts
<$> optional (strOption (long "benchmark-arguments" <>
metavar "BENCH_ARGS" <>
help ("Forward BENCH_ARGS to the benchmark suite. " <>
"Supports templates from `cabal bench`")))
<*> switch (long "no-run-benchmarks" <>
help "Disable running of benchmarks. (Benchmarks will still be built.)")
-- | Parser for build arguments.
buildOptsParser :: Command
-> Parser BuildOpts
buildOptsParser cmd =
BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>
haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*>
flags <*> copyBins <*> preFetch <*> buildSubset <*>
fileWatch' <*> keepGoing <*> forceDirty <*> tests <*>
testOptsParser <*> benches <*> benchOptsParser <*>
many exec <*> onlyConfigure <*> reconfigure <*> cabalVerbose
where target =
many (textArgument
(metavar "TARGET" <>
help "If none specified, use all packages"))
libProfiling =
boolFlags False
"library-profiling"
"library profiling for TARGETs and all its dependencies"
idm
exeProfiling =
boolFlags False
"executable-profiling"
"executable profiling for TARGETs and all its dependencies"
idm
haddock =
boolFlags (cmd == Haddock)
"haddock"
"generating Haddocks the package(s) in this directory/configuration"
idm
haddockDeps =
maybeBoolFlags
"haddock-deps"
"building Haddocks for dependencies"
idm
copyBins = boolFlags (cmd == Install)
"copy-bins"
"copying binaries to the local-bin-path (see 'stack path')"
idm
dryRun = switch (long "dry-run" <>
help "Don't build anything, just prepare to")
ghcOpts = (\x y z -> concat [x, y, z])
<$> flag [] ["-Wall", "-Werror"]
( long "pedantic"
<> help "Turn on -Wall and -Werror"
)
<*> flag [] ["-O0"]
( long "fast"
<> help "Turn off optimizations (-O0)"
)
<*> many (textOption (long "ghc-options" <>
metavar "OPTION" <>
help "Additional options passed to GHC"))
flags = Map.unionsWith Map.union <$> many
(option readFlag
(long "flag" <>
metavar "PACKAGE:[-]FLAG" <>
help ("Override flags set in stack.yaml " <>
"(applies to local packages and extra-deps)")))
preFetch = switch
(long "prefetch" <>
help "Fetch packages necessary for the build immediately, useful with --dry-run")
buildSubset =
flag' BSOnlyDependencies
(long "dependencies-only" <>
help "A synonym for --only-dependencies")
<|> flag' BSOnlySnapshot
(long "only-snapshot" <>
help "Only build packages for the snapshot database, not the local database")
<|> flag' BSOnlyDependencies
(long "only-dependencies" <>
help "Only build packages that are dependencies of targets on the command line")
<|> pure BSAll
fileWatch' =
flag' FileWatch
(long "file-watch" <>
help "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file")
<|> flag' FileWatchPoll
(long "file-watch-poll" <>
help "Like --file-watch, but polling the filesystem instead of using events")
<|> pure NoFileWatch
keepGoing = maybeBoolFlags
"keep-going"
"continue running after a step fails (default: false for build, true for test/bench)"
idm
forceDirty = switch
(long "force-dirty" <>
help "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)")
tests = boolFlags (cmd == Test)
"test"
"testing the package(s) in this directory/configuration"
idm
benches = boolFlags (cmd == Bench)
"bench"
"benchmarking the package(s) in this directory/configuration"
idm
exec = cmdOption
( long "exec" <>
metavar "CMD [ARGS]" <>
help "Command and arguments to run after a successful build" )
onlyConfigure = switch
(long "only-configure" <>
help "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!")
reconfigure = switch
(long "reconfigure" <>
help "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files")
cabalVerbose = switch
(long "cabal-verbose" <>
help "Ask Cabal to be verbose in its output")
-- | Parser for package:[-]flag
readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))
readFlag = do
s <- readerAsk
case break (== ':') s of
(pn, ':':mflag) -> do
pn' <-
case parsePackageNameFromString pn of
Nothing
| pn == "*" -> return Nothing
| otherwise -> readerError $ "Invalid package name: " ++ pn
Just x -> return $ Just x
let (b, flagS) =
case mflag of
'-':x -> (False, x)
_ -> (True, mflag)
flagN <-
case parseFlagNameFromString flagS of
Nothing -> readerError $ "Invalid flag name: " ++ flagS
Just x -> return x
return $ Map.singleton pn' $ Map.singleton flagN b
_ -> readerError "Must have a colon"
-- | Command-line parser for the clean command.
cleanOptsParser :: Parser CleanOpts
cleanOptsParser = CleanOpts <$> packages
where
packages =
many
(packageNameArgument
(metavar "PACKAGE" <>
help "If none specified, clean all local packages"))
-- | Command-line arguments parser for configuration.
configOptsParser :: Bool -> Parser ConfigMonoid
configOptsParser hide0 =
(\workDir dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
{ configMonoidWorkDir = workDir
, configMonoidDockerOpts = dockerOpts
, configMonoidNixOpts = nixOpts
, configMonoidSystemGHC = systemGHC
, configMonoidInstallGHC = installGHC
, configMonoidSkipGHCCheck = skipGHCCheck
, configMonoidArch = arch
, configMonoidOS = os
, configMonoidGHCVariant = ghcVariant
, configMonoidJobs = jobs
, configMonoidExtraIncludeDirs = includes
, configMonoidExtraLibDirs = libs
, configMonoidSkipMsys = skipMsys
, configMonoidLocalBinPath = localBin
, configMonoidModifyCodePage = modifyCodePage
})
<$> optional (strOption
( long "work-dir"
<> metavar "WORK-DIR"
<> help "Override work directory (default: .stack-work)"
<> hide
))
<*> dockerOptsParser True
<*> nixOptsParser True
<*> maybeBoolFlags
"system-ghc"
"using the system installed GHC (on the PATH) if available and a matching version"
hide
<*> maybeBoolFlags
"install-ghc"
"downloading and installing GHC if necessary (can be done manually with stack setup)"
hide
<*> optional (strOption
( long "arch"
<> metavar "ARCH"
<> help "System architecture, e.g. i386, x86_64"
<> hide
))
<*> optional (strOption
( long "os"
<> metavar "OS"
<> help "Operating system, e.g. linux, windows"
<> hide
))
<*> optional (ghcVariantParser hide0)
<*> optional (option auto
( long "jobs"
<> short 'j'
<> metavar "JOBS"
<> help "Number of concurrent jobs to run"
<> hide
))
<*> fmap Set.fromList (many (textOption
( long "extra-include-dirs"
<> metavar "DIR"
<> help "Extra directories to check for C header files"
<> hide
)))
<*> fmap Set.fromList (many (textOption
( long "extra-lib-dirs"
<> metavar "DIR"
<> help "Extra directories to check for libraries"
<> hide
)))
<*> maybeBoolFlags
"skip-ghc-check"
"skipping the GHC version and architecture check"
hide
<*> maybeBoolFlags
"skip-msys"
"skipping the local MSYS installation (Windows only)"
hide
<*> optional (strOption
( long "local-bin-path"
<> metavar "DIR"
<> help "Install binaries to DIR"
<> hide
))
<*> maybeBoolFlags
"modify-code-page"
"setting the codepage to support UTF-8 (Windows only)"
hide
where hide = hideMods hide0
nixOptsParser :: Bool -> Parser NixOptsMonoid
nixOptsParser hide0 =
NixOptsMonoid
<$> pure False
<*> maybeBoolFlags nixCmdName
"using a Nix-shell"
hide
<*> pure []
<*> pure Nothing
<*> ((map T.pack . fromMaybe [])
<$> optional (argsOption (long "nix-shell-options" <>
metavar "OPTION" <>
help "Additional options passed to nix-shell" <>
hide)))
where
hide = hideMods hide0
-- | Options parser configuration for Docker.
dockerOptsParser :: Bool -> Parser DockerOptsMonoid
dockerOptsParser hide0 =
DockerOptsMonoid
<$> pure False
<*> maybeBoolFlags dockerCmdName
"using a Docker container"
hide
<*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>
hide <>
metavar "NAME" <>
help "Docker repository name") <|>
(Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>
hide <>
metavar "IMAGE" <>
help "Exact Docker image ID (overrides docker-repo)") <|>
pure Nothing)
<*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)
"registry requires login"
hide
<*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>
hide <>
metavar "USERNAME" <>
help "Docker registry username")
<*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>
hide <>
metavar "PASSWORD" <>
help "Docker registry password")
<*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)
"automatic pulling latest version of image"
hide
<*> maybeBoolFlags (dockerOptName dockerDetachArgName)
"running a detached Docker container"
hide
<*> maybeBoolFlags (dockerOptName dockerPersistArgName)
"not deleting container after it exits"
hide
<*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>
hide <>
metavar "NAME" <>
help "Docker container name")
<*> argsOption (long (dockerOptName dockerRunArgsArgName) <>
hide <>
value [] <>
metavar "'ARG1 [ARG2 ...]'" <>
help "Additional options to pass to 'docker run'")
<*> many (option auto (long (dockerOptName dockerMountArgName) <>
hide <>
metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>
help ("Mount volumes from host in container " ++
"(may specify multiple times)")))
<*> many (option str (long (dockerOptName dockerEnvArgName) <>
hide <>
metavar "NAME=VALUE" <>
help ("Set environment variable in container " ++
"(may specify multiple times)")))
<*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>
hide <>
metavar "PATH" <>
help "Location of image usage tracking database")
<*> optional (option str
(long(dockerOptName dockerStackExeArgName) <>
hide <>
metavar (intercalate "|"
[ dockerStackExeDownloadVal
, dockerStackExeHostVal
, dockerStackExeImageVal
, "PATH" ]) <>
help (concat [ "Location of "
, stackProgName
, " executable used in container" ])))
<*> maybeBoolFlags (dockerOptName dockerSetUserArgName)
"setting user in container to match host"
hide
<*> pure anyVersion
where
dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName
maybeStrOption = optional . option str
hide = hideMods hide0
-- | Parser for docker cleanup arguments.
dockerCleanupOptsParser :: Parser Docker.CleanupOpts
dockerCleanupOptsParser =
Docker.CleanupOpts <$>
(flag' Docker.CleanupInteractive
(short 'i' <>
long "interactive" <>
help "Show cleanup plan in editor and allow changes (default)") <|>
flag' Docker.CleanupImmediate
(short 'y' <>
long "immediate" <>
help "Immediately execute cleanup plan") <|>
flag' Docker.CleanupDryRun
(short 'n' <>
long "dry-run" <>
help "Display cleanup plan but do not execute") <|>
pure Docker.CleanupInteractive) <*>
opt (Just 14) "known-images" "LAST-USED" <*>
opt Nothing "unknown-images" "CREATED" <*>
opt (Just 0) "dangling-images" "CREATED" <*>
opt Nothing "stopped-containers" "CREATED" <*>
opt Nothing "running-containers" "CREATED"
where opt def' name mv =
fmap Just
(option auto
(long name <>
metavar (mv ++ "-DAYS-AGO") <>
help ("Remove " ++
toDescr name ++
" " ++
map toLower (toDescr mv) ++
" N days ago" ++
case def' of
Just n -> " (default " ++ show n ++ ")"
Nothing -> ""))) <|>
flag' Nothing
(long ("no-" ++ name) <>
help ("Do not remove " ++
toDescr name ++
case def' of
Just _ -> ""
Nothing -> " (default)")) <|>
pure def'
toDescr = map (\c -> if c == '-' then ' ' else c)
-- | Parser for arguments to `stack dot`
dotOptsParser :: Parser DotOpts
dotOptsParser = DotOpts
<$> includeExternal
<*> includeBase
<*> depthLimit
<*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs
where includeExternal = boolFlags False
"external"
"inclusion of external dependencies"
idm
includeBase = boolFlags True
"include-base"
"inclusion of dependencies on base"
idm
depthLimit =
optional (option auto
(long "depth" <>
metavar "DEPTH" <>
help ("Limit the depth of dependency resolution " <>
"(Default: No limit)")))
prunedPkgs = optional (strOption
(long "prune" <>
metavar "PACKAGES" <>
help ("Prune each package name " <>
"from the comma separated list " <>
"of package names PACKAGES")))
splitNames :: String -> [String]
splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","
ghciOptsParser :: Parser GhciOpts
ghciOptsParser = GhciOpts
<$> switch (long "no-build" <> help "Don't build before launching GHCi")
<*> fmap concat (many (argsOption (long "ghci-options" <>
metavar "OPTION" <>
help "Additional options passed to GHCi")))
<*> optional
(strOption (long "with-ghc" <>
metavar "GHC" <>
help "Use this GHC to run GHCi"))
<*> (not <$> boolFlags True "load" "load modules on start-up" idm)
<*> packagesParser
<*> optional
(textOption
(long "main-is" <>
metavar "TARGET" <>
help "Specify which target should contain the main \
\module to load, such as for an executable for \
\test suite or benchmark."))
<*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")
<*> buildOptsParser Build
-- | Parser for exec command
execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser mcmd =
ExecOpts
<$> maybe eoCmdParser pure mcmd
<*> eoArgsParser
<*> execOptsExtraParser
where
eoCmdParser = ExecCmd <$> strArgument (metavar "CMD")
eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))
evalOptsParser :: String -- ^ metavar
-> Parser EvalOpts
evalOptsParser meta =
EvalOpts
<$> eoArgsParser
<*> execOptsExtraParser
where
eoArgsParser :: Parser String
eoArgsParser = strArgument (metavar meta)
-- | Parser for extra options to exec command
execOptsExtraParser :: Parser ExecOptsExtra
execOptsExtraParser = eoPlainParser <|>
ExecOptsEmbellished
<$> eoEnvSettingsParser
<*> eoPackagesParser
where
eoEnvSettingsParser :: Parser EnvSettings
eoEnvSettingsParser = EnvSettings
<$> pure True
<*> boolFlags True
"ghc-package-path"
"setting the GHC_PACKAGE_PATH variable for the subprocess"
idm
<*> boolFlags True
"stack-exe"
"setting the STACK_EXE environment variable to the path for the stack executable"
idm
<*> pure False
eoPackagesParser :: Parser [String]
eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
eoPlainParser :: Parser ExecOptsExtra
eoPlainParser = flag' ExecOptsPlain
(long "plain" <>
help "Use an unmodified environment (only useful with Docker)")
-- | Parser for global command-line options.
globalOptsParser :: Bool -> Parser GlobalOptsMonoid
globalOptsParser hide0 =
GlobalOptsMonoid <$>
optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>
optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>
logLevelOptsParser hide0 <*>
configOptsParser hide0 <*>
optional (abstractResolverOptsParser hide0) <*>
optional (compilerOptsParser hide0) <*>
maybeBoolFlags
"terminal"
"overriding terminal detection in the case of running in a false terminal"
hide <*>
optional (strOption (long "stack-yaml" <>
metavar "STACK-YAML" <>
help ("Override project stack.yaml file " <>
"(overrides any STACK_YAML environment variable)") <>
hide))
where hide = hideMods hide0
-- | Create GlobalOpts from GlobalOptsMonoid.
globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts
globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts
{ globalReExecVersion = globalMonoidReExecVersion
, globalDockerEntrypoint = globalMonoidDockerEntrypoint
, globalLogLevel = fromMaybe defaultLogLevel globalMonoidLogLevel
, globalConfigMonoid = globalMonoidConfigMonoid
, globalResolver = globalMonoidResolver
, globalCompiler = globalMonoidCompiler
, globalTerminal = fromMaybe defaultTerminal globalMonoidTerminal
, globalStackYaml = globalMonoidStackYaml }
initOptsParser :: Parser InitOpts
initOptsParser =
InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs
where
ignoreSubDirs = switch (long "ignore-subdirs" <>
help "Do not search for .cabal files in sub directories")
overwrite = switch (long "force" <>
help "Force overwriting of an existing stack.yaml if it exists")
method = solver
<|> (MethodResolver <$> resolver)
<|> (MethodSnapshot <$> snapPref)
solver =
flag' MethodSolver
(long "solver" <>
help "Use a dependency solver to determine dependencies")
snapPref =
flag' PrefLTS
(long "prefer-lts" <>
help "Prefer LTS snapshots over Nightly snapshots") <|>
flag' PrefNightly
(long "prefer-nightly" <>
help "Prefer Nightly snapshots over LTS snapshots") <|>
pure PrefNone
resolver = option readAbstractResolver
(long "resolver" <>
metavar "RESOLVER" <>
help "Use the given resolver, even if not all dependencies are met")
-- | Parser for a logging level.
logLevelOptsParser :: Bool -> Parser (Maybe LogLevel)
logLevelOptsParser hide =
fmap (Just . parse)
(strOption (long "verbosity" <>
metavar "VERBOSITY" <>
help "Verbosity: silent, error, warn, info, debug" <>
hideMods hide)) <|>
flag' (Just verboseLevel)
(short 'v' <> long "verbose" <>
help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <>
hideMods hide) <|>
pure Nothing
where verboseLevel = LevelDebug
showLevel l =
case l of
LevelDebug -> "debug"
LevelInfo -> "info"
LevelWarn -> "warn"
LevelError -> "error"
LevelOther x -> T.unpack x
parse s =
case s of
"debug" -> LevelDebug
"info" -> LevelInfo
"warn" -> LevelWarn
"error" -> LevelError
_ -> LevelOther (T.pack s)
-- | Parser for the resolver
abstractResolverOptsParser :: Bool -> Parser AbstractResolver
abstractResolverOptsParser hide =
option readAbstractResolver
(long "resolver" <>
metavar "RESOLVER" <>
help "Override resolver in project file" <>
hideMods hide)
readAbstractResolver :: ReadM AbstractResolver
readAbstractResolver = do
s <- readerAsk
case s of
"global" -> return ARGlobal
"nightly" -> return ARLatestNightly
"lts" -> return ARLatestLTS
'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->
return $ ARLatestLTSMajor x'
_ ->
case parseResolverText $ T.pack s of
Left e -> readerError $ show e
Right x -> return $ ARResolver x
compilerOptsParser :: Bool -> Parser CompilerVersion
compilerOptsParser hide =
option readCompilerVersion
(long "compiler" <>
metavar "COMPILER" <>
help "Use the specified compiler" <>
hideMods hide)
readCompilerVersion :: ReadM CompilerVersion
readCompilerVersion = do
s <- readerAsk
case parseCompilerVersion (T.pack s) of
Nothing -> readerError $ "Failed to parse compiler: " ++ s
Just x -> return x
-- | GHC variant parser
ghcVariantParser :: Bool -> Parser GHCVariant
ghcVariantParser hide =
option
readGHCVariant
(long "ghc-variant" <> metavar "VARIANT" <>
help
"Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" <>
hideMods hide
)
where
readGHCVariant = do
s <- readerAsk
case parseGHCVariant s of
Left e -> readerError (show e)
Right v -> return v
-- | Parser for @solverCmd@
solverOptsParser :: Parser Bool
solverOptsParser = boolFlags False
"modify-stack-yaml"
"Automatically modify stack.yaml with the solver's recommendations"
idm
-- | Parser for test arguments.
testOptsParser :: Parser TestOpts
testOptsParser = TestOpts
<$> boolFlags True
"rerun-tests"
"running already successful tests"
idm
<*> fmap (fromMaybe [])
(optional (argsOption(long "test-arguments" <>
metavar "TEST_ARGS" <>
help "Arguments passed in to the test suite program")))
<*> switch (long "coverage" <>
help "Generate a code coverage report")
<*> switch (long "no-run-tests" <>
help "Disable running of tests. (Tests will still be built.)")
-- | Parser for @stack new@.
newOptsParser :: Parser (NewOpts,InitOpts)
newOptsParser = (,) <$> newOpts <*> initOptsParser
where
newOpts =
NewOpts <$>
packageNameArgument
(metavar "PACKAGE_NAME" <> help "A valid package name.") <*>
switch
(long "bare" <>
help "Do not create a subdirectory for the project") <*>
templateNameArgument
(metavar "TEMPLATE_NAME" <>
help "Name of a template or a local template in a subdirectory,\
\ for example: foo or foo.hsfiles" <>
value defaultTemplateName) <*>
fmap
M.fromList
(many
(templateParamArgument
(short 'p' <> long "param" <> metavar "KEY:VALUE" <>
help
"Parameter for the template in the format key:value")))
-- | Parser for @stack hpc report@.
hpcReportOptsParser :: Parser HpcReportOpts
hpcReportOptsParser = HpcReportOpts
<$> many (textArgument $ metavar "TARGET_OR_TIX")
<*> switch (long "all" <> help "Use results from all packages and components")
<*> optional (strOption (long "destdir" <> help "Output directy for HTML report"))
pvpBoundsOption :: Parser PvpBounds
pvpBoundsOption =
option
readPvpBounds
(long "pvp-bounds" <> metavar "PVP-BOUNDS" <>
help
"How PVP version bounds should be added to .cabal file: none, lower, upper, both")
where
readPvpBounds = do
s <- readerAsk
case parsePvpBounds $ T.pack s of
Left e ->
readerError e
Right v ->
return v
configCmdSetParser :: Parser ConfigCmdSet
configCmdSetParser =
fromM
(do field <-
oneM
(strArgument
(metavar "FIELD VALUE"))
oneM (fieldToValParser field))
where
fieldToValParser :: String -> Parser ConfigCmdSet
fieldToValParser s =
case s of
"resolver" ->
ConfigCmdSetResolver <$>
argument
readAbstractResolver
idm
_ ->
error "parse stack config set field: only set resolver is implemented"
-- | If argument is True, hides the option from usage and help
hideMods :: Bool -> Mod f a
hideMods hide = if hide then internal <> hidden else idm
stack-0.1.10.0/src/Stack/Package.hs 0000644 0000000 0000000 00000127445 12630352213 014757 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
-- | Dealing with Cabal.
module Stack.Package
(readPackage
,readPackageBS
,readPackageDescriptionDir
,readPackageUnresolved
,readPackageUnresolvedBS
,resolvePackage
,getCabalFileName
,Package(..)
,GetPackageFiles(..)
,GetPackageOpts(..)
,PackageConfig(..)
,buildLogPath
,PackageException (..)
,resolvePackageDescription
,packageToolDependencies
,packageDependencies
,packageIdentifier
,autogenDir
,checkCabalFileName
,printCabalFileWarning
,cabalFilePackageId)
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative, (<$>), (<*>))
#endif
import Control.Arrow ((&&&))
import Control.Exception hiding (try,catch)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger,logWarn)
import Control.Monad.Reader
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.Either
import Data.Function
import Data.List
import Data.List.Extra (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Maybe.Extra
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Version (showVersion)
import Distribution.Compiler
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as Cabal
import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
import qualified Distribution.Package as D
import Distribution.PackageDescription hiding (FlagName)
import qualified Distribution.PackageDescription as D
import Distribution.PackageDescription.Parse
import qualified Distribution.PackageDescription.Parse as D
import Distribution.ParseUtils
import Distribution.Simple.Utils
import Distribution.System (OS (..), Arch, Platform (..))
import Distribution.Text (display, simpleParse)
import qualified Distribution.Verbosity as D
import Path as FL
import Path.Extra
import Path.Find
import Path.IO
import Prelude
import Safe (headDef, tailSafe)
import Stack.Build.Installed
import Stack.Constants
import Stack.Types
import qualified Stack.Types.PackageIdentifier
import System.Directory (doesFileExist, getDirectoryContents)
import System.FilePath (splitExtensions, replaceExtension)
import qualified System.FilePath as FilePath
import System.IO.Error
packageIdentifier :: Package -> Stack.Types.PackageIdentifier.PackageIdentifier
packageIdentifier pkg =
Stack.Types.PackageIdentifier.PackageIdentifier
(packageName pkg)
(packageVersion pkg)
-- | Read the raw, unresolved package information.
readPackageUnresolved :: (MonadIO m, MonadThrow m)
=> Path Abs File
-> m ([PWarning],GenericPackageDescription)
readPackageUnresolved cabalfp =
liftIO (BS.readFile (FL.toFilePath cabalfp))
>>= readPackageUnresolvedBS (Just cabalfp)
-- | Read the raw, unresolved package information from a ByteString.
readPackageUnresolvedBS :: (MonadThrow m)
=> Maybe (Path Abs File)
-> BS.ByteString
-> m ([PWarning],GenericPackageDescription)
readPackageUnresolvedBS mcabalfp bs =
case parsePackageDescription chars of
ParseFailed per ->
throwM (PackageInvalidCabalFile mcabalfp per)
ParseOk warnings gpkg -> return (warnings,gpkg)
where
chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs))
-- https://github.com/haskell/hackage-server/issues/351
dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t
-- | Reads and exposes the package information
readPackage :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> PackageConfig
-> Path Abs File
-> m ([PWarning],Package)
readPackage packageConfig cabalfp =
do (warnings,gpkg) <- readPackageUnresolved cabalfp
return (warnings,resolvePackage packageConfig gpkg)
-- | Reads and exposes the package information, from a ByteString
readPackageBS :: (MonadThrow m)
=> PackageConfig
-> BS.ByteString
-> m ([PWarning],Package)
readPackageBS packageConfig bs =
do (warnings,gpkg) <- readPackageUnresolvedBS Nothing bs
return (warnings,resolvePackage packageConfig gpkg)
-- | Get 'GenericPackageDescription' and 'PackageDescription' reading info
-- from given directory.
readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> PackageConfig
-> Path Abs Dir
-> m (GenericPackageDescription, PackageDescription)
readPackageDescriptionDir config pkgDir = do
cabalfp <- getCabalFileName pkgDir
gdesc <- liftM snd (readPackageUnresolved cabalfp)
return (gdesc, resolvePackageDescription config gdesc)
-- | Print cabal file warnings.
printCabalFileWarning
:: (MonadLogger m)
=> Path Abs File -> PWarning -> m ()
printCabalFileWarning cabalfp =
\case
(PWarning x) ->
$logWarn
("Cabal file warning in " <> T.pack (toFilePath cabalfp) <>
": " <>
T.pack x)
(UTFWarning line msg) ->
$logWarn
("Cabal file warning in " <> T.pack (toFilePath cabalfp) <> ":" <>
T.pack (show line) <>
": " <>
T.pack msg)
-- | Check if the given name in the @Package@ matches the name of the .cabal file
checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()
checkCabalFileName name cabalfp = do
-- Previously, we just use parsePackageNameFromFilePath. However, that can
-- lead to confusing error messages. See:
-- https://github.com/commercialhaskell/stack/issues/895
let expected = packageNameString name ++ ".cabal"
when (expected /= toFilePath (filename cabalfp))
$ throwM $ MismatchedCabalName cabalfp name
-- | Resolve a parsed cabal file into a 'Package'.
resolvePackage :: PackageConfig
-> GenericPackageDescription
-> Package
resolvePackage packageConfig gpkg =
Package
{ packageName = name
, packageVersion = fromCabalVersion (pkgVersion pkgId)
, packageDeps = deps
, packageFiles = pkgFiles
, packageTools = packageDescTools pkg
, packageFlags = packageConfigFlags packageConfig
, packageAllDeps = S.fromList (M.keys deps)
, packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg)
, packageTests = M.fromList
[(T.pack (testName t), testInterface t) | t <- testSuites pkg
, buildable (testBuildInfo t)]
, packageBenchmarks = S.fromList
[T.pack (benchmarkName b) | b <- benchmarks pkg
, buildable (benchmarkBuildInfo b)]
, packageExes = S.fromList
[T.pack (exeName b) | b <- executables pkg
, buildable (buildInfo b)]
, packageOpts = GetPackageOpts $
\sourceMap installedMap omitPkgs cabalfp ->
do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp
componentsOpts <-
generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentFiles
return (componentsModules,componentFiles,componentsOpts)
, packageHasExposedModules = maybe
False
(not . null . exposedModules)
(library pkg)
, packageSimpleType = buildType (packageDescription gpkg) == Just Simple
, packageDefinedFlags = S.fromList $
map (fromCabalFlagName . flagName) $ genPackageFlags gpkg
}
where
pkgFiles = GetPackageFiles $
\cabalfp ->
do distDir <- distDirFromDir (parent cabalfp)
(componentModules,componentFiles,dataFiles',warnings) <-
runReaderT
(packageDescModulesAndFiles pkg)
(cabalfp, buildDir distDir)
return (componentModules, componentFiles, S.insert cabalfp dataFiles', warnings)
pkgId = package (packageDescription gpkg)
name = fromCabalPackageName (pkgName pkgId)
pkg = resolvePackageDescription packageConfig gpkg
deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg)
-- | Generate GHC options for the package's components, and a list of
-- options which apply generally to the package, not one specific
-- component.
generatePkgDescOpts
:: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)
=> SourceMap
-> InstalledMap
-> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags
-> Path Abs File
-> PackageDescription
-> Map NamedComponent (Set DotCabalPath)
-> m (Map NamedComponent BuildInfoOpts)
generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentPaths = do
distDir <- distDirFromDir cabalDir
let cabalMacros = autogenDir distDir $(mkRelFile "cabal_macros.h")
exists <- fileExists cabalMacros
let mcabalMacros =
if exists
then Just cabalMacros
else Nothing
let generate namedComponent binfo =
( namedComponent
, generateBuildInfoOpts
sourceMap
installedMap
mcabalMacros
cabalDir
distDir
omitPkgs
binfo
(fromMaybe mempty (M.lookup namedComponent componentPaths))
namedComponent)
return
( M.fromList
(concat
[ maybe
[]
(return . generate CLib . libBuildInfo)
(library pkg)
, fmap
(\exe ->
generate
(CExe (T.pack (exeName exe)))
(buildInfo exe))
(executables pkg)
, fmap
(\bench ->
generate
(CBench (T.pack (benchmarkName bench)))
(benchmarkBuildInfo bench))
(benchmarks pkg)
, fmap
(\test ->
generate
(CTest (T.pack (testName test)))
(testBuildInfo test))
(testSuites pkg)]))
where
cabalDir = parent cabalfp
-- | Generate GHC options for the target.
generateBuildInfoOpts
:: SourceMap
-> InstalledMap
-> Maybe (Path Abs File)
-> Path Abs Dir
-> Path Abs Dir
-> [PackageName]
-> BuildInfo
-> Set DotCabalPath
-> NamedComponent
-> BuildInfoOpts
generateBuildInfoOpts sourceMap installedMap mcabalMacros cabalDir distDir omitPkgs b dotCabalPaths componentName =
BuildInfoOpts
{ bioOpts = ghcOpts b ++ cppOptions b
-- NOTE for future changes: Due to this use of nubOrd (and other uses
-- downstream), these generated options must not rely on multiple
-- argument sequences. For example, ["--main-is", "Foo.hs", "--main-
-- is", "Bar.hs"] would potentially break due to the duplicate
-- "--main-is" being removed.
--
-- See https://github.com/commercialhaskell/stack/issues/1255
, bioOneWordOpts = nubOrd $ concat
[extOpts b, srcOpts, includeOpts, deps, extra b, extraDirs, fworks b, cObjectFiles]
, bioCabalMacros = mcabalMacros
}
where
cObjectFiles =
mapMaybe (fmap toFilePath .
makeObjectFilePathFromC cabalDir componentName distDir)
cfiles
cfiles = mapMaybe dotCabalCFilePath (S.toList dotCabalPaths)
deps =
concat
[ case M.lookup (fromCabalPackageName name) installedMap of
Just (_, Stack.Types.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid]
_ -> ["-package=" <> display name <>
maybe "" -- This empty case applies to e.g. base.
((("-" <>) . versionString) . sourceVersion)
(M.lookup (fromCabalPackageName name) sourceMap)]
| Dependency name _ <- targetBuildDepends b
, name `notElem` fmap toCabalPackageName omitPkgs]
-- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...
sourceVersion (PSUpstream ver _ _) = ver
sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg)
ghcOpts = concatMap snd . filter (isGhc . fst) . options
where
isGhc GHC = True
isGhc _ = False
extOpts = map (("-X" ++) . display) . usedExtensions
srcOpts =
map
(("-i" <>) . toFilePathNoTrailingSep)
([cabalDir | null (hsSourceDirs b)] <>
mapMaybe toIncludeDir (hsSourceDirs b) <>
[autogenDir distDir,buildDir distDir]) ++
["-stubdir=" ++ toFilePathNoTrailingSep (buildDir distDir)]
toIncludeDir "." = Just cabalDir
toIncludeDir x = fmap (cabalDir ) (parseRelDir x)
includeOpts =
[ "-I" <> toFilePathNoTrailingSep absDir
| dir <- includeDirs b
, absDir <- case (parseAbsDir dir, parseRelDir dir) of
(Just ab, _ ) -> [ab]
(_ , Just rel) -> [cabalDir rel]
(Nothing, Nothing ) -> []
]
extra
= map ("-l" <>)
. extraLibs
extraDirs =
[ "-L" <> toFilePathNoTrailingSep absDir
| dir <- extraLibDirs b
, absDir <- case (parseAbsDir dir, parseRelDir dir) of
(Just ab, _ ) -> [ab]
(_ , Just rel) -> [cabalDir rel]
(Nothing, Nothing ) -> []
]
fworks = map (\fwk -> "-framework=" <> fwk) . frameworks
-- | Make the .o path from the .c file path for a component. Example:
--
-- @
-- executable FOO
-- c-sources: cbits/text_search.c
-- @
--
-- Produces
--
-- /build/FOO/FOO-tmp/cbits/text_search.o
--
-- Example:
--
-- λ> makeObjectFilePathFromC
-- $(mkAbsDir "/Users/chris/Repos/hoogle")
-- CLib
-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")
-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")
-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/cbits/text_search.o"
-- λ> makeObjectFilePathFromC
-- $(mkAbsDir "/Users/chris/Repos/hoogle")
-- (CExe "hoogle")
-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")
-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")
-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/hoogle/hoogle-tmp/cbits/text_search.o"
-- λ>
makeObjectFilePathFromC
:: MonadThrow m
=> Path Abs Dir -- ^ The cabal directory.
-> NamedComponent -- ^ The name of the component.
-> Path Abs Dir -- ^ Dist directory.
-> Path Abs File -- ^ The path to the .c file.
-> m (Path Abs File) -- ^ The path to the .o file for the component.
makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do
relCFilePath <- stripDir cabalDir cFilePath
relOFilePath <-
parseRelFile (replaceExtension (toFilePath relCFilePath) "o")
addComponentPrefix <- fromComponentName
return (addComponentPrefix (buildDir distDir) relOFilePath)
where
fromComponentName =
case namedComponent of
CLib -> return id
CExe name -> makeTmp name
CTest name -> makeTmp name
CBench name -> makeTmp name
makeTmp name = do
prefix <- parseRelDir (T.unpack name <> "/" <> T.unpack name <> "-tmp")
return ( prefix)
-- | Make the autogen dir.
autogenDir :: Path Abs Dir -> Path Abs Dir
autogenDir distDir = buildDir distDir $(mkRelDir "autogen")
-- | Make the build dir.
buildDir :: Path Abs Dir -> Path Abs Dir
buildDir distDir = distDir $(mkRelDir "build")
-- | Make the component-specific subdirectory of the build directory.
getBuildComponentDir :: Maybe String -> Maybe (Path Rel Dir)
getBuildComponentDir Nothing = Nothing
getBuildComponentDir (Just name) = parseRelDir (name FilePath. (name ++ "-tmp"))
-- | Get all dependencies of the package (buildable targets only).
packageDependencies :: PackageDescription -> Map PackageName VersionRange
packageDependencies =
M.fromListWith intersectVersionRanges .
concatMap (fmap (depName &&& depRange) .
targetBuildDepends) .
allBuildInfo'
-- | Get all build tool dependencies of the package (buildable targets only).
packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange
packageToolDependencies =
M.fromList .
concatMap (fmap (packageNameByteString . depName &&& depRange) .
buildTools) .
allBuildInfo'
-- | Get all dependencies of the package (buildable targets only).
packageDescTools :: PackageDescription -> [Dependency]
packageDescTools = concatMap buildTools . allBuildInfo'
-- | This is a copy-paste from Cabal's @allBuildInfo@ function, but with the
-- @buildable@ test removed. The reason is that (surprise) Cabal is broken,
-- see: https://github.com/haskell/cabal/issues/1725
allBuildInfo' :: PackageDescription -> [BuildInfo]
allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr]
, let bi = libBuildInfo lib
, True || buildable bi ]
++ [ bi | exe <- executables pkg_descr
, let bi = buildInfo exe
, True || buildable bi ]
++ [ bi | tst <- testSuites pkg_descr
, let bi = testBuildInfo tst
, True || buildable bi
, testEnabled tst ]
++ [ bi | tst <- benchmarks pkg_descr
, let bi = benchmarkBuildInfo tst
, True || buildable bi
, benchmarkEnabled tst ]
-- | Get all files referenced by the package.
packageDescModulesAndFiles
:: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m)
=> PackageDescription
-> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning])
packageDescModulesAndFiles pkg = do
(libraryMods,libDotCabalFiles,libWarnings) <-
maybe
(return (M.empty, M.empty, []))
(asModuleAndFileMap libComponent libraryFiles)
(library pkg)
(executableMods,exeDotCabalFiles,exeWarnings) <-
liftM
foldTuples
(mapM
(asModuleAndFileMap exeComponent executableFiles)
(executables pkg))
(testMods,testDotCabalFiles,testWarnings) <-
liftM
foldTuples
(mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg))
(benchModules,benchDotCabalPaths,benchWarnings) <-
liftM
foldTuples
(mapM
(asModuleAndFileMap benchComponent benchmarkFiles)
(benchmarks pkg))
(dfiles) <- resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg))
let modules = libraryMods <> executableMods <> testMods <> benchModules
files =
libDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <>
benchDotCabalPaths
warnings = libWarnings <> exeWarnings <> testWarnings <> benchWarnings
return (modules, files, dfiles, warnings)
where
libComponent = const CLib
exeComponent = CExe . T.pack . exeName
testComponent = CTest . T.pack . testName
benchComponent = CBench . T.pack . benchmarkName
asModuleAndFileMap label f lib = do
(a,b,c) <- f lib
return (M.singleton (label lib) a, M.singleton (label lib) b, c)
foldTuples = foldl' (<>) (M.empty, M.empty, [])
-- | Resolve globbing of files (e.g. data files) to absolute paths.
resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m)
=> [String] -> m (Set (Path Abs File))
resolveGlobFiles =
liftM (S.fromList . catMaybes . concat) .
mapM resolve
where
resolve name =
if '*' `elem` name
then explode name
else liftM return (resolveFileOrWarn name)
explode name = do
dir <- asks (parent . fst)
names <-
matchDirFileGlob'
(FL.toFilePath dir)
name
mapM resolveFileOrWarn names
matchDirFileGlob' dir glob =
catch
(liftIO (matchDirFileGlob_ dir glob))
(\(e :: IOException) ->
if isUserError e
then do
$logWarn
("Wildcard does not match any files: " <> T.pack glob <> "\n" <>
"in directory: " <> T.pack dir)
return []
else throwM e)
-- | This is a copy/paste of the Cabal library function, but with
--
-- @ext == ext'@
--
-- Changed to
--
-- @isSuffixOf ext ext'@
--
-- So that this will work:
--
-- @
-- λ> matchDirFileGlob_ "." "test/package-dump/*.txt"
-- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"]
-- @
--
matchDirFileGlob_ :: String -> String -> IO [String]
matchDirFileGlob_ dir filepath = case parseFileGlob filepath of
Nothing -> die $ "invalid file glob '" ++ filepath
++ "'. Wildcards '*' are only allowed in place of the file"
++ " name, not in the directory name or file extension."
++ " If a wildcard is used it must be with an file extension."
Just (NoGlob filepath') -> return [filepath']
Just (FileGlob dir' ext) -> do
files <- getDirectoryContents (dir FilePath. dir')
case [ dir' FilePath. file
| file <- files
, let (name, ext') = splitExtensions file
, not (null name) && isSuffixOf ext ext' ] of
[] -> die $ "filepath wildcard '" ++ filepath
++ "' does not match any files."
matches -> return matches
-- | Get all files referenced by the benchmark.
benchmarkFiles
:: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
benchmarkFiles bench = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
dir <- asks (parent . fst)
(modules,files,warnings) <-
resolveFilesAndDeps
(Just $ benchmarkName bench)
(dirs ++ [dir])
(bnames <> exposed)
haskellModuleExts
cfiles <- buildOtherSources build
return (modules, files <> cfiles, warnings)
where
exposed =
case benchmarkInterface bench of
BenchmarkExeV10 _ fp -> [DotCabalMain fp]
BenchmarkUnsupported _ -> []
bnames = map DotCabalModule (otherModules build)
build = benchmarkBuildInfo bench
-- | Get all files referenced by the test.
testFiles
:: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> TestSuite
-> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
testFiles test = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
dir <- asks (parent . fst)
(modules,files,warnings) <-
resolveFilesAndDeps
(Just $ testName test)
(dirs ++ [dir])
(bnames <> exposed)
haskellModuleExts
cfiles <- buildOtherSources build
return (modules, files <> cfiles, warnings)
where
exposed =
case testInterface test of
TestSuiteExeV10 _ fp -> [DotCabalMain fp]
TestSuiteLibV09 _ mn -> [DotCabalModule mn]
TestSuiteUnsupported _ -> []
bnames = map DotCabalModule (otherModules build)
build = testBuildInfo test
-- | Get all files referenced by the executable.
executableFiles
:: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Executable
-> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
executableFiles exe = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
dir <- asks (parent . fst)
(modules,files,warnings) <-
resolveFilesAndDeps
(Just $ exeName exe)
(dirs ++ [dir])
(map DotCabalModule (otherModules build) ++
[DotCabalMain (modulePath exe)])
haskellModuleExts
cfiles <- buildOtherSources build
return (modules, files <> cfiles, warnings)
where
build = buildInfo exe
-- | Get all files referenced by the library.
libraryFiles
:: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
libraryFiles lib = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
dir <- asks (parent . fst)
(modules,files,warnings) <-
resolveFilesAndDeps
Nothing
(dirs ++ [dir])
(names <> exposed)
haskellModuleExts
cfiles <- buildOtherSources build
return (modules, files <> cfiles, warnings)
where
names = bnames ++ exposed
exposed = map DotCabalModule (exposedModules lib)
bnames = map DotCabalModule (otherModules build)
build = libBuildInfo lib
-- | Get all C sources and extra source files in a build.
buildOtherSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)
=> BuildInfo -> m (Set DotCabalPath)
buildOtherSources build =
do csources <- liftM
(S.map DotCabalCFilePath . S.fromList)
(mapMaybeM resolveFileOrWarn (cSources build))
jsources <- liftM
(S.map DotCabalFilePath . S.fromList)
(mapMaybeM resolveFileOrWarn (targetJsSources build))
return (csources <> jsources)
-- | Get the target's JS sources.
targetJsSources :: BuildInfo -> [FilePath]
#if MIN_VERSION_Cabal(1, 22, 0)
targetJsSources = jsSources
#else
targetJsSources = const []
#endif
-- | Get all dependencies of a package, including library,
-- executables, tests, benchmarks.
resolvePackageDescription :: PackageConfig
-> GenericPackageDescription
-> PackageDescription
resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib exes tests benches) =
desc {library =
fmap (resolveConditions rc updateLibDeps) mlib
,executables =
map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n})
exes
,testSuites =
map (\(n,v) -> (resolveConditions rc updateTestDeps v){testName=n})
tests
,benchmarks =
map (\(n,v) -> (resolveConditions rc updateBenchmarkDeps v){benchmarkName=n})
benches}
where flags =
M.union (packageConfigFlags packageConfig)
(flagMap defaultFlags)
rc = mkResolveConditions
(packageConfigCompilerVersion packageConfig)
(packageConfigPlatform packageConfig)
flags
updateLibDeps lib deps =
lib {libBuildInfo =
(libBuildInfo lib) {targetBuildDepends = deps}}
updateExeDeps exe deps =
exe {buildInfo =
(buildInfo exe) {targetBuildDepends = deps}}
updateTestDeps test deps =
test {testBuildInfo =
(testBuildInfo test) {targetBuildDepends = deps}
,testEnabled = packageConfigEnableTests packageConfig}
updateBenchmarkDeps benchmark deps =
benchmark {benchmarkBuildInfo =
(benchmarkBuildInfo benchmark) {targetBuildDepends = deps}
,benchmarkEnabled = packageConfigEnableBenchmarks packageConfig}
-- | Make a map from a list of flag specifications.
--
-- What is @flagManual@ for?
flagMap :: [Flag] -> Map FlagName Bool
flagMap = M.fromList . map pair
where pair :: Flag -> (FlagName, Bool)
pair (MkFlag (fromCabalFlagName -> name) _desc def _manual) = (name,def)
data ResolveConditions = ResolveConditions
{ rcFlags :: Map FlagName Bool
, rcCompilerVersion :: CompilerVersion
, rcOS :: OS
, rcArch :: Arch
}
-- | Generic a @ResolveConditions@ using sensible defaults.
mkResolveConditions :: CompilerVersion -- ^ Compiler version
-> Platform -- ^ installation target platform
-> Map FlagName Bool -- ^ enabled flags
-> ResolveConditions
mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions
{ rcFlags = flags
, rcCompilerVersion = compilerVersion
, rcOS = os
, rcArch = arch
}
-- | Resolve the condition tree for the library.
resolveConditions :: (Monoid target,Show target)
=> ResolveConditions
-> (target -> cs -> target)
-> CondTree ConfVar cs target
-> target
resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children
where basic = addDeps lib deps
children = mconcat (map apply cs)
where apply (cond,node,mcs) =
if condSatisfied cond
then resolveConditions rc addDeps node
else maybe mempty (resolveConditions rc addDeps) mcs
condSatisfied c =
case c of
Var v -> varSatisifed v
Lit b -> b
CNot c' ->
not (condSatisfied c')
COr cx cy ->
condSatisfied cx || condSatisfied cy
CAnd cx cy ->
condSatisfied cx && condSatisfied cy
varSatisifed v =
case v of
OS os -> os == rcOS rc
Arch arch -> arch == rcArch rc
Flag flag ->
fromMaybe False $ M.lookup (fromCabalFlagName flag) (rcFlags rc)
-- NOTE: ^^^^^ This should never happen, as all flags
-- which are used must be declared. Defaulting to
-- False.
Impl flavor range ->
case (flavor, rcCompilerVersion rc) of
(GHC, GhcVersion vghc) -> vghc `withinRange` range
(GHC, GhcjsVersion _ vghc) -> vghc `withinRange` range
#if MIN_VERSION_Cabal(1, 22, 0)
(GHCJS, GhcjsVersion vghcjs _) ->
#else
(OtherCompiler "ghcjs", GhcjsVersion vghcjs _) ->
#endif
vghcjs `withinRange` range
_ -> False
-- | Get the name of a dependency.
depName :: Dependency -> PackageName
depName (Dependency n _) = fromCabalPackageName n
-- | Get the version range of a dependency.
depRange :: Dependency -> VersionRange
depRange (Dependency _ r) = r
-- | Try to resolve the list of base names in the given directory by
-- looking for unique instances of base names applied with the given
-- extensions, plus find any of their module and TemplateHaskell
-- dependencies.
resolveFilesAndDeps
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Maybe String -- ^ Package component name
-> [Path Abs Dir] -- ^ Directories to look in.
-> [DotCabalDescriptor] -- ^ Base names.
-> [Text] -- ^ Extentions.
-> m (Set ModuleName,Set DotCabalPath,[PackageWarning])
resolveFilesAndDeps component dirs names0 exts = do
(dotCabalPaths,foundModules) <- loop names0 S.empty
warnings <- warnUnlisted foundModules
return (foundModules, dotCabalPaths, warnings)
where
loop [] doneModules = return (S.empty, doneModules)
loop names doneModules0 = do
resolvedFiles <- resolveFiles dirs names exts
pairs <- mapM (getDependencies component) resolvedFiles
let doneModules' =
S.union
doneModules0
(S.fromList (mapMaybe dotCabalModule names))
moduleDeps = S.unions (map fst pairs)
thDepFiles = concatMap snd pairs
modulesRemaining = S.difference moduleDeps doneModules'
(resolvedFiles',doneModules'') <-
loop (map DotCabalModule (S.toList modulesRemaining)) doneModules'
return
( S.union
(S.fromList
(resolvedFiles <> map DotCabalFilePath thDepFiles))
resolvedFiles'
, doneModules'')
warnUnlisted foundModules = do
let unlistedModules =
foundModules `S.difference`
S.fromList (mapMaybe dotCabalModule names0)
cabalfp <- asks fst
return $
if S.null unlistedModules
then []
else [ UnlistedModulesWarning
cabalfp
component
(S.toList unlistedModules)]
-- | Get the dependencies of a Haskell module file.
getDependencies
:: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m)
=> Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File])
getDependencies component dotCabalPath =
case dotCabalPath of
DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile
DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile
DotCabalFilePath{} -> return (S.empty, [])
DotCabalCFilePath{} -> return (S.empty, [])
where
readResolvedHi resolvedFile = do
dumpHIDir <- getDumpHIDir
dir <- asks (parent . fst)
case stripDir dir resolvedFile of
Nothing -> return (S.empty, [])
Just fileRel -> do
let dumpHIPath =
FilePath.replaceExtension
(toFilePath (dumpHIDir fileRel))
".dump-hi"
dumpHIExists <- liftIO $ doesFileExist dumpHIPath
if dumpHIExists
then parseDumpHI dumpHIPath
else return (S.empty, [])
getDumpHIDir = do
bld <- asks snd
return $ maybe bld (bld ) (getBuildComponentDir component)
-- | Parse a .dump-hi file into a set of modules and files.
parseDumpHI
:: (MonadReader (Path Abs File, void) m, MonadIO m)
=> FilePath -> m (Set ModuleName, [Path Abs File])
parseDumpHI dumpHIPath = do
dir <- asks (parent . fst)
dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath)
let startModuleDeps =
dropWhile (not . ("module dependencies:" `C8.isPrefixOf`)) dumpHI
moduleDeps =
S.fromList $
mapMaybe (simpleParse . T.unpack . decodeUtf8) $
C8.words $
C8.concat $
C8.dropWhile (/= ' ') (headDef "" startModuleDeps) :
takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps)
thDeps =
-- The dependent file path is surrounded by quotes but is not escaped.
-- It can be an absolute or relative path.
mapMaybe
(parseAbsOrRelFile dir <=<
(fmap T.unpack .
(T.stripSuffix "\"" <=< T.stripPrefix "\"") .
T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"'))) $
filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI
return (moduleDeps, thDeps)
where
parseAbsOrRelFile dir fp =
case parseRelFile fp of
Just rel -> Just (dir rel)
Nothing -> parseAbsFile fp
-- | Try to resolve the list of base names in the given directory by
-- looking for unique instances of base names applied with the given
-- extensions.
resolveFiles
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> [Path Abs Dir] -- ^ Directories to look in.
-> [DotCabalDescriptor] -- ^ Base names.
-> [Text] -- ^ Extentions.
-> m [DotCabalPath]
resolveFiles dirs names exts =
forMaybeM names (findCandidate dirs exts)
-- | Find a candidate for the given module-or-filename from the list
-- of directories and given extensions.
findCandidate
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
=> [Path Abs Dir]
-> [Text]
-> DotCabalDescriptor
-> m (Maybe DotCabalPath)
findCandidate dirs exts name = do
pkg <- asks fst >>= parsePackageNameFromFilePath
candidates <- liftIO makeNameCandidates
case candidates of
[candidate] -> return (Just (cons candidate))
[] -> do
case name of
DotCabalModule mn
| display mn /= paths_pkg pkg -> logPossibilities dirs mn
_ -> return ()
return Nothing
(candidate:rest) -> do
warnMultiple name candidate rest
return (Just (cons candidate))
where
cons =
case name of
DotCabalModule{} -> DotCabalModulePath
DotCabalMain{} -> DotCabalMainPath
DotCabalFile{} -> DotCabalFilePath
DotCabalCFile{} -> DotCabalCFilePath
paths_pkg pkg = "Paths_" ++ packageNameString pkg
makeNameCandidates =
liftM (nubOrd . rights . concat) (mapM makeDirCandidates dirs)
makeDirCandidates :: Path Abs Dir
-> IO [Either ResolveException (Path Abs File)]
makeDirCandidates dir =
case name of
DotCabalMain fp -> liftM return (try (resolveFile' dir fp))
DotCabalFile fp -> liftM return (try (resolveFile' dir fp))
DotCabalCFile fp -> liftM return (try (resolveFile' dir fp))
DotCabalModule mn ->
mapM
((\ ext ->
try (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext)))
. T.unpack)
exts
resolveFile'
:: (MonadIO m, MonadThrow m)
=> Path Abs Dir -> FilePath.FilePath -> m (Path Abs File)
resolveFile' x y = do
p <- parseCollapsedAbsFile (toFilePath x FilePath. y)
exists <- fileExists p
if exists
then return p
else throwM $ ResolveFileFailed x y (toFilePath p)
-- | Warn the user that multiple candidates are available for an
-- entry, but that we picked one anyway and continued.
warnMultiple
:: MonadLogger m
=> DotCabalDescriptor -> Path b t -> [Path b t] -> m ()
warnMultiple name candidate rest =
$logWarn
("There were multiple candidates for the Cabal entry \"" <>
showName name <>
"\" (" <>
T.intercalate "," (map (T.pack . toFilePath) rest) <>
"), picking " <>
T.pack (toFilePath candidate))
where showName (DotCabalModule name') = T.pack (display name')
showName (DotCabalMain fp) = T.pack fp
showName (DotCabalFile fp) = T.pack fp
showName (DotCabalCFile fp) = T.pack fp
-- | Log that we couldn't find a candidate, but there are
-- possibilities for custom preprocessor extensions.
--
-- For example: .erb for a Ruby file might exist in one of the
-- directories.
logPossibilities
:: (MonadIO m, MonadThrow m, MonadLogger m)
=> [Path Abs Dir] -> ModuleName -> m ()
logPossibilities dirs mn = do
possibilities <- liftM concat (makePossibilities mn)
case possibilities of
[] -> return ()
_ ->
$logWarn
("Unable to find a known candidate for the Cabal entry \"" <>
T.pack (display mn) <>
"\", but did find: " <>
T.intercalate ", " (map (T.pack . toFilePath) possibilities) <>
". If you are using a custom preprocessor for this module " <>
"with its own file extension, consider adding the file(s) " <>
"to your .cabal under extra-source-files.")
where
makePossibilities name =
mapM
(\dir ->
do (_,files) <- listDirectory dir
return
(map
filename
(filter
(isPrefixOf (display name) .
toFilePath . filename)
files)))
dirs
-- | Get the filename for the cabal file in the given directory.
--
-- If no .cabal file is present, or more than one is present, an exception is
-- thrown via 'throwM'.
getCabalFileName
:: (MonadThrow m, MonadIO m)
=> Path Abs Dir -- ^ package directory
-> m (Path Abs File)
getCabalFileName pkgDir = do
files <- liftIO $ findFiles
pkgDir
(flip hasExtension "cabal" . FL.toFilePath)
(const False)
case files of
[] -> throwM $ PackageNoCabalFileFound pkgDir
[x] -> return x
_:_ -> throwM $ PackageMultipleCabalFilesFound pkgDir files
where hasExtension fp x = FilePath.takeExtension fp == "." ++ x
-- | Path for the package's build log.
buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)
=> Package -> Maybe String -> m (Path Abs File)
buildLogPath package' msuffix = do
env <- ask
let stack = configProjectWorkDir env
fp <- parseRelFile $ concat $
packageIdentifierString (packageIdentifier package') :
maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"]
return $ stack $(mkRelDir "logs") fp
-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn
resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Text
-> (Path Abs Dir -> String -> m (Maybe a))
-> FilePath.FilePath
-> m (Maybe a)
resolveOrWarn subject resolver path =
do cwd <- getWorkingDir
file <- asks fst
dir <- asks (parent . fst)
result <- resolver dir path
when (isNothing result) $
$logWarn ("Warning: " <> subject <> " listed in " <>
T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>
" file does not exist: " <>
T.pack path)
return result
-- | Resolve the file, if it can't be resolved, warn for the user
-- (purely to be helpful).
resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
=> FilePath.FilePath
-> m (Maybe (Path Abs File))
resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe
-- | Resolve the directory, if it can't be resolved, warn for the user
-- (purely to be helpful).
resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
=> FilePath.FilePath
-> m (Maybe (Path Abs Dir))
resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
-- | Extract the @PackageIdentifier@ given an exploded haskell package
-- path.
cabalFilePackageId
:: (Applicative m, MonadIO m, MonadThrow m)
=> Path Abs File -> m PackageIdentifier
cabalFilePackageId fp = do
pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp)
(toStackPI . D.package . D.packageDescription) pkgDescr
where
toStackPI (D.PackageIdentifier (D.PackageName name) ver) =
PackageIdentifier <$> parsePackageNameFromString name <*>
parseVersionFromString (showVersion ver)
stack-0.1.10.0/src/Stack/PackageDump.hs 0000644 0000000 0000000 00000040554 12623647202 015607 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Stack.PackageDump
( Line
, eachSection
, eachPair
, DumpPackage (..)
, conduitDumpPackage
, ghcPkgDump
, ghcPkgDescribe
, InstalledCache
, InstalledCacheEntry (..)
, newInstalledCache
, loadInstalledCache
, saveInstalledCache
, addProfiling
, addHaddock
, sinkMatching
, pruneDeps
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception.Enclosed (tryIO)
import Control.Monad (liftM)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Control
import Data.Attoparsec.Args
import Data.Attoparsec.Text as P
import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Either (partitionEithers)
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, listToMaybe)
import Data.Maybe.Extra (mapMaybeM)
import qualified Data.Set as Set
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Path
import Path.IO (createTree)
import Path.Extra (toFilePathNoTrailingSep)
import Prelude -- Fix AMP warning
import Stack.GhcPkg
import Stack.Types
import System.Directory (getDirectoryContents, doesFileExist)
import System.Process.Read
-- | Cached information on whether package have profiling libraries and haddocks.
newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
deriving (Binary, NFData, Generic)
instance HasStructuralInfo InstalledCacheInner
instance HasSemanticVersion InstalledCacheInner
-- | Cached information on whether a package has profiling libraries and haddocks.
data InstalledCacheEntry = InstalledCacheEntry
{ installedCacheProfiling :: !Bool
, installedCacheHaddock :: !Bool
, installedCacheIdent :: !PackageIdentifier }
deriving (Eq, Generic)
instance Binary InstalledCacheEntry
instance HasStructuralInfo InstalledCacheEntry
instance NFData InstalledCacheEntry
-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database
ghcPkgDump
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir] -- ^ if empty, use global
-> Sink ByteString IO a
-> m a
ghcPkgDump = ghcPkgCmdArgs ["dump"]
-- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database
ghcPkgDescribe
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> PackageName
-> EnvOverride
-> WhichCompiler
-> [Path Abs Dir] -- ^ if empty, use global
-> Sink ByteString IO a
-> m a
ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName]
-- | Call ghc-pkg and stream to the given @Sink@, for a single database
ghcPkgCmdArgs
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> [String]
-> EnvOverride
-> WhichCompiler
-> [Path Abs Dir] -- ^ if empty, use global
-> Sink ByteString IO a
-> m a
ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do
case reverse mpkgDbs of
(pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead?
_ -> return ()
sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink
where
args = concat
[ case mpkgDbs of
[] -> ["--global", "--no-user-package-db"]
_ -> ["--user", "--no-user-package-db"] ++
concatMap (\pkgDb -> ["--package-db", toFilePathNoTrailingSep pkgDb]) mpkgDbs
, cmd
, ["--expand-pkgroot"]
]
-- | Create a new, empty @InstalledCache@
newInstalledCache :: MonadIO m => m InstalledCache
newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Map.empty)
-- | Load a @InstalledCache@ from disk, swallowing any errors and returning an
-- empty cache.
loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache
loadInstalledCache path = do
m <- taggedDecodeOrLoad path (return $ InstalledCacheInner Map.empty)
liftIO $ InstalledCache <$> newIORef m
-- | Save a @InstalledCache@ to disk
saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m ()
saveInstalledCache path (InstalledCache ref) = liftIO $ do
createTree (parent path)
readIORef ref >>= taggedEncodeFile path
-- | Prune a list of possible packages down to those whose dependencies are met.
--
-- * id uniquely identifies an item
--
-- * There can be multiple items per name
pruneDeps
:: (Ord name, Ord id)
=> (id -> name) -- ^ extract the name from an id
-> (item -> id) -- ^ the id of an item
-> (item -> [id]) -- ^ get the dependencies of an item
-> (item -> item -> item) -- ^ choose the desired of two possible items
-> [item] -- ^ input items
-> Map name item
pruneDeps getName getId getDepends chooseBest =
Map.fromList
. fmap (getName . getId &&& id)
. loop Set.empty Set.empty []
where
loop foundIds usedNames foundItems dps =
case partitionEithers $ map depsMet dps of
([], _) -> foundItems
(s', dps') ->
let foundIds' = Map.fromListWith chooseBest s'
foundIds'' = Set.fromList $ map getId $ Map.elems foundIds'
usedNames' = Map.keysSet foundIds'
foundItems' = Map.elems foundIds'
in loop
(Set.union foundIds foundIds'')
(Set.union usedNames usedNames')
(foundItems ++ foundItems')
(catMaybes dps')
where
depsMet dp
| name `Set.member` usedNames = Right Nothing
| all (`Set.member` foundIds) (getDepends dp) = Left (name, dp)
| otherwise = Right $ Just dp
where
id' = getId dp
name = getName id'
-- | Find the package IDs matching the given constraints with all dependencies installed.
-- Packages not mentioned in the provided @Map@ are allowed to be present too.
sinkMatching :: Monad m
=> Bool -- ^ require profiling?
-> Bool -- ^ require haddock?
-> Map PackageName Version -- ^ allowed versions
-> Consumer (DumpPackage Bool Bool)
m
(Map PackageName (DumpPackage Bool Bool))
sinkMatching reqProfiling reqHaddock allowed = do
dps <- CL.filter (\dp -> isAllowed (dpPackageIdent dp) &&
(not reqProfiling || dpProfiling dp) &&
(not reqHaddock || dpHaddock dp))
=$= CL.consume
return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps
id
dpGhcPkgId
dpDepends
const -- Could consider a better comparison in the future
dps
where
isAllowed (PackageIdentifier name version) =
case Map.lookup name allowed of
Just version' | version /= version' -> False
_ -> True
-- | Add profiling information to the stream of @DumpPackage@s
addProfiling :: MonadIO m
=> InstalledCache
-> Conduit (DumpPackage a b) m (DumpPackage Bool b)
addProfiling (InstalledCache ref) =
CL.mapM go
where
go dp = liftIO $ do
InstalledCacheInner m <- readIORef ref
let gid = dpGhcPkgId dp
p <- case Map.lookup gid m of
Just installed -> return (installedCacheProfiling installed)
Nothing | null (dpLibraries dp) -> return True
Nothing -> do
let loop [] = return False
loop (dir:dirs) = do
econtents <- tryIO $ getDirectoryContents dir
let contents = either (const []) id econtents
if or [isProfiling content lib
| content <- contents
, lib <- dpLibraries dp
] && not (null contents)
then return True
else loop dirs
loop $ dpLibDirs dp
return dp { dpProfiling = p }
isProfiling :: FilePath -- ^ entry in directory
-> ByteString -- ^ name of library
-> Bool
isProfiling content lib =
prefix `S.isPrefixOf` S8.pack content
where
prefix = S.concat ["lib", lib, "_p"]
-- | Add haddock information to the stream of @DumpPackage@s
addHaddock :: MonadIO m
=> InstalledCache
-> Conduit (DumpPackage a b) m (DumpPackage a Bool)
addHaddock (InstalledCache ref) =
CL.mapM go
where
go dp = liftIO $ do
InstalledCacheInner m <- readIORef ref
let gid = dpGhcPkgId dp
h <- case Map.lookup gid m of
Just installed -> return (installedCacheHaddock installed)
Nothing | not (dpHasExposedModules dp) -> return True
Nothing -> do
let loop [] = return False
loop (ifc:ifcs) = do
exists <- doesFileExist ifc
if exists
then return True
else loop ifcs
loop $ dpHaddockInterfaces dp
return dp { dpHaddock = h }
-- | Dump information for a single package
data DumpPackage profiling haddock = DumpPackage
{ dpGhcPkgId :: !GhcPkgId
, dpPackageIdent :: !PackageIdentifier
, dpLibDirs :: ![FilePath]
, dpLibraries :: ![ByteString]
, dpHasExposedModules :: !Bool
, dpDepends :: ![GhcPkgId]
, dpHaddockInterfaces :: ![FilePath]
, dpHaddockHtml :: !(Maybe FilePath)
, dpProfiling :: !profiling
, dpHaddock :: !haddock
, dpIsExposed :: !Bool
}
deriving (Show, Eq, Ord)
data PackageDumpException
= MissingSingleField ByteString (Map ByteString [Line])
| Couldn'tParseField ByteString [Line]
deriving Typeable
instance Exception PackageDumpException
instance Show PackageDumpException where
show (MissingSingleField name values) = unlines $ concat
[ return $ concat
[ "Expected single value for field name "
, show name
, " when parsing ghc-pkg dump output:"
]
, map (\(k, v) -> " " ++ show (k, v)) (Map.toList values)
]
show (Couldn'tParseField name ls) =
"Couldn't parse the field " ++ show name ++ " from lines: " ++ show ls
-- | Convert a stream of bytes into a stream of @DumpPackage@s
conduitDumpPackage :: MonadThrow m
=> Conduit ByteString m (DumpPackage () ())
conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do
pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume
let m = Map.fromList pairs
let parseS k =
case Map.lookup k m of
Just [v] -> return v
_ -> throwM $ MissingSingleField k m
-- Can't fail: if not found, same as an empty list. See:
-- https://github.com/fpco/stack/issues/182
parseM k = Map.findWithDefault [] k m
parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId)
parseDepend "builtin_rts" = return Nothing
parseDepend bs =
liftM Just $ parseGhcPkgId bs'
where
(bs', _builtinRts) =
case stripSuffixBS " builtin_rts" bs of
Nothing ->
case stripPrefixBS "builtin_rts " bs of
Nothing -> (bs, False)
Just x -> (x, True)
Just x -> (x, True)
case Map.lookup "id" m of
Just ["builtin_rts"] -> return Nothing
_ -> do
name <- parseS "name" >>= parsePackageName
version <- parseS "version" >>= parseVersion
ghcPkgId <- parseS "id" >>= parseGhcPkgId
-- if a package has no modules, these won't exist
let libDirKey = "library-dirs"
libraries = parseM "hs-libraries"
exposedModules = parseM "exposed-modules"
exposed = parseM "exposed"
depends <- mapMaybeM parseDepend $ parseM "depends"
let parseQuoted key =
case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of
Left{} -> throwM (Couldn'tParseField key val)
Right dirs -> return (concat dirs)
where
val = parseM key
libDirPaths <- parseQuoted libDirKey
haddockInterfaces <- parseQuoted "haddock-interfaces"
haddockHtml <- parseQuoted "haddock-html"
return $ Just DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = PackageIdentifier name version
, dpLibDirs = libDirPaths
, dpLibraries = S8.words $ S8.unwords libraries
, dpHasExposedModules = not (null libraries || null exposedModules)
, dpDepends = depends
, dpHaddockInterfaces = haddockInterfaces
, dpHaddockHtml = listToMaybe haddockHtml
, dpProfiling = ()
, dpHaddock = ()
, dpIsExposed = exposed == ["True"]
}
stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString
stripPrefixBS x y
| x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
| otherwise = Nothing
stripSuffixBS :: ByteString -> ByteString -> Maybe ByteString
stripSuffixBS x y
| x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y
| otherwise = Nothing
-- | A single line of input, not including line endings
type Line = ByteString
-- | Apply the given Sink to each section of output, broken by a single line containing ---
eachSection :: Monad m
=> Sink Line m a
-> Conduit ByteString m a
eachSection inner =
CL.map (S.filter (/= _cr)) =$= CB.lines =$= start
where
_cr = 13
peekBS = await >>= maybe (return Nothing) (\bs ->
if S.null bs
then peekBS
else leftover bs >> return (Just bs))
start = peekBS >>= maybe (return ()) (const go)
go = do
x <- toConsumer $ takeWhileC (/= "---") =$= inner
yield x
CL.drop 1
start
-- | Grab each key/value pair
eachPair :: Monad m
=> (ByteString -> Sink Line m a)
-> Conduit Line m a
eachPair inner =
start
where
start = await >>= maybe (return ()) start'
_colon = 58
_space = 32
start' bs1 =
toConsumer (valSrc =$= inner key) >>= yield >> start
where
(key, bs2) = S.break (== _colon) bs1
(spaces, bs3) = S.span (== _space) $ S.drop 1 bs2
indent = S.length key + 1 + S.length spaces
valSrc
| S.null bs3 = noIndent
| otherwise = yield bs3 >> loopIndent indent
noIndent = do
mx <- await
case mx of
Nothing -> return ()
Just bs -> do
let (spaces, val) = S.span (== _space) bs
if S.length spaces == 0
then leftover val
else do
yield val
loopIndent (S.length spaces)
loopIndent i =
loop
where
loop = await >>= maybe (return ()) go
go bs
| S.length spaces == i && S.all (== _space) spaces =
yield val >> loop
| otherwise = leftover bs
where
(spaces, val) = S.splitAt i bs
-- | General purpose utility
takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a
takeWhileC f =
loop
where
loop = await >>= maybe (return ()) go
go x
| f x = yield x >> loop
| otherwise = leftover x
stack-0.1.10.0/src/Stack/PackageIndex.hs 0000644 0000000 0000000 00000033366 12623647202 015754 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- | Dealing with the 00-index file and all its cabal files.
module Stack.PackageIndex
( updateAllIndices
, getPackageCaches
) where
import qualified Codec.Archive.Tar as Tar
import Control.Exception (Exception)
import Control.Exception.Enclosed (tryIO)
import Control.Monad (unless, when, liftM)
import Control.Monad.Catch (MonadThrow, throwM, MonadCatch)
import qualified Control.Monad.Catch as C
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logDebug,
logInfo, logWarn)
import Control.Monad.Reader (asks)
import Control.Monad.Trans.Control
import Data.Aeson.Extended
import Data.Binary.VersionTagged
import qualified Data.Word8 as Word8
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as SU
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Conduit (($$), (=$))
import Data.Conduit.Binary (sinkHandle,
sourceHandle)
import Data.Conduit.Zlib (ungzip)
import Data.Foldable (forM_)
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (forM)
import Data.Typeable (Typeable)
import Network.HTTP.Download
import Path (mkRelDir, parent,
parseRelDir, toFilePath,
parseAbsFile, ())
import Path.IO
import Prelude -- Fix AMP warning
import Stack.Types
import Stack.Types.StackT
import System.FilePath (takeBaseName, (<.>))
import System.IO (IOMode (ReadMode, WriteMode),
withBinaryFile)
import System.Process.Read (readInNull, EnvOverride, doesExecutableExist)
-- | Populate the package index caches and return them.
populateCache
:: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> PackageIndex
-> m (Map PackageIdentifier PackageCache)
populateCache menv index = do
requireIndex menv index
-- This uses full on lazy I/O instead of ResourceT to provide some
-- protections. Caveat emptor
path <- configPackageIndex (indexName index)
let loadPIS = do
$logSticky "Populating index cache ..."
lbs <- liftIO $ L.readFile $ Path.toFilePath path
loop 0 Map.empty (Tar.read lbs)
pis <- loadPIS `C.catch` \e -> do
$logWarn $ "Exception encountered when parsing index tarball: "
<> T.pack (show (e :: Tar.FormatError))
$logWarn "Automatically updating index and trying again"
updateIndex menv index
loadPIS
when (indexRequireHashes index) $ forM_ (Map.toList pis) $ \(ident, pc) ->
case pcDownload pc of
Just _ -> return ()
Nothing -> throwM $ MissingRequiredHashes (indexName index) ident
$logStickyDone "Populated index cache."
return pis
where
loop !blockNo !m (Tar.Next e es) =
loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es
loop _ m Tar.Done = return m
loop _ _ (Tar.Fail e) = throwM e
goE blockNo m e =
case Tar.entryContent e of
Tar.NormalFile lbs size ->
case parseNameVersion $ Tar.entryPath e of
Just (ident, ".cabal") -> addCabal ident size
Just (ident, ".json") -> addJSON ident lbs
_ -> m
_ -> m
where
addCabal ident size = Map.insertWith
(\_ pcOld -> pcNew { pcDownload = pcDownload pcOld })
ident
pcNew
m
where
pcNew = PackageCache
{ pcOffset = (blockNo + 1) * 512
, pcSize = size
, pcDownload = Nothing
}
addJSON ident lbs =
case decode lbs of
Nothing -> m
Just !pd -> Map.insertWith
(\_ pc -> pc { pcDownload = Just pd })
ident
PackageCache
{ pcOffset = 0
, pcSize = 0
, pcDownload = Just pd
}
m
breakSlash x
| S.null z = Nothing
| otherwise = Just (y, SU.unsafeTail z)
where
(y, z) = S.break (== Word8._slash) x
parseNameVersion t1 = do
(p', t3) <- breakSlash
$ S.map (\c -> if c == Word8._backslash then Word8._slash else c)
$ S8.pack t1
p <- parsePackageName p'
(v', t5) <- breakSlash t3
v <- parseVersion v'
let (t6, suffix) = S.break (== Word8._period) t5
if t6 == p'
then return (PackageIdentifier p v, suffix)
else Nothing
data PackageIndexException
= GitNotAvailable IndexName
| MissingRequiredHashes IndexName PackageIdentifier
deriving Typeable
instance Exception PackageIndexException
instance Show PackageIndexException where
show (GitNotAvailable name) = concat
[ "Package index "
, T.unpack $ indexNameText name
, " only provides Git access, and you do not have"
, " the git executable on your PATH"
]
show (MissingRequiredHashes name ident) = concat
[ "Package index "
, T.unpack $ indexNameText name
, " is configured to require package hashes, but no"
, " hash is available for "
, packageIdentifierString ident
]
-- | Require that an index be present, updating if it isn't.
requireIndex :: (MonadIO m,MonadLogger m
,MonadThrow m,MonadReader env m,HasHttpManager env
,HasConfig env,MonadBaseControl IO m,MonadCatch m)
=> EnvOverride
-> PackageIndex
-> m ()
requireIndex menv index = do
tarFile <- configPackageIndex $ indexName index
exists <- fileExists tarFile
unless exists $ updateIndex menv index
-- | Update all of the package indices
updateAllIndices
:: (MonadIO m,MonadLogger m
,MonadThrow m,MonadReader env m,HasHttpManager env
,HasConfig env,MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> m ()
updateAllIndices menv =
asks (configPackageIndices . getConfig) >>= mapM_ (updateIndex menv)
-- | Update the index tarball
updateIndex :: (MonadIO m,MonadLogger m
,MonadThrow m,MonadReader env m,HasHttpManager env
,HasConfig env,MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> PackageIndex
-> m ()
updateIndex menv index =
do let name = indexName index
logUpdate mirror = $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> mirror <> ") ..."
git <- isGitInstalled menv
case (git, indexLocation index) of
(True, ILGit url) -> logUpdate url >> updateIndexGit menv name index url
(True, ILGitHttp url _) -> logUpdate url >> updateIndexGit menv name index url
(_, ILHttp url) -> logUpdate url >> updateIndexHTTP name index url
(False, ILGitHttp _ url) -> logUpdate url >> updateIndexHTTP name index url
(False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name)
-- | Update the index Git repo and the index tarball
updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> IndexName
-> PackageIndex
-> Text -- ^ Git URL
-> m ()
updateIndexGit menv indexName' index gitUrl = do
tarFile <- configPackageIndex indexName'
let idxPath = parent tarFile
createTree idxPath
do
repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl
let cloneArgs =
["clone"
,T.unpack gitUrl
,toFilePath repoName
,"--depth"
,"1"
,"-b" --
,"display"]
sDir <- configPackageIndexRoot indexName'
let suDir =
sDir
$(mkRelDir "git-update")
acfDir = suDir repoName
repoExists <- dirExists acfDir
unless repoExists
(readInNull suDir "git" menv cloneArgs Nothing)
$logSticky "Fetching package index ..."
readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing
$logStickyDone "Fetched package index."
removeFileIfExists tarFile
when (indexGpgVerify index)
(readInNull acfDir
"git"
menv
["tag","-v","current-hackage"]
(Just (T.unlines ["Signature verification failed. "
,"Please ensure you've set up your"
,"GPG keychain to accept the D6CF60FD signing key."
,"For more information, see:"
,"https://github.com/fpco/stackage-update#readme"])))
$logDebug ("Exporting a tarball to " <>
(T.pack . toFilePath) tarFile)
deleteCache indexName'
let tarFileTmp = toFilePath tarFile ++ ".tmp"
readInNull acfDir
"git"
menv
["archive"
,"--format=tar"
,"-o"
,tarFileTmp
,"current-hackage"]
Nothing
tarFileTmpPath <- parseAbsFile tarFileTmp
renameFile tarFileTmpPath tarFile
-- | Update the index tarball via HTTP
updateIndexHTTP :: (MonadIO m,MonadLogger m
,MonadThrow m,MonadReader env m,HasHttpManager env,HasConfig env)
=> IndexName
-> PackageIndex
-> Text -- ^ url
-> m ()
updateIndexHTTP indexName' index url = do
req <- parseUrl $ T.unpack url
$logInfo ("Downloading package index from " <> url)
gz <- configPackageIndexGz indexName'
tar <- configPackageIndex indexName'
wasDownloaded <- redownload req gz
toUnpack <-
if wasDownloaded
then return True
else liftM not $ fileExists tar
when toUnpack $ do
let tmp = toFilePath tar <.> "tmp"
tmpPath <- parseAbsFile tmp
deleteCache indexName'
liftIO $ do
withBinaryFile (toFilePath gz) ReadMode $ \input ->
withBinaryFile tmp WriteMode $ \output ->
sourceHandle input
$$ ungzip
=$ sinkHandle output
renameFile tmpPath tar
when (indexGpgVerify index)
$ $logWarn
$ "You have enabled GPG verification of the package index, " <>
"but GPG verification only works with Git downloading"
-- | Is the git executable installed?
isGitInstalled :: MonadIO m
=> EnvOverride
-> m Bool
isGitInstalled = flip doesExecutableExist "git"
-- | Delete the package index cache
deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m) => IndexName -> m ()
deleteCache indexName' = do
fp <- configPackageIndexCache indexName'
eres <- liftIO $ tryIO $ removeFile fp
case eres of
Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)
Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp)
-- | Load the cached package URLs, or created the cache if necessary.
getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> m (Map PackageIdentifier (PackageIndex, PackageCache))
getPackageCaches menv = do
config <- askConfig
liftM mconcat $ forM (configPackageIndices config) $ \index -> do
fp <- configPackageIndexCache (indexName index)
PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index
return (fmap (index,) pis')
--------------- Lifted from cabal-install, Distribution.Client.Tar:
-- | Return the number of blocks in an entry.
entrySizeInBlocks :: Tar.Entry -> Int64
entrySizeInBlocks entry = 1 + case Tar.entryContent entry of
Tar.NormalFile _ size -> bytesToBlocks size
Tar.OtherEntryType _ _ size -> bytesToBlocks size
_ -> 0
where
bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)
stack-0.1.10.0/src/Stack/Ghci.hs 0000644 0000000 0000000 00000047575 12630352213 014303 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
-- | Run a GHCi configured with the user's package(s).
module Stack.Ghci
( GhciOpts(..)
, GhciPkgInfo(..)
, ghciSetup
, ghci
) where
import Control.Exception.Enclosed (tryAny)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.RWS.Strict
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import qualified Data.ByteString.Char8 as S8
import Data.Either
import Data.Function
import Data.List
import Data.List.Extra (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Maybe.Extra (forMaybeM)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Distribution.ModuleName (ModuleName)
import Distribution.Text (display)
import Network.HTTP.Client.Conduit
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Prelude
import Stack.Build
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Build.Target
import Stack.Constants
import Stack.Exec
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Directory (getTemporaryDirectory)
-- | Command-line options for GHC.
data GhciOpts = GhciOpts
{ ghciNoBuild :: !Bool
, ghciArgs :: ![String]
, ghciGhcCommand :: !(Maybe FilePath)
, ghciNoLoadModules :: !Bool
, ghciAdditionalPackages :: ![String]
, ghciMainIs :: !(Maybe Text)
, ghciSkipIntermediate :: !Bool
, ghciBuildOpts :: !BuildOpts
} deriving Show
-- | Necessary information to load a package or its components.
data GhciPkgInfo = GhciPkgInfo
{ ghciPkgName :: !PackageName
, ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]
, ghciPkgDir :: !(Path Abs Dir)
, ghciPkgModules :: !(Set ModuleName)
, ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths.
, ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files.
, ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File)))
, ghciPkgPackage :: !Package
} deriving Show
-- | Launch a GHCi session for the given local package targets with the
-- given options and configure it with the load paths and extensions
-- of those targets.
ghci
:: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)
=> GhciOpts -> m ()
ghci GhciOpts{..} = do
let bopts = ghciBuildOpts
{ boptsTestOpts = (boptsTestOpts ghciBuildOpts) { toDisableRun = True }
, boptsBenchmarkOpts = (boptsBenchmarkOpts ghciBuildOpts) { beoDisableRun = True }
}
(targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciSkipIntermediate ghciMainIs
config <- asks getConfig
bconfig <- asks getBuildConfig
mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs
wc <- getWhichCompiler
let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts
hidePkgOpt = if null pkgs then [] else ["-hide-all-packages"]
genOpts = nubOrd (concatMap (concatMap (bioOneWordOpts . snd) . ghciPkgOpts) pkgs)
(omittedOpts, ghcOpts) = partition badForGhci $
concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++
getUserOptions Nothing ++
concatMap (getUserOptions . Just . ghciPkgName) pkgs
getUserOptions mpkg =
map T.unpack (M.findWithDefault [] mpkg (configGhcOptions config))
badForGhci x =
isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror")
unless (null omittedOpts) $
$logWarn
("The following GHC options are incompatible with GHCi and have not been passed to it: " <>
T.unwords (map T.pack (nubOrd omittedOpts)))
oiDir <- objectInterfaceDir bconfig
let modulesToLoad = nubOrd $
concatMap (map display . S.toList . ghciPkgModules) pkgs
thingsToLoad =
maybe [] (return . toFilePath) mainFile <> modulesToLoad
odir =
[ "-odir=" <> toFilePathNoTrailingSep oiDir
, "-hidir=" <> toFilePathNoTrailingSep oiDir ]
$logInfo
("Configuring GHCi with the following packages: " <>
T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))
let execGhci extras = do
menv <- liftIO $ configEnvOverride config defaultEnvSettings
exec menv
(fromMaybe (compilerExeName wc) ghciGhcCommand)
("--interactive" :
-- This initial "-i" resets the include directories to not
-- include CWD.
"-i" :
odir <> pkgopts <> ghciArgs <> extras)
tmp <- liftIO getTemporaryDirectory
withCanonicalizedTempDirectory tmp "ghci" $ \tmpDir -> do
let macrosFile = tmpDir $(mkRelFile "cabal_macros.h")
macrosOpts <- preprocessCabalMacros pkgs macrosFile
if ghciNoLoadModules
then execGhci macrosOpts
else do
let scriptPath = tmpDir $(mkRelFile "ghci-script")
fp = toFilePath scriptPath
loadModules = ":load " <> unwords (map show thingsToLoad)
bringIntoScope = ":module + " <> unwords modulesToLoad
liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))
execGhci (macrosOpts ++ ["-ghci-script=" <> fp])
-- | Figure out the main-is file to load based on the targets. Sometimes there
-- is none, sometimes it's unambiguous, sometimes it's
-- ambiguous. Warns and returns nothing if it's ambiguous.
figureOutMainFile
:: (Monad m, MonadLogger m)
=> BuildOpts
-> Maybe (Map PackageName SimpleTarget)
-> Map PackageName SimpleTarget
-> [GhciPkgInfo]
-> m (Maybe (Path Abs File))
figureOutMainFile bopts mainIsTargets targets0 packages =
case candidates of
[] -> return Nothing
[c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c)
return (Just fp)
candidate:_ -> borderedWarning $ do
$logWarn "The main module to load is ambiguous. Candidates are: "
forM_ (map renderCandidate candidates) $logWarn
$logWarn
"None will be loaded. You can specify which one to pick by: "
$logWarn
(" 1) Specifying targets to stack ghci e.g. stack ghci " <>
sampleTargetArg candidate)
$logWarn
(" 2) Specifying what the main is e.g. stack ghci " <>
sampleMainIsArg candidate)
return Nothing
where
targets = fromMaybe targets0 mainIsTargets
candidates = do
pkg <- packages
case M.lookup (ghciPkgName pkg) targets of
Nothing -> []
Just target -> do
(component,mains) <-
M.toList $
M.filterWithKey (\k _ -> k `S.member` wantedComponents)
(ghciPkgMainIs pkg)
main <- S.toList mains
return (ghciPkgName pkg, component, main)
where
wantedComponents =
wantedPackageComponents bopts target (ghciPkgPackage pkg)
renderCandidate (pkgName,namedComponent,mainIs) =
"Package `" <> packageNameText pkgName <> "' component " <>
renderComp namedComponent <>
" with main-is file: " <>
T.pack (toFilePath mainIs)
renderComp c =
case c of
CLib -> "lib"
CExe name -> "exe:" <> name
CTest name -> "test:" <> name
CBench name -> "bench:" <> name
sampleTargetArg (pkg,comp,_) =
packageNameText pkg <> ":" <> renderComp comp
sampleMainIsArg (pkg,comp,_) =
"--main-is " <> packageNameText pkg <> ":" <> renderComp comp
-- | Create a list of infos for each target containing necessary
-- information to load that package/components.
ghciSetup
:: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)
=> BuildOpts
-> Bool
-> Bool
-> Maybe Text
-> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])
ghciSetup bopts noBuild skipIntermediate mainIs = do
(_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts
mainIsTargets <-
case mainIs of
Nothing -> return Nothing
Just target -> do
(_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts { boptsTargets = [target] }
return (Just targets')
econfig <- asks getEnvConfig
(realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts
menv <- getMinimalEnvOverride
(installedMap, _, _, _) <- getInstalled
menv
GetInstalledOpts
{ getInstalledProfiling = False
, getInstalledHaddock = False
}
sourceMap
directlyWanted <-
forMaybeM (M.toList (envConfigPackages econfig)) $
\(dir,validWanted) ->
do cabalfp <- getCabalFileName dir
name <- parsePackageNameFromFilePath cabalfp
if validWanted
then case M.lookup name targets of
Just simpleTargets ->
return (Just (name, (cabalfp, simpleTargets)))
Nothing -> return Nothing
else return Nothing
let intermediateDeps = getIntermediateDeps sourceMap directlyWanted
wanted <-
if skipIntermediate || null intermediateDeps
then return directlyWanted
else do
$logInfo $ T.concat
[ "The following libraries will also be loaded into GHCi because "
, "they are intermediate dependencies of your targets:\n "
, T.intercalate ", " (map (packageNameText . fst) intermediateDeps)
, "\n(Use --skip-intermediate-deps to omit these)"
]
return (directlyWanted ++ intermediateDeps)
-- Try to build, but optimistically launch GHCi anyway if it fails (#1065)
unless noBuild $ do
eres <- tryAny $ build (const (return ())) Nothing bopts
case eres of
Right () -> return ()
Left err -> do
$logError $ T.pack (show err)
$logWarn "Warning: build failed, but optimistically launching GHCi anyway"
-- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180)
let localLibs = [name | (name, (_, target)) <- wanted , hasLocalComp isCLib target]
infos <-
forM wanted $
\(name,(cabalfp,target)) ->
makeGhciPkgInfo bopts sourceMap installedMap localLibs name cabalfp target
checkForIssues infos
return (realTargets, mainIsTargets, infos)
where
hasLocalComp p t =
case t of
STLocalComps s -> any p (S.toList s)
STLocalAll -> True
_ -> False
-- | Make information necessary to load the given package in GHCi.
makeGhciPkgInfo
:: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m)
=> BuildOpts
-> SourceMap
-> InstalledMap
-> [PackageName]
-> PackageName
-> Path Abs File
-> SimpleTarget
-> m GhciPkgInfo
makeGhciPkgInfo bopts sourceMap installedMap locals name cabalfp target = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
let config =
PackageConfig
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = True
, packageConfigFlags = localFlags (boptsFlags bopts) bconfig name
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform (getConfig bconfig)
}
(warnings,pkg) <- readPackage config cabalfp
mapM_ (printCabalFileWarning cabalfp) warnings
(mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp
let filteredOpts = filterWanted opts
filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted)
allWanted = wantedPackageComponents bopts target pkg
setMapMaybe f = S.fromList . mapMaybe f . S.toList
return
GhciPkgInfo
{ ghciPkgName = packageName pkg
, ghciPkgOpts = M.toList filteredOpts
, ghciPkgDir = parent cabalfp
, ghciPkgModules = mconcat (M.elems (filterWanted mods))
, ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files)))
, ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files
, ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files)))
, ghciPkgPackage = pkg
}
-- NOTE: this should make the same choices as the components code in
-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic
-- (differently).
wantedPackageComponents :: BuildOpts -> SimpleTarget -> Package -> Set NamedComponent
wantedPackageComponents _ (STLocalComps cs) _ = cs
wantedPackageComponents bopts STLocalAll pkg = S.fromList $
(if packageHasLibrary pkg then [CLib] else []) ++
map CExe (S.toList (packageExes pkg)) <>
(if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <>
(if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else [])
wantedPackageComponents _ _ _ = S.empty
checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m ()
checkForIssues pkgs = do
unless (null issues) $ borderedWarning $ do
$logWarn "There are issues with this project which may prevent GHCi from working properly."
$logWarn ""
mapM_ $logWarn $ intercalate [""] issues
$logWarn ""
$logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files."
$logWarn ""
$logWarn "It isn't yet possible to load multiple packages into GHCi in all cases - see"
$logWarn "https://ghc.haskell.org/trac/ghc/ticket/10827"
where
issues = concat
[ mixedFlag "-XNoImplicitPrelude"
[ "-XNoImplicitPrelude will be used, but GHCi will likely fail to build things which depend on the implicit prelude." ]
, mixedFlag "-XCPP"
[ "-XCPP will be used, but it can cause issues with multiline strings."
, "See https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps"
]
, mixedFlag "-XNoTraditionalRecordSyntax"
[ "-XNoTraditionalRecordSyntax will be used, but it break modules which use record syntax." ]
, mixedFlag "-XTemplateHaskell"
[ "-XTemplateHaskell will be used, but it may cause compilation issues due to different parsing of '$' when there's no space after it." ]
, mixedFlag "-XQuasiQuotes"
[ "-XQuasiQuotes will be used, but it may cause parse failures due to a different meaning for list comprehension syntax like [x| ... ]" ]
, mixedFlag "-XSafe"
[ "-XSafe will be used, but it will fail to compile unsafe modules." ]
, mixedFlag "-XArrows"
[ "-XArrows will be used, but it will cause non-arrow usages of proc, (-<), (-<<) to fail" ]
, mixedFlag "-XOverloadedStrings"
[ "-XOverloadedStrings will be used, but it can cause type ambiguity in code not usually compiled with it." ]
, mixedFlag "-XOverloadedLists"
[ "-XOverloadedLists will be used, but it can cause type ambiguity in code not usually compiled with it." ]
, mixedFlag "-XMonoLocalBinds"
[ "-XMonoLocalBinds will be used, but it can cause type errors in code which expects generalized local bindings." ]
, mixedFlag "-XTypeFamilies"
[ "-XTypeFamilies will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ]
, mixedFlag "-XGADTs"
[ "-XGADTs will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ]
, mixedFlag "-XNewQualifiedOperators"
[ "-XNewQualifiedOperators will be used, but this will break usages of the old qualified operator syntax." ]
]
mixedFlag flag msgs =
let x = partitionComps (== flag) in
[ msgs ++ showWhich x | mixedSettings x ]
mixedSettings (xs, ys) = xs /= [] && ys /= []
showWhich (haveIt, don'tHaveIt) =
[ "It is specified for:"
, " " <> renderPkgComponents haveIt
, "But not for: "
, " " <> renderPkgComponents don'tHaveIt
]
partitionComps f = (map fst xs, map fst ys)
where
(xs, ys) = partition (any f . snd) compsWithOpts
compsWithOpts = map (\(k, bio) -> (k, bioOneWordOpts bio ++ bioOpts bio)) compsWithBios
compsWithBios =
[ ((ghciPkgName pkg, c), bio)
| pkg <- pkgs
, (c, bio) <- ghciPkgOpts pkg
]
borderedWarning :: MonadLogger m => m a -> m a
borderedWarning f = do
$logWarn ""
$logWarn "* * * * * * * *"
x <- f
$logWarn "* * * * * * * *"
$logWarn ""
return x
-- Adds in intermediate dependencies between ghci targets. Note that it
-- will return a Lib component for these intermediate dependencies even
-- if they don't have a library (but that's fine for the usage within
-- this module).
getIntermediateDeps
:: SourceMap
-> [(PackageName, (Path Abs File, SimpleTarget))]
-> [(PackageName, (Path Abs File, SimpleTarget))]
getIntermediateDeps sourceMap targets =
M.toList $
(\mp -> foldl' (flip M.delete) mp (map fst targets)) $
M.mapMaybe id $
execState (mapM_ (mapM_ go . getDeps . fst) targets)
(M.fromList (map (\(k, x) -> (k, Just x)) targets))
where
getDeps :: PackageName -> [PackageName]
getDeps name =
case M.lookup name sourceMap of
Just (PSLocal lp) -> M.keys (packageDeps (lpPackage lp))
_ -> []
go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, SimpleTarget))) Bool
go name = do
cache <- get
case (M.lookup name cache, M.lookup name sourceMap) of
(Just (Just _), _) -> return True
(Just Nothing, _) -> return False
(_, Just (PSLocal lp)) -> do
let deps = M.keys (packageDeps (lpPackage lp))
isIntermediate <- liftM or $ mapM go deps
if isIntermediate
then do
modify (M.insert name (Just (lpCabalFile lp, STLocalComps (S.singleton CLib))))
return True
else do
modify (M.insert name Nothing)
return False
(_, Just PSUpstream{}) -> return False
(Nothing, Nothing) -> return False
preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String]
preprocessCabalMacros pkgs out = liftIO $ do
let fps = nubOrd (concatMap (catMaybes . map (bioCabalMacros . snd) . ghciPkgOpts) pkgs)
files <- mapM (S8.readFile . toFilePath) fps
if null files then return [] else do
S8.writeFile (toFilePath out) $ S8.intercalate "\n#undef CURRENT_PACKAGE_KEY\n" files
return ["-optP-include", "-optP" <> toFilePath out]
stack-0.1.10.0/src/Stack/Ide.hs 0000644 0000000 0000000 00000010433 12630352213 014111 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- | Run a IDE configured with the user's package(s).
module Stack.Ide
(ide, getPackageOptsAndTargetFiles)
where
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Set as S
import Data.Text (Text)
import Distribution.System
import Network.HTTP.Client.Conduit
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Stack.Constants
import Stack.Ghci (GhciPkgInfo(..), ghciSetup)
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Environment (lookupEnv)
import System.FilePath (searchPathSeparator)
import System.Process.Run
-- | Launch a GHCi IDE for the given local project targets with the
-- given options and configure it with the load paths and extensions
-- of those targets.
ide
:: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m, HasHttpManager r)
=> [Text] -- ^ Targets.
-> [String] -- ^ GHC options.
-> m ()
ide targets useropts = do
let bopts = defaultBuildOpts
{ boptsTargets = targets
, boptsBuildSubset = BSOnlyDependencies
}
(_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing
pwd <- getWorkingDir
(pkgopts,_srcfiles) <-
liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd
localdb <- packageDatabaseLocal
depsdb <- packageDatabaseDeps
mpath <- liftIO $ lookupEnv "PATH"
bindirs <- extraBinDirs `ap` return True {- include local bin -}
let pkgdbs =
["--package-db=" <> toFilePathNoTrailingSep depsdb <> [searchPathSeparator] <> toFilePathNoTrailingSep localdb]
paths =
[ "--ide-backend-tools-path=" <>
intercalate [searchPathSeparator] (map toFilePath bindirs) <>
maybe "" (searchPathSeparator :) mpath]
args =
["--verbose"] <> ["--include=" <> includeDirs pkgopts] <>
["--local-work-dir=" ++ toFilePathNoTrailingSep pwd] <>
map ("--ghc-option=" ++) useropts <>
paths <>
pkgopts <>
pkgdbs
menv <- getMinimalEnvOverride
Platform _ os <- asks getPlatform
when
(os == OSX)
(catch (callProcess (Cmd (Just pwd) "stty" menv ["cbreak", "-imaxbel"]))
(\(_ :: ProcessExitedUnsuccessfully) -> return ()))
callProcess (Cmd (Just pwd) "stack-ide" menv args)
where
includeDirs pkgopts =
intercalate
[searchPathSeparator]
(mapMaybe
(stripPrefix "--ghc-option=-i")
pkgopts)
-- | Get options and target files for the given package info.
getPackageOptsAndTargetFiles
:: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)
=> Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath])
getPackageOptsAndTargetFiles pwd pkg = do
dist <- distDirFromDir (ghciPkgDir pkg)
let autogen = autogenDir dist
paths_foo <-
liftM
(autogen )
(parseRelFile
("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs"))
paths_foo_exists <- fileExists paths_foo
let ghcOptions bio =
bioOneWordOpts bio ++
bioOpts bio ++
maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio)
return
( ("--dist-dir=" <> toFilePathNoTrailingSep dist) :
map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg))
, mapMaybe
(fmap toFilePath . stripDir pwd)
(S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <>
[paths_foo | paths_foo_exists]))
stack-0.1.10.0/src/Stack/Image.hs 0000644 0000000 0000000 00000020273 12630352213 014435 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module builds Docker (OpenContainer) images.
module Stack.Image
(stageContainerImageArtifacts, createContainerImageFromStage,
imgCmdName, imgDockerCmdName, imgOptsFromMonoid,
imgDockerOptsFromMonoid, imgOptsParser, imgDockerOptsParser)
where
import Control.Applicative
import Control.Exception.Lifted hiding (finally)
import Control.Monad
import Control.Monad.Catch hiding (bracket)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Typeable
import Options.Applicative
import Path
import Path.Extra
import Path.IO
import Stack.Constants
import Stack.Types
import Stack.Types.Internal
import System.Process.Run
type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m)
type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)
-- | Stages the executables & additional content in a staging
-- directory under '.stack-work'
stageContainerImageArtifacts :: Build e m => m ()
stageContainerImageArtifacts = do
imageDir <- getWorkingDir >>= imageStagingDir
removeTreeIfExists imageDir
createTree imageDir
stageExesInDir imageDir
syncAddContentToDir imageDir
-- | Builds a Docker (OpenContainer) image extending the `base` image
-- specified in the project's stack.yaml. Then new image will be
-- extended with an ENTRYPOINT specified for each `entrypoint` listed
-- in the config file.
createContainerImageFromStage :: Assemble e m => m ()
createContainerImageFromStage = do
imageDir <- getWorkingDir >>= imageStagingDir
createDockerImage imageDir
extendDockerImageWithEntrypoint imageDir
-- | Stage all the Package executables in the usr/local/bin
-- subdirectory of a temp directory.
stageExesInDir :: Build e m => Path Abs Dir -> m ()
stageExesInDir dir = do
srcBinPath <-
( $(mkRelDir "bin")) <$>
installationRootLocal
let destBinPath = dir
$(mkRelDir "usr/local/bin")
createTree destBinPath
copyDirectoryRecursive srcBinPath destBinPath
-- | Add any additional files into the temp directory, respecting the
-- (Source, Destination) mapping.
syncAddContentToDir :: Build e m => Path Abs Dir -> m ()
syncAddContentToDir dir = do
config <- asks getConfig
bconfig <- asks getBuildConfig
let imgAdd = maybe Map.empty imgDockerAdd (imgDocker (configImage config))
forM_
(Map.toList imgAdd)
(\(source,dest) ->
do sourcePath <- parseRelDir source
destPath <- parseAbsDir dest
let destFullPath = dir dropRoot destPath
createTree destFullPath
copyDirectoryRecursive
(bcRoot bconfig sourcePath)
destFullPath)
-- | Derive an image name from the project directory.
imageName :: Path Abs Dir -> String
imageName = map toLower . toFilePathNoTrailingSep . dirname
-- | Create a general purpose docker image from the temporary
-- directory of executables & static content.
createDockerImage :: Assemble e m => Path Abs Dir -> m ()
createDockerImage dir = do
menv <- getMinimalEnvOverride
config <- asks getConfig
let dockerConfig = imgDocker (configImage config)
case imgDockerBase =<< dockerConfig of
Nothing -> throwM StackImageDockerBaseUnspecifiedException
Just base -> do
liftIO
(writeFile
(toFilePath
(dir
$(mkRelFile "Dockerfile")))
(unlines ["FROM " ++ base, "ADD ./ /"]))
let args = [ "build"
, "-t"
, fromMaybe
(imageName (parent (parent dir)))
(imgDockerImageName =<< dockerConfig)
, toFilePathNoTrailingSep dir]
callProcess $ Cmd Nothing "docker" menv args
-- | Extend the general purpose docker image with entrypoints (if
-- specified).
extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m ()
extendDockerImageWithEntrypoint dir = do
menv <- getMinimalEnvOverride
config <- asks getConfig
let dockerConfig = imgDocker (configImage config)
let dockerImageName = fromMaybe
(imageName (parent (parent dir)))
(imgDockerImageName =<< dockerConfig)
let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig
case imgEntrypoints of
Nothing -> return ()
Just eps ->
forM_
eps
(\ep -> do
liftIO
(writeFile
(toFilePath
(dir
$(mkRelFile "Dockerfile")))
(unlines
[ "FROM " ++ dockerImageName
, "ENTRYPOINT [\"/usr/local/bin/" ++
ep ++ "\"]"
, "CMD []"]))
callProcess $ Cmd
Nothing
"docker"
menv
[ "build"
, "-t"
, dockerImageName ++ "-" ++ ep
, toFilePathNoTrailingSep dir])
-- | The command name for dealing with images.
imgCmdName :: String
imgCmdName = "image"
-- | The command name for building a docker container.
imgDockerCmdName :: String
imgDockerCmdName = "container"
-- | A parser for ImageOptsMonoid.
imgOptsParser :: Parser ImageOptsMonoid
imgOptsParser = ImageOptsMonoid <$>
optional
(subparser
(command
imgDockerCmdName
(info
imgDockerOptsParser
(progDesc "Create a container image (EXPERIMENTAL)"))))
-- | A parser for ImageDockerOptsMonoid.
imgDockerOptsParser :: Parser ImageDockerOptsMonoid
imgDockerOptsParser = ImageDockerOptsMonoid <$>
optional
(option
str
(long (imgDockerCmdName ++ "-" ++ T.unpack imgDockerBaseArgName) <>
metavar "NAME" <>
help "Docker base image name")) <*>
pure Nothing <*>
pure Nothing <*>
pure Nothing
-- | Convert image opts monoid to image options.
imgOptsFromMonoid :: ImageOptsMonoid -> ImageOpts
imgOptsFromMonoid ImageOptsMonoid{..} = ImageOpts
{ imgDocker = imgDockerOptsFromMonoid <$> imgMonoidDocker
}
-- | Convert Docker image opts monoid to Docker image options.
imgDockerOptsFromMonoid :: ImageDockerOptsMonoid -> ImageDockerOpts
imgDockerOptsFromMonoid ImageDockerOptsMonoid{..} = ImageDockerOpts
{ imgDockerBase = emptyToNothing imgDockerMonoidBase
, imgDockerEntrypoints = emptyToNothing imgDockerMonoidEntrypoints
, imgDockerAdd = fromMaybe Map.empty imgDockerMonoidAdd
, imgDockerImageName = emptyToNothing imgDockerMonoidImageName
}
where emptyToNothing Nothing = Nothing
emptyToNothing (Just s)
| null s =
Nothing
| otherwise =
Just s
-- | Stack image exceptions.
data StackImageException =
StackImageDockerBaseUnspecifiedException
deriving (Typeable)
instance Exception StackImageException
instance Show StackImageException where
show StackImageDockerBaseUnspecifiedException = "You must specify a base docker image on which to place your haskell executables."
stack-0.1.10.0/src/Stack/SDist.hs 0000644 0000000 0000000 00000035254 12630352213 014446 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- Create a source distribution tarball
module Stack.SDist
( getSDistTarball
, checkSDistTarball
, checkSDistTarball'
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Concurrent.Execute (ActionContext(..))
import Control.Monad (unless, void, liftM)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (liftBaseWith)
import Control.Monad.Trans.Resource
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Data (Data, Typeable, cast, gmapT)
import Data.Either (partitionEithers)
import Data.List
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX
import Distribution.Package (Dependency (..))
import qualified Distribution.PackageDescription.Check as Check
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion)
import Distribution.Version.Extra
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Prelude -- Fix redundant import warnings
import Stack.Build (mkBaseConfigOpts)
import Stack.Build.Execute
import Stack.Build.Installed
import Stack.Build.Source (loadSourceMap, getPackageConfig)
import Stack.Build.Target
import Stack.Constants
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Directory (getModificationTime, getPermissions, Permissions(..))
import System.IO.Temp (withSystemTempDirectory)
import qualified System.FilePath as FP
-- | Special exception to throw when you want to fail because of bad results
-- of package check.
data CheckException
= CheckException (NonEmpty Check.PackageCheck)
deriving (Typeable)
instance Exception CheckException
instance Show CheckException where
show (CheckException xs) =
"Package check reported the following errors:\n" ++
(intercalate "\n" . fmap show . NE.toList $ xs)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
-- | Given the path to a local package, creates its source
-- distribution tarball.
--
-- While this yields a 'FilePath', the name of the tarball, this
-- tarball is not written to the disk and instead yielded as a lazy
-- bytestring.
getSDistTarball
:: M env m
=> Maybe PvpBounds -- ^ Override Config value
-> Path Abs Dir -- ^ Path to local package
-> m (FilePath, L.ByteString) -- ^ Filename and tarball contents
getSDistTarball mpvpBounds pkgDir = do
config <- asks getConfig
let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds
tweakCabal = pvpBounds /= PvpBoundsNone
pkgFp = toFilePath pkgDir
lp <- readLocalPackage pkgDir
$logInfo $ "Getting file list for " <> T.pack pkgFp
(fileList, cabalfp) <- getSDistFileList lp
$logInfo $ "Building sdist tarball for " <> T.pack pkgFp
files <- normalizeTarballPaths (lines fileList)
-- NOTE: Could make this use lazy I/O to only read files as needed
-- for upload (both GZip.compress and Tar.write are lazy).
-- However, it seems less error prone and more predictable to read
-- everything in at once, so that's what we're doing for now:
let tarPath isDir fp = either error id
(Tar.toTarPath isDir (pkgId FP. fp))
packWith f isDir fp = liftIO $ f (pkgFp FP. fp) (tarPath isDir fp)
packDir = packWith Tar.packDirectoryEntry True
packFile fp
| tweakCabal && isCabalFp fp = do
lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp
return $ Tar.fileEntry (tarPath False fp) lbs
| otherwise = packWith packFileEntry False fp
isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp
tarName = pkgId FP.<.> "tar.gz"
pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))
dirEntries <- mapM packDir (dirsFromFiles files)
fileEntries <- mapM packFile files
return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))
-- | Get the PVP bounds-enabled version of the given cabal file
getCabalLbs :: M env m => PvpBounds -> FilePath -> m L.ByteString
getCabalLbs pvpBounds fp = do
bs <- liftIO $ S.readFile fp
(_warnings, gpd) <- readPackageUnresolvedBS Nothing bs
(_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOpts
menv <- getMinimalEnvOverride
(installedMap, _, _, _) <- getInstalled menv GetInstalledOpts
{ getInstalledProfiling = False
, getInstalledHaddock = False
}
sourceMap
let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd
return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'
where
addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency
addBounds sourceMap installedMap dep@(Dependency cname range) =
case lookupVersion (fromCabalPackageName cname) of
Nothing -> dep
Just version -> Dependency cname $ simplifyVersionRange
$ (if toAddUpper && not (hasUpper range) then addUpper version else id)
$ (if toAddLower && not (hasLower range) then addLower version else id)
range
where
lookupVersion name =
case Map.lookup name sourceMap of
Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp
Just (PSUpstream version _ _) -> Just version
Nothing ->
case Map.lookup name installedMap of
Just (_, installed) -> Just (installedVersion installed)
Nothing -> Nothing
addUpper version = intersectVersionRanges
(earlierVersion $ toCabalVersion $ nextMajorVersion version)
addLower version = intersectVersionRanges
(orLaterVersion (toCabalVersion version))
(toAddLower, toAddUpper) =
case pvpBounds of
PvpBoundsNone -> (False, False)
PvpBoundsUpper -> (False, True)
PvpBoundsLower -> (True, False)
PvpBoundsBoth -> (True, True)
-- | Traverse a data type.
gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT f =
gmapT (\x -> case cast x of
Nothing -> gtraverseT f x
Just b -> fromMaybe x (cast (f b)))
-- | Read in a 'LocalPackage' config. This makes some default decisions
-- about 'LocalPackage' fields that might not be appropriate for other
-- use-cases.
readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage
readLocalPackage pkgDir = do
cabalfp <- getCabalFileName pkgDir
name <- parsePackageNameFromFilePath cabalfp
config <- getPackageConfig defaultBuildOpts name
(warnings,package) <- readPackage config cabalfp
mapM_ (printCabalFileWarning cabalfp) warnings
return LocalPackage
{ lpPackage = package
, lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file.
, lpDir = pkgDir
, lpCabalFile = cabalfp
-- NOTE: these aren't the 'correct values, but aren't used in
-- the usage of this function in this module.
, lpTestDeps = Map.empty
, lpBenchDeps = Map.empty
, lpTestBench = Nothing
, lpDirtyFiles = Just Set.empty
, lpNewBuildCache = Map.empty
, lpFiles = Set.empty
, lpComponents = Set.empty
, lpUnbuildable = Set.empty
}
-- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.
getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File)
getSDistFileList lp =
withCanonicalizedSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do
menv <- getMinimalEnvOverride
let bopts = defaultBuildOpts
baseConfigOpts <- mkBaseConfigOpts bopts
(_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets bopts
runInBase <- liftBaseWith $ \run -> return (void . run)
withExecuteEnv menv bopts baseConfigOpts locals
[] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files
$ \ee ->
withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do
let outFile = toFilePath tmpdir FP. "source-files-list"
cabal False ["sdist", "--list-sources", outFile]
contents <- liftIO (readFile outFile)
return (contents, cabalfp)
where
package = lpPackage lp
ac = ActionContext Set.empty
task = Task
{ taskProvides = PackageIdentifier (packageName package) (packageVersion package)
, taskType = TTLocal lp
, taskConfigOpts = TaskConfigOpts
{ tcoMissing = Set.empty
, tcoOpts = \_ -> ConfigureOpts [] []
}
, taskPresent = Map.empty
, taskAllInOne = True
}
normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]
normalizeTarballPaths fps = do
-- TODO: consider whether erroring out is better - otherwise the
-- user might upload an incomplete tar?
unless (null outsideDir) $
$logWarn $ T.concat
[ "Warning: These files are outside of the package directory, and will be omitted from the tarball: "
, T.pack (show outsideDir)]
return files
where
(outsideDir, files) = partitionEithers (map pathToEither fps)
pathToEither fp = maybe (Left fp) Right (normalizePath fp)
normalizePath :: FilePath -> Maybe FilePath
normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise
where
go [] = Just []
go ("..":_) = Nothing
go (_:"..":xs) = go xs
go (x:xs) = (x :) <$> go xs
dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles dirs = Set.toAscList (Set.delete "." results)
where
results = foldl' (\s -> go s . FP.takeDirectory) Set.empty dirs
go s x
| Set.member x s = s
| otherwise = go (Set.insert x s) (FP.takeDirectory x)
-- | Check package in given tarball. This will log all warnings
-- and will throw an exception in case of critical errors.
--
-- Note that we temporarily decompress the archive to analyze it.
checkSDistTarball :: (MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
=> Path Abs File -- ^ Absolute path to tarball
-> m ()
checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do
pkgDir <- (pkgDir' ) `liftM`
(parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)
-- ^ drop ".tar" ^ drop ".gz"
cabalfp <- getCabalFileName pkgDir
name <- parsePackageNameFromFilePath cabalfp
config <- getPackageConfig defaultBuildOpts name
(gdesc, pkgDesc) <- readPackageDescriptionDir config pkgDir
$logInfo $
"Checking package '" <> packageNameText name <> "' for common mistakes"
let pkgChecks = Check.checkPackage gdesc (Just pkgDesc)
fileChecks <- liftIO $ Check.checkPackageFiles pkgDesc (toFilePath pkgDir)
let checks = pkgChecks ++ fileChecks
(errors, warnings) =
let criticalIssue (Check.PackageBuildImpossible _) = True
criticalIssue (Check.PackageDistInexcusable _) = True
criticalIssue _ = False
in partition criticalIssue checks
unless (null warnings) $
$logWarn $ "Package check reported the following warnings:\n" <>
T.pack (intercalate "\n" . fmap show $ warnings)
case NE.nonEmpty errors of
Nothing -> return ()
Just ne -> throwM $ CheckException ne
-- | Version of 'checkSDistTarball' that first saves lazy bytestring to
-- temporary directory and then calls 'checkSDistTarball' on it.
checkSDistTarball' :: (MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
=> String -- ^ Tarball name
-> L.ByteString -- ^ Tarball contents as a byte string
-> m ()
checkSDistTarball' name bytes = withSystemTempDirectory "stack" $ \tdir -> do
tpath <- parseAbsDir tdir
npath <- (tpath ) `liftM` parseRelFile name
liftIO $ L.writeFile (toFilePath npath) bytes
checkSDistTarball npath
withTempTarGzContents :: (MonadIO m, MonadMask m, MonadThrow m)
=> Path Abs File -- ^ Location of tarball
-> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents
-> m a
withTempTarGzContents apath f = withSystemTempDirectory "stack" $ \tdir -> do
tpath <- parseAbsDir tdir
archive <- liftIO $ L.readFile (toFilePath apath)
liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive
f tpath
--------------------------------------------------------------------------------
-- Copy+modified from the tar package to avoid issues with lazy IO ( see
-- https://github.com/commercialhaskell/stack/issues/1344 )
packFileEntry :: FilePath -- ^ Full path to find the file on the local disk
-> Tar.TarPath -- ^ Path to use for the tar Entry in the archive
-> IO Tar.Entry
packFileEntry filepath tarpath = do
mtime <- getModTime filepath
perms <- getPermissions filepath
content <- S.readFile filepath
let size = fromIntegral (S.length content)
return (Tar.simpleEntry tarpath (Tar.NormalFile (L.fromStrict content) size)) {
Tar.entryPermissions = if executable perms then Tar.executableFilePermissions
else Tar.ordinaryFilePermissions,
Tar.entryTime = mtime
}
getModTime :: FilePath -> IO Tar.EpochTime
getModTime path = do
t <- getModificationTime path
return . floor . utcTimeToPOSIXSeconds $ t
stack-0.1.10.0/src/Stack/Setup.hs 0000644 0000000 0000000 00000176501 12630352213 014521 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
module Stack.Setup
( setupEnv
, ensureCompiler
, ensureDockerStackExe
, SetupOpts (..)
, defaultStackSetupYaml
) where
import Control.Applicative
import Control.Exception.Enclosed (catchIO, tryAny)
import Control.Monad (liftM, when, join, void, unless)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Control.Monad.State (get, put, modify)
import Control.Monad.Trans.Control
import "cryptohash" Crypto.Hash (SHA1(SHA1))
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isSpace)
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import qualified Data.Conduit.Binary as CB
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Foldable hiding (concatMap, or, maximum)
import Data.IORef
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (concat, elem, maximumBy, any)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import qualified Data.Yaml as Yaml
import Distribution.System (OS, Arch (..), Platform (..))
import qualified Distribution.System as Cabal
import Distribution.Text (simpleParse)
import Language.Haskell.TH as TH
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import qualified Paths_stack as Meta
import Prelude hiding (concat, elem, any) -- Fix AMP warning
import Safe (readMay)
import Stack.Build (build)
import Stack.Config (resolvePackageEntry, loadConfig)
import Stack.Constants (distRelativeDir, stackProgName)
import Stack.Exec (defaultEnvSettings)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)
import Stack.Setup.Installed
import Stack.Types
import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel)
import Stack.Types.StackT
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (searchPathSeparator)
import qualified System.FilePath as FP
import System.Process (rawSystem)
import System.Process.Read
import System.Process.Run (runCmd, Cmd(..))
import Text.Printf (printf)
-- | Default location of the stack-setup.yaml file
defaultStackSetupYaml :: String
defaultStackSetupYaml =
"https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"
data SetupOpts = SetupOpts
{ soptsInstallIfMissing :: !Bool
, soptsUseSystem :: !Bool
, soptsWantedCompiler :: !CompilerVersion
, soptsCompilerCheck :: !VersionCheck
, soptsStackYaml :: !(Maybe (Path Abs File))
-- ^ If we got the desired GHC version from that file
, soptsForceReinstall :: !Bool
, soptsSanityCheck :: !Bool
-- ^ Run a sanity check on the selected GHC
, soptsSkipGhcCheck :: !Bool
-- ^ Don't check for a compatible GHC version/architecture
, soptsSkipMsys :: !Bool
-- ^ Do not use a custom msys installation on Windows
, soptsUpgradeCabal :: !Bool
-- ^ Upgrade the global Cabal library in the database to the newest
-- version. Only works reliably with a stack-managed installation.
, soptsResolveMissingGHC :: !(Maybe Text)
-- ^ Message shown to user for how to resolve the missing GHC
, soptsStackSetupYaml :: !FilePath
-- ^ Location of the main stack-setup.yaml file
, soptsGHCBindistURL :: !(Maybe String)
-- ^ Alternate GHC binary distribution (requires custom GHCVariant)
}
deriving Show
data SetupException = UnsupportedSetupCombo OS Arch
| MissingDependencies [String]
| UnknownCompilerVersion Text CompilerVersion [CompilerVersion]
| UnknownOSKey Text
| GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)
| WantedMustBeGHC
| RequireCustomGHCVariant
| ProblemWhileDecompressing (Path Abs File)
| SetupInfoMissingSevenz
| GHCJSRequiresStandardVariant
| GHCJSNotBooted
| DockerStackExeNotFound Version Text
deriving Typeable
instance Exception SetupException
instance Show SetupException where
show (UnsupportedSetupCombo os arch) = concat
[ "I don't know how to install GHC for "
, show (os, arch)
, ", please install manually"
]
show (MissingDependencies tools) =
"The following executables are missing and must be installed: " ++
intercalate ", " tools
show (UnknownCompilerVersion oskey wanted known) = concat
[ "No information found for "
, compilerVersionString wanted
, ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': "
, intercalate ", " (map show known)
]
show (UnknownOSKey oskey) =
"Unable to find installation URLs for OS key: " ++
T.unpack oskey
show (GHCSanityCheckCompileFailed e ghc) = concat
[ "The GHC located at "
, toFilePath ghc
, " failed to compile a sanity check. Please see:\n\n"
, " https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md\n\n"
, "for more information. Exception was:\n"
, show e
]
show WantedMustBeGHC =
"The wanted compiler must be GHC"
show RequireCustomGHCVariant =
"A custom --ghc-variant must be specified to use --ghc-bindist"
show (ProblemWhileDecompressing archive) =
"Problem while decompressing " ++ toFilePath archive
show SetupInfoMissingSevenz =
"SetupInfo missing Sevenz EXE/DLL"
show GHCJSRequiresStandardVariant =
"stack does not yet support using --ghc-variant with GHCJS"
show GHCJSNotBooted =
"GHCJS does not yet have its boot packages installed. Use \"stack setup\" to attempt to run ghcjs-boot."
show (DockerStackExeNotFound stackVersion osKey) = concat
[ stackProgName
, "-"
, versionString stackVersion
, " executable not found for "
, T.unpack osKey
, "\nUse the '"
, T.unpack dockerStackExeArgName
, "' option to specify a location"]
-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too
setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)
=> Maybe Text -- ^ Message to give user when necessary GHC is not available
-> m EnvConfig
setupEnv mResolveMissingGHC = do
bconfig <- asks getBuildConfig
let platform = getPlatform bconfig
wc = whichCompiler (bcWantedCompiler bconfig)
sopts = SetupOpts
{ soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig
, soptsUseSystem = configSystemGHC $ bcConfig bconfig
, soptsWantedCompiler = bcWantedCompiler bconfig
, soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig
, soptsStackYaml = Just $ bcStackYaml bconfig
, soptsForceReinstall = False
, soptsSanityCheck = False
, soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig
, soptsSkipMsys = configSkipMsys $ bcConfig bconfig
, soptsUpgradeCabal = False
, soptsResolveMissingGHC = mResolveMissingGHC
, soptsStackSetupYaml = defaultStackSetupYaml
, soptsGHCBindistURL = Nothing
}
mghcBin <- ensureCompiler sopts
-- Modify the initial environment to include the GHC path, if a local GHC
-- is being used
menv0 <- getMinimalEnvOverride
let env = removeHaskellEnvVars
$ augmentPathMap (maybe [] edBins mghcBin)
$ unEnvOverride menv0
menv <- mkEnvOverride platform env
compilerVer <- getCompilerVersion menv wc
cabalVer <- getCabalPkgVer menv wc
packages <- mapM
(resolvePackageEntry menv (bcRoot bconfig))
(bcPackageEntries bconfig)
let envConfig0 = EnvConfig
{ envConfigBuildConfig = bconfig
, envConfigCabalVersion = cabalVer
, envConfigCompilerVersion = compilerVer
, envConfigPackages = Map.fromList $ concat packages
}
-- extra installation bin directories
mkDirs <- runReaderT extraBinDirs envConfig0
let mpath = Map.lookup "PATH" env
mkDirs' = map toFilePath . mkDirs
depsPath = augmentPath (mkDirs' False) mpath
localsPath = augmentPath (mkDirs' True) mpath
deps <- runReaderT packageDatabaseDeps envConfig0
createDatabase menv wc deps
localdb <- runReaderT packageDatabaseLocal envConfig0
createDatabase menv wc localdb
globaldb <- getGlobalDB menv wc
extras <- runReaderT packageDatabaseExtra envConfig0
let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb
distDir <- runReaderT distRelativeDir envConfig0
executablePath <- liftIO getExecutablePath
utf8EnvVars <- getUtf8LocaleVars menv
envRef <- liftIO $ newIORef Map.empty
let getEnvOverride' es = do
m <- readIORef envRef
case Map.lookup es m of
Just eo -> return eo
Nothing -> do
eo <- mkEnvOverride platform
$ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)
$ (if esIncludeGhcPackagePath es
then Map.insert
(case wc of { Ghc -> "GHC_PACKAGE_PATH"; Ghcjs -> "GHCJS_PACKAGE_PATH" })
(mkGPP (esIncludeLocals es))
else id)
$ (if esStackExe es
then Map.insert "STACK_EXE" (T.pack executablePath)
else id)
$ (if esLocaleUtf8 es
then Map.union utf8EnvVars
else id)
-- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70
$ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps)
$ Map.insert "HASKELL_PACKAGE_SANDBOXES"
(T.pack $ if esIncludeLocals es
then intercalate [searchPathSeparator]
[ toFilePathNoTrailingSep localdb
, toFilePathNoTrailingSep deps
, ""
]
else intercalate [searchPathSeparator]
[ toFilePathNoTrailingSep deps
, ""
])
$ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) env
() <- atomicModifyIORef envRef $ \m' ->
(Map.insert es eo m', ())
return eo
return EnvConfig
{ envConfigBuildConfig = bconfig
{ bcConfig = maybe id addIncludeLib mghcBin
(bcConfig bconfig)
{ configEnvOverride = getEnvOverride' }
}
, envConfigCabalVersion = cabalVer
, envConfigCompilerVersion = compilerVer
, envConfigPackages = envConfigPackages envConfig0
}
-- | Add the include and lib paths to the given Config
addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib (ExtraDirs _bins includes libs) config = config
{ configExtraIncludeDirs = Set.union
(configExtraIncludeDirs config)
(Set.fromList $ map T.pack includes)
, configExtraLibDirs = Set.union
(configExtraLibDirs config)
(Set.fromList $ map T.pack libs)
}
-- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary
ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)
=> SetupOpts
-> m (Maybe ExtraDirs)
ensureCompiler sopts = do
let wc = whichCompiler (soptsWantedCompiler sopts)
when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do
$logWarn "stack will almost certainly fail with GHC below version 7.8"
$logWarn "Valiantly attempting to run anyway, but I know this is doomed"
$logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"
$logWarn ""
-- Check the available GHCs
menv0 <- getMinimalEnvOverride
msystem <-
if soptsUseSystem sopts
then getSystemCompiler menv0 wc
else return Nothing
Platform expectedArch _ <- asks getPlatform
let needLocal = case msystem of
Nothing -> True
Just _ | soptsSkipGhcCheck sopts -> False
Just (system, arch) ->
not (isWanted system) ||
arch /= expectedArch
isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
-- If we need to install a GHC or MSYS, try to do so
-- Return the additional directory paths of GHC & MSYS.
mtools <- if needLocal
then do
getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager)
localPrograms <- asks $ configLocalPrograms . getConfig
installed <- listInstalled localPrograms
-- Install GHC
ghcVariant <- asks getGHCVariant
config <- asks getConfig
ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
let installedCompiler =
case wc of
Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion)
Ghcjs -> getInstalledGhcjs installed isWanted
compilerTool <- case installedCompiler of
Just tool -> return tool
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
downloadAndInstallCompiler
si
(soptsWantedCompiler sopts)
(soptsCompilerCheck sopts)
(soptsGHCBindistURL sopts)
| otherwise ->
throwM $ CompilerVersionMismatch
msystem
(soptsWantedCompiler sopts, expectedArch)
ghcVariant
(soptsCompilerCheck sopts)
(soptsStackYaml sopts)
(fromMaybe
("Try running \"stack setup\" to install the correct GHC into "
<> T.pack (toFilePath (configLocalPrograms config)))
$ soptsResolveMissingGHC sopts)
-- Install msys2 on windows, if necessary
platform <- asks getPlatform
mmsys2Tool <- case platform of
Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
case getInstalledTool installed $(mkPackageName "msys2") (const True) of
Just tool -> return (Just tool)
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
osKey <- getOSKey platform
VersionedDownloadInfo version info <-
case Map.lookup osKey $ siMsys2 si of
Just x -> return x
Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey
let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version)
Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey)
| otherwise -> do
$logWarn "Continuing despite missing tool: msys2"
return Nothing
_ -> return Nothing
return $ Just (compilerTool, mmsys2Tool)
else return Nothing
mpaths <- case mtools of
Nothing -> return Nothing
Just (compilerTool, mmsys2Tool) -> do
-- Add GHC's and MSYS's paths to the config.
let idents = catMaybes [Just compilerTool, mmsys2Tool]
paths <- mapM extraDirs idents
return $ Just $ mconcat paths
menv <-
case mpaths of
Nothing -> return menv0
Just ed -> do
config <- asks getConfig
let m = augmentPathMap (edBins ed) (unEnvOverride menv0)
mkEnvOverride (configPlatform config) (removeHaskellEnvVars m)
when (soptsUpgradeCabal sopts) $ do
unless needLocal $ do
$logWarn "Trying to upgrade Cabal library on a GHC not installed by stack."
$logWarn "This may fail, caveat emptor!"
upgradeCabal menv wc
case mtools of
Just (ToolGhcjs cv, _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts)
_ -> return ()
when (soptsSanityCheck sopts) $ sanityCheck menv wc
return mpaths
-- Ensure Docker container-compatible 'stack' executable is downloaded
ensureDockerStackExe
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Platform -> m (Path Abs File)
ensureDockerStackExe containerPlatform = do
config <- asks getConfig
containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
let programsPath = configLocalProgramsBase config containerPlatformDir
stackVersion = fromCabalVersion Meta.version
tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)
stackExePath <- ( $(mkRelFile "stack")) <$> installDir programsPath tool
stackExeExists <- fileExists stackExePath
unless stackExeExists $
do
$logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]
si <- getSetupInfo defaultStackSetupYaml =<< asks getHttpManager
osKey <- getOSKey containerPlatform
info <-
case Map.lookup osKey (siStack si) of
Just versions ->
case Map.lookup stackVersion versions of
Just x -> return x
Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)
Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)
_ <-
downloadAndInstallTool
programsPath
si
info
tool
installDockerStackExe
return ()
return stackExePath
-- | Install the newest version of Cabal globally
upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)
=> EnvOverride
-> WhichCompiler
-> m ()
upgradeCabal menv wc = do
let name = $(mkPackageName "Cabal")
rmap <- resolvePackages menv Set.empty (Set.singleton name)
newest <-
case Map.keys rmap of
[] -> error "No Cabal library found in index, cannot upgrade"
[PackageIdentifier name' version]
| name == name' -> return version
x -> error $ "Unexpected results for resolvePackages: " ++ show x
installed <- getCabalPkgVer menv wc
if installed >= newest
then $logInfo $ T.concat
[ "Currently installed Cabal is "
, T.pack $ versionString installed
, ", newest is "
, T.pack $ versionString newest
, ". I'm not upgrading Cabal."
]
else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
$logInfo $ T.concat
[ "Installing Cabal-"
, T.pack $ versionString newest
, " to replace "
, T.pack $ versionString installed
]
let ident = PackageIdentifier name newest
m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)
compilerPath <- join $ findExecutable menv (compilerExeName wc)
newestDir <- parseRelDir $ versionString newest
let installRoot = toFilePath $ parent (parent compilerPath)
$(mkRelDir "new-cabal")
newestDir
dir <-
case Map.lookup ident m of
Nothing -> error "upgradeCabal: Invariant violated, dir missing"
Just dir -> return dir
runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing
platform <- asks getPlatform
let setupExe = toFilePath $ dir
(case platform of
Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe")
_ -> $(mkRelFile "Setup"))
dirArgument name' = concat
[ "--"
, name'
, "dir="
, installRoot FP. name'
]
args = ( "configure": map dirArgument (words "lib bin data doc") )
runCmd (Cmd (Just dir) setupExe menv args) Nothing
runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing
runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing
$logInfo "New Cabal library installed"
-- | Get the version of the system compiler, if available
getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch))
getSystemCompiler menv wc = do
let exeName = case wc of
Ghc -> "ghc"
Ghcjs -> "ghcjs"
exists <- doesExecutableExist menv exeName
if exists
then do
eres <- tryProcessStdout Nothing menv exeName ["--info"]
let minfo = do
Right bs <- Just eres
pairs <- readMay $ S8.unpack bs :: Maybe [(String, String)]
version <- lookup "Project version" pairs >>= parseVersionFromString
arch <- lookup "Target platform" pairs >>= simpleParse . takeWhile (/= '-')
return (version, arch)
case (wc, minfo) of
(Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch))
(Ghcjs, Just (_, arch)) -> do
eversion <- tryAny $ getCompilerVersion menv Ghcjs
case eversion of
Left _ -> return Nothing
Right version -> return (Just (version, arch))
(_, Nothing) -> return Nothing
else return Nothing
-- | Download the most recent SetupInfo
getSetupInfo
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)
=> String -> Manager -> m SetupInfo
getSetupInfo stackSetupYaml manager = do
config <- asks getConfig
setupInfos <-
mapM
loadSetupInfo
(SetupInfoFileOrURL stackSetupYaml :
configSetupInfoLocations config)
return (mconcat setupInfos)
where
loadSetupInfo (SetupInfoInline si) = return si
loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do
bs <-
case parseUrl urlOrFile of
Just req -> do
bss <-
liftIO $
flip runReaderT manager $
withResponse req $
\res ->
responseBody res $$ CL.consume
return $ S8.concat bss
Nothing -> liftIO $ S.readFile urlOrFile
(si,warnings) <- either throwM return (Yaml.decodeEither' bs)
when (urlOrFile /= defaultStackSetupYaml) $
logJSONWarnings urlOrFile warnings
return si
getInstalledTool :: [Tool] -- ^ already installed
-> PackageName -- ^ package to find
-> (Version -> Bool) -- ^ which versions are acceptable
-> Maybe Tool
getInstalledTool installed name goodVersion =
if null available
then Nothing
else Just $ Tool $ maximumBy (comparing packageIdentifierVersion) available
where
available = mapMaybe goodPackage installed
goodPackage (Tool pi') =
if packageIdentifierName pi' == name &&
goodVersion (packageIdentifierVersion pi')
then Just pi'
else Nothing
goodPackage _ = Nothing
getInstalledGhcjs :: [Tool]
-> (CompilerVersion -> Bool)
-> Maybe Tool
getInstalledGhcjs installed goodVersion =
if null available
then Nothing
else Just $ ToolGhcjs $ maximum available
where
available = mapMaybe goodPackage installed
goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing
goodPackage _ = Nothing
downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Path Abs Dir
-> SetupInfo
-> DownloadInfo
-> Tool
-> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ())
-> m Tool
downloadAndInstallTool programsDir si downloadInfo tool installer = do
(file, at) <- downloadFromInfo programsDir downloadInfo tool
dir <- installDir programsDir tool
unmarkInstalled programsDir tool
installer si file at dir
markInstalled programsDir tool
return tool
downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> SetupInfo
-> CompilerVersion
-> VersionCheck
-> Maybe String
-> m Tool
downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do
ghcVariant <- asks getGHCVariant
(selectedVersion, downloadInfo) <- case mbindistURL of
Just bindistURL -> do
case ghcVariant of
GHCCustom _ -> return ()
_ -> throwM RequireCustomGHCVariant
case wanted of
GhcVersion version ->
return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing)
_ ->
throwM WantedMustBeGHC
_ -> do
ghcKey <- getGhcKey
case Map.lookup ghcKey $ siGHCs si of
Nothing -> throwM $ UnknownOSKey ghcKey
Just pairs -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs
config <- asks getConfig
let installer =
case configPlatform config of
Platform _ Cabal.Windows -> installGHCWindows selectedVersion
_ -> installGHCPosix selectedVersion
$logInfo $
"Preparing to install GHC" <>
(case ghcVariant of
GHCStandard -> ""
v -> " (" <> T.pack (ghcVariantName v) <> ")") <>
" to an isolated location."
$logInfo "This will not interfere with any system-level installation."
ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer
downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do
config <- asks getConfig
ghcVariant <- asks getGHCVariant
case ghcVariant of
GHCStandard -> return ()
_ -> throwM GHCJSRequiresStandardVariant
(selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of
Nothing -> throwM $ UnknownOSKey "source"
Just pairs -> getWantedCompilerInfo "source" versionCheck wanted id pairs
$logInfo "Preparing to install GHCJS to an isolated location."
$logInfo "This will not interfere with any system-level installation."
let tool = ToolGhcjs selectedVersion
installer = installGHCJS $ case selectedVersion of
GhcjsVersion version _ -> version
_ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler."
downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer
getWantedCompilerInfo :: (Ord k, MonadThrow m)
=> Text
-> VersionCheck
-> CompilerVersion
-> (k -> CompilerVersion)
-> Map k a
-> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs =
case mpair of
Just pair -> return pair
Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs))
where
mpair =
listToMaybe $
sortBy (flip (comparing fst)) $
filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs)
getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> m Text
getGhcKey = do
ghcVariant <- asks getGHCVariant
platform <- asks getPlatform
osKey <- getOSKey platform
return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)
getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> Platform -> m Text
getOSKey platform =
case platform of
Platform I386 Cabal.Linux -> return "linux32"
Platform X86_64 Cabal.Linux -> return "linux64"
Platform I386 Cabal.OSX -> return "macosx"
Platform X86_64 Cabal.OSX -> return "macosx"
Platform I386 Cabal.FreeBSD -> return "freebsd32"
Platform X86_64 Cabal.FreeBSD -> return "freebsd64"
Platform I386 Cabal.OpenBSD -> return "openbsd32"
Platform X86_64 Cabal.OpenBSD -> return "openbsd64"
Platform I386 Cabal.Windows -> return "windows32"
Platform X86_64 Cabal.Windows -> return "windows64"
Platform arch os -> throwM $ UnsupportedSetupCombo os arch
downloadFromInfo
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType)
downloadFromInfo programsDir downloadInfo tool = do
at <-
case extension of
".tar.xz" -> return TarXz
".tar.bz2" -> return TarBz2
".tar.gz" -> return TarGz
".7z.exe" -> return SevenZ
_ -> error $ "Unknown extension for url: " ++ T.unpack url
relfile <- parseRelFile $ toolString tool ++ extension
let path = programsDir relfile
chattyDownload (T.pack (toolString tool)) downloadInfo path
return (path, at)
where
url = downloadInfoUrl downloadInfo
extension =
loop $ T.unpack url
where
loop fp
| ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
| otherwise = ""
where
(fp', ext) = FP.splitExtension fp
data ArchiveType
= TarBz2
| TarXz
| TarGz
| SevenZ
installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Version
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installGHCPosix version _ archiveFile archiveType destDir = do
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))
$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))
zipTool' <-
case archiveType of
TarXz -> return "xz"
TarBz2 -> return "bzip2"
TarGz -> return "gzip"
SevenZ -> error "Don't know how to deal with .7z files on non-Windows"
(zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
<$> checkDependency zipTool'
<*> (checkDependency "gmake" <|> checkDependency "make")
<*> checkDependency "tar"
$logDebug $ "ziptool: " <> T.pack zipTool
$logDebug $ "make: " <> T.pack makeTool
$logDebug $ "tar: " <> T.pack tarTool
withCanonicalizedSystemTempDirectory "stack-setup" $ \root -> do
dir <-
liftM (root ) $
parseRelDir $
"ghc-" ++ versionString version
$logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."]
$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)
readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing
$logSticky "Configuring GHC ..."
readInNull dir (toFilePath $ dir $(mkRelFile "configure"))
menv ["--prefix=" ++ toFilePath destDir] Nothing
$logSticky "Installing GHC ..."
readInNull dir makeTool menv ["install"] Nothing
$logStickyDone $ "Installed GHC."
$logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)
installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> Version
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installGHCJS version si archiveFile archiveType destDir = do
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
-- This ensures that locking is disabled for the invocations of
-- stack below.
let removeLockVar = Map.delete "STACK_LOCK"
menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0)))
$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))
-- NOTE: this is a bit of a hack - instead of using a temp
-- directory, leave the unpacked source tarball in the destination
-- directory. This way, the absolute paths in the wrapper scripts
-- will point to executables that exist in
-- src/.stack-work/install/... - see
-- https://github.com/commercialhaskell/stack/issues/1016
--
-- This is also used by 'ensureGhcjsBooted', because it can use the
-- environment of the stack.yaml which came with ghcjs, in order to
-- install cabal-install. This lets us also fix the version of
-- cabal-install used.
let unpackDir = destDir $(mkRelDir "src")
tarComponent <- parseRelDir ("ghcjs-" ++ versionString version)
runUnpack <- case platform of
Platform _ Cabal.Windows -> return $
withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir
_ -> do
zipTool' <-
case archiveType of
TarXz -> return "xz"
TarBz2 -> return "bzip2"
TarGz -> return "gzip"
SevenZ -> error "Don't know how to deal with .7z files on non-Windows"
(zipTool, tarTool) <- checkDependencies $ (,)
<$> checkDependency zipTool'
<*> checkDependency "tar"
$logDebug $ "ziptool: " <> T.pack zipTool
$logDebug $ "tar: " <> T.pack tarTool
return $ do
removeTreeIfExists unpackDir
readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing
renameDir (destDir tarComponent) unpackDir
$logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."]
$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)
runUnpack
$logSticky "Setting up GHCJS build environment"
let stackYaml = unpackDir $(mkRelFile "stack.yaml")
destBinDir = destDir $(mkRelDir "bin")
createTree destBinDir
envConfig <- loadGhcjsEnvConfig stackYaml destBinDir
-- On windows we need to copy options files out of the install dir. Argh!
-- This is done before the build, so that if it fails, things fail
-- earlier.
mwindowsInstallDir <- case platform of
Platform _ Cabal.Windows ->
liftM Just $ runInnerStackT envConfig installationRootLocal
_ -> return Nothing
$logSticky "Installing GHCJS (this will take a long time) ..."
runInnerStackT envConfig $
build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True }
-- Copy over *.options files needed on windows.
forM_ mwindowsInstallDir $ \dir -> do
(_, files) <- listDirectory (dir $(mkRelDir "bin"))
forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do
let dest = destDir $(mkRelDir "bin") filename optionsFile
removeFileIfExists dest
copyFile optionsFile dest
$logStickyDone "Installed GHCJS."
-- Install the downloaded stack binary distribution
installDockerStackExe
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installDockerStackExe _ archiveFile _ destDir = do
(_,tarTool) <-
checkDependencies $
(,) <$> checkDependency "gzip" <*> checkDependency "tar"
menv <- getMinimalEnvOverride
createTree destDir
readInNull
destDir
tarTool
menv
["xf", toFilePath archiveFile, "--strip-components", "1"]
Nothing
ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)
=> EnvOverride -> CompilerVersion -> Bool -> m ()
ensureGhcjsBooted menv cv shouldBoot = do
eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ())
case eres of
Right () -> return ()
Left (ReadProcessException _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err ->
return ()
Left (ReadProcessException _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err ->
if not shouldBoot then throwM GHCJSNotBooted else do
config <- asks getConfig
destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv)
let stackYaml = destDir $(mkRelFile "src/stack.yaml")
-- TODO: Remove 'actualStackYaml' and just use
-- 'stackYaml' for a version after 0.1.6. It's for
-- compatibility with the directories setup used for
-- most of the life of the development branch between
-- 0.1.5 and 0.1.6. See
-- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783
-- This only affects the case where GHCJS has been
-- installed with an older version and not yet booted.
stackYamlExists <- fileExists stackYaml
actualStackYaml <- if stackYamlExists then return stackYaml
else case cv of
GhcjsVersion version _ ->
liftM ((destDir $(mkRelDir "src")) ) $
parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml"
_ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion"
actualStackYamlExists <- fileExists actualStackYaml
unless actualStackYamlExists $
fail "Couldn't find GHCJS stack.yaml in old or new location."
bootGhcjs actualStackYaml destDir
Left err -> throwM err
bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)
=> Path Abs File -> Path Abs Dir -> m ()
bootGhcjs stackYaml destDir = do
envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin"))
menv <- liftIO $ configEnvOverride (getConfig envConfig) defaultEnvSettings
-- Install cabal-install if missing, or if the installed one is old.
mcabal <- getCabalInstallVersion menv
shouldInstallCabal <- case mcabal of
Nothing -> do
$logInfo "No cabal-install binary found for use with GHCJS. Installing a local copy of cabal-install from source."
return True
Just v
| v < $(mkVersion "1.22.4") -> do
$logInfo $
"cabal-install found on PATH is too old to be used for booting GHCJS (version " <>
versionText v <>
"). Installing a local copy of cabal-install from source."
return True
| otherwise -> return False
when shouldInstallCabal $ do
$logSticky "Building cabal-install for use by ghcjs-boot ... "
runInnerStackT envConfig $
build (\_ -> return ())
Nothing
defaultBuildOpts { boptsTargets = ["cabal-install"] }
$logSticky "Booting GHCJS (this will take a long time) ..."
let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False }
menv' <- liftIO $ configEnvOverride (getConfig envConfig) envSettings
runAndLog Nothing "ghcjs-boot" menv' ["--clean"]
$logStickyDone "GHCJS booted."
-- TODO: something similar is done in Stack.Build.Execute. Create some utilities
-- for this?
runAndLog :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
=> Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m ()
runAndLog mdir name menv args = liftBaseWith $ \restore -> do
let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr)
void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines
loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r)
=> Path Abs File -> Path b t -> m EnvConfig
loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do
lc <- loadConfig
(mempty
{ configMonoidInstallGHC = Just True
, configMonoidLocalBinPath = Just (toFilePath binPath)
})
(Just stackYaml)
Nothing
bconfig <- lcLoadBuildConfig lc Nothing
runInnerStackT bconfig $ setupEnv Nothing
getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m)
=> EnvOverride -> m (Maybe Version)
getCabalInstallVersion menv = do
ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"]
case ebs of
Left _ -> return Nothing
Right bs -> Just <$> parseVersion (T.encodeUtf8 (T.dropWhileEnd isSpace (T.decodeUtf8 bs)))
-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)
=> CheckDependency a -> m a
checkDependencies (CheckDependency f) = do
menv <- getMinimalEnvOverride
liftIO (f menv) >>= either (throwM . MissingDependencies) return
checkDependency :: String -> CheckDependency String
checkDependency tool = CheckDependency $ \menv -> do
exists <- doesExecutableExist menv tool
return $ if exists then Right tool else Left [tool]
newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a))
deriving Functor
instance Applicative CheckDependency where
pure x = CheckDependency $ \_ -> return (Right x)
CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do
f' <- f menv
x' <- x menv
return $
case (f', x') of
(Left e1, Left e2) -> Left $ e1 ++ e2
(Left e, Right _) -> Left e
(Right _, Left e) -> Left e
(Right f'', Right x'') -> Right $ f'' x''
instance Alternative CheckDependency where
empty = CheckDependency $ \_ -> return $ Left []
CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do
res1 <- x menv
case res1 of
Left _ -> y menv
Right x' -> return $ Right x'
installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Version
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installGHCWindows version si archiveFile archiveType destDir = do
tarComponent <- parseRelDir $ "ghc-" ++ versionString version
withUnpackedTarball7z "GHC" si archiveFile archiveType tarComponent destDir
$logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)
installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Text -- ^ OS Key
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installMsys2Windows osKey si archiveFile archiveType destDir = do
exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do
$logError $ T.pack $
"Could not delete existing msys directory: " ++
toFilePath destDir
throwM e
msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)
withUnpackedTarball7z "MSYS2" si archiveFile archiveType msys destDir
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
let oldEnv = unEnvOverride menv0
newEnv = augmentPathMap
[toFilePath $ destDir $(mkRelDir "usr") $(mkRelDir "bin")]
oldEnv
menv <- mkEnvOverride platform newEnv
-- I couldn't find this officially documented anywhere, but you need to run
-- the shell once in order to initialize some pacman stuff. Once that run
-- happens, you can just run commands as usual.
runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing
-- No longer installing git, it's unreliable
-- (https://github.com/commercialhaskell/stack/issues/1046) and the
-- MSYS2-installed version has bad CRLF defaults.
--
-- Install git. We could install other useful things in the future too.
-- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing
-- | Unpack a compressed tarball using 7zip. Expects a single directory in
-- the unpacked results, which is renamed to the destination directory.
withUnpackedTarball7z :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> String -- ^ Name of tool, used in error messages
-> SetupInfo
-> Path Abs File -- ^ Path to archive file
-> ArchiveType
-> Path Rel Dir -- ^ Name of directory expected to be in archive.
-> Path Abs Dir -- ^ Destination directory.
-> m ()
withUnpackedTarball7z name si archiveFile archiveType srcDir destDir = do
suffix <-
case archiveType of
TarXz -> return ".xz"
TarBz2 -> return ".bz2"
TarGz -> return ".gz"
_ -> error $ name ++ " must be a tarball file"
tarFile <-
case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of
Nothing -> error $ "Invalid " ++ name ++ " filename: " ++ show archiveFile
Just x -> parseAbsFile $ T.unpack x
run7z <- setup7z si
let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"
createTree (parent destDir)
withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do
let absSrcDir = tmpDir srcDir
removeTreeIfExists destDir
run7z (parent archiveFile) archiveFile
run7z tmpDir tarFile
removeFile tarFile `catchIO` \e ->
$logWarn (T.concat
[ "Exception when removing "
, T.pack $ toFilePath tarFile
, ": "
, T.pack $ show e
])
renameDir absSrcDir destDir
-- | Download 7z as necessary, and get a function for unpacking things.
--
-- Returned function takes an unpack directory and archive.
setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadLogger n, MonadBaseControl IO m)
=> SetupInfo
-> m (Path Abs Dir -> Path Abs File -> n ())
setup7z si = do
dir <- asks $ configLocalPrograms . getConfig
let exe = dir $(mkRelFile "7z.exe")
dll = dir $(mkRelFile "7z.dll")
case (siSevenzDll si, siSevenzExe si) of
(Just sevenzDll, Just sevenzExe) -> do
chattyDownload "7z.dll" sevenzDll dll
chattyDownload "7z.exe" sevenzExe exe
return $ \outdir archive -> do
let cmd = toFilePath exe
args =
[ "x"
, "-o" ++ toFilePath outdir
, "-y"
, toFilePath archive
]
$logProcessRun cmd args
ec <- liftIO $ rawSystem cmd args
when (ec /= ExitSuccess)
$ liftIO $ throwM (ProblemWhileDecompressing archive)
_ -> throwM SetupInfoMissingSevenz
chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
=> Text -- ^ label
-> DownloadInfo -- ^ URL, content-length, and sha1
-> Path Abs File -- ^ destination
-> m ()
chattyDownload label downloadInfo path = do
let url = downloadInfoUrl downloadInfo
req <- parseUrl $ T.unpack url
$logSticky $ T.concat
[ "Preparing to download "
, label
, " ..."
]
$logDebug $ T.concat
[ "Downloading from "
, url
, " to "
, T.pack $ toFilePath path
, " ..."
]
hashChecks <- case downloadInfoSha1 downloadInfo of
Just sha1ByteString -> do
let sha1 = CheckHexDigestByteString sha1ByteString
$logDebug $ T.concat
[ "Will check against sha1 hash: "
, T.decodeUtf8With T.lenientDecode sha1ByteString
]
return [HashCheck SHA1 sha1]
Nothing -> do
$logWarn $ T.concat
[ "No sha1 found in metadata,"
, " download hash won't be checked."
]
return []
let dReq = DownloadRequest
{ drRequest = req
, drHashChecks = hashChecks
, drLengthCheck = mtotalSize
, drRetryPolicy = drRetryPolicyDefault
}
runInBase <- liftBaseWith $ \run -> return (void . run)
x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)
if x
then $logStickyDone ("Downloaded " <> label <> ".")
else $logStickyDone "Already downloaded."
where
mtotalSize = downloadInfoContentLength downloadInfo
chattyDownloadProgress runInBase _ = do
_ <- liftIO $ runInBase $ $logSticky $
label <> ": download has begun"
CL.map (Sum . S.length)
=$ chunksOverTime 1
=$ go
where
go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
modify (+ size)
totalSoFar <- get
liftIO $ runInBase $ $logSticky $ T.pack $
case mtotalSize of
Nothing -> chattyProgressNoTotal totalSoFar
Just 0 -> chattyProgressNoTotal totalSoFar
Just totalSize -> chattyProgressWithTotal totalSoFar totalSize
-- Example: ghc: 42.13 KiB downloaded...
chattyProgressNoTotal totalSoFar =
printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
(T.unpack label)
-- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
chattyProgressWithTotal totalSoFar total =
printf ("%s: " <>
bytesfmt "%7.2f" totalSoFar <> " / " <>
bytesfmt "%.2f" total <>
" (%6.2f%%) downloaded...")
(T.unpack label)
percentage
where percentage :: Double
percentage = fromIntegral totalSoFar / fromIntegral total * 100
-- | Given a printf format string for the decimal part and a number of
-- bytes, formats the bytes using an appropiate unit and returns the
-- formatted string.
--
-- >>> bytesfmt "%.2" 512368
-- "500.359375 KiB"
bytesfmt :: Integral a => String -> a -> String
bytesfmt formatter bs = printf (formatter <> " %s")
(fromIntegral (signum bs) * dec :: Double)
(bytesSuffixes !! i)
where
(dec,i) = getSuffix (abs bs)
getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)
where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)
bytesSuffixes :: [String]
bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]
-- Await eagerly (collect with monoidal append),
-- but space out yields by at least the given amount of time.
-- The final yield may come sooner, and may be a superfluous mempty.
-- Note that Integer and Float literals can be turned into NominalDiffTime
-- (these literals are interpreted as "seconds")
chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> Conduit a m a
chunksOverTime diff = do
currentTime <- liftIO getCurrentTime
evalStateC (currentTime, mempty) go
where
-- State is a tuple of:
-- * the last time a yield happened (or the beginning of the sink)
-- * the accumulated awaits since the last yield
go = await >>= \case
Nothing -> do
(_, acc) <- get
yield acc
Just a -> do
(lastTime, acc) <- get
let acc' = acc <> a
currentTime <- liftIO getCurrentTime
if diff < diffUTCTime currentTime lastTime
then put (currentTime, mempty) >> yield acc'
else put (lastTime, acc')
go
-- | Perform a basic sanity check of GHC
sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> m ()
sanityCheck menv wc = withCanonicalizedSystemTempDirectory "stack-sanity-check" $ \dir -> do
let fp = toFilePath $ dir $(mkRelFile "Main.hs")
liftIO $ writeFile fp $ unlines
[ "import Distribution.Simple" -- ensure Cabal library is present
, "main = putStrLn \"Hello World\""
]
let exeName = compilerExeName wc
ghc <- join $ findExecutable menv exeName
$logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc)
eres <- tryProcessStdout (Just dir) menv exeName
[ fp
, "-no-user-package-db"
]
case eres of
Left e -> throwM $ GHCSanityCheckCompileFailed e ghc
Right _ -> return () -- TODO check that the output of running the command is correct
-- Remove potentially confusing environment variables
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
Map.delete "GHCJS_PACKAGE_PATH" .
Map.delete "GHC_PACKAGE_PATH" .
Map.delete "HASKELL_PACKAGE_SANDBOX" .
Map.delete "HASKELL_PACKAGE_SANDBOXES" .
Map.delete "HASKELL_DIST_DIR"
-- | Get map of environment variables to set to change the locale's encoding to UTF-8
getUtf8LocaleVars
:: forall m env.
(MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)
=> EnvOverride -> m (Map Text Text)
getUtf8LocaleVars menv = do
Platform _ os <- asks getPlatform
if os == Cabal.Windows
then
-- On Windows, locale is controlled by the code page, so we don't set any environment
-- variables.
return
Map.empty
else do
let checkedVars = map checkVar (Map.toList $ eoTextMap menv)
-- List of environment variables that will need to be updated to set UTF-8 (because
-- they currently do not specify UTF-8).
needChangeVars = concatMap fst checkedVars
-- Set of locale-related environment variables that have already have a value.
existingVarNames = Set.unions (map snd checkedVars)
-- True if a locale is already specified by one of the "global" locale variables.
hasAnyExisting =
any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]
if null needChangeVars && hasAnyExisting
then
-- If no variables need changes and at least one "global" variable is set, no
-- changes to environment need to be made.
return
Map.empty
else do
-- Get a list of known locales by running @locale -a@.
elocales <- tryProcessStdout Nothing menv "locale" ["-a"]
let
-- Filter the list to only include locales with UTF-8 encoding.
utf8Locales =
case elocales of
Left _ -> []
Right locales ->
filter
isUtf8Locale
(T.lines $
T.decodeUtf8With
T.lenientDecode
locales)
mfallback = getFallbackLocale utf8Locales
when
(isNothing mfallback)
($logWarn
"Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")
let
-- Get the new values of variables to adjust.
changes =
Map.unions $
map
(adjustedVarValue utf8Locales mfallback)
needChangeVars
-- Get the values of variables to add.
adds
| hasAnyExisting =
-- If we already have a "global" variable, then nothing needs
-- to be added.
Map.empty
| otherwise =
-- If we don't already have a "global" variable, then set LANG to the
-- fallback.
case mfallback of
Nothing -> Map.empty
Just fallback ->
Map.singleton "LANG" fallback
return (Map.union changes adds)
where
-- Determines whether an environment variable is locale-related and, if so, whether it needs to
-- be adjusted.
checkVar
:: (Text, Text) -> ([Text], Set Text)
checkVar (k,v) =
if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k
then if isUtf8Locale v
then ([], Set.singleton k)
else ([k], Set.singleton k)
else ([], Set.empty)
-- Adjusted value of an existing locale variable. Looks for valid UTF-8 encodings with
-- same language /and/ territory, then with same language, and finally the first UTF-8 locale
-- returned by @locale -a@.
adjustedVarValue
:: [Text] -> Maybe Text -> Text -> Map Text Text
adjustedVarValue utf8Locales mfallback k =
case Map.lookup k (eoTextMap menv) of
Nothing -> Map.empty
Just v ->
case concatMap
(matchingLocales utf8Locales)
[ T.takeWhile (/= '.') v <> "."
, T.takeWhile (/= '_') v <> "_"] of
(v':_) -> Map.singleton k v'
[] ->
case mfallback of
Just fallback -> Map.singleton k fallback
Nothing -> Map.empty
-- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in
-- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale
-- -a@.
getFallbackLocale
:: [Text] -> Maybe Text
getFallbackLocale utf8Locales =
case concatMap (matchingLocales utf8Locales) fallbackPrefixes of
(v:_) -> Just v
[] ->
case utf8Locales of
[] -> Nothing
(v:_) -> Just v
-- Filter the list of locales for any with the given prefixes (case-insitive).
matchingLocales
:: [Text] -> Text -> [Text]
matchingLocales utf8Locales prefix =
filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales
-- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?
isUtf8Locale locale =
any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes
-- Prefixes of fallback locales (case-insensitive)
fallbackPrefixes = ["C.", "en_US.", "en_"]
-- Suffixes of UTF-8 locales (case-insensitive)
utf8Suffixes = [".UTF-8", ".utf8"]
stack-0.1.10.0/src/Stack/Setup/Installed.hs 0000644 0000000 0000000 00000014061 12623647202 016437 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Setup.Installed
( getCompilerVersion
, markInstalled
, unmarkInstalled
, listInstalled
, Tool (..)
, toolString
, toolNameString
, parseToolText
, ExtraDirs (..)
, extraDirs
, installDir
) where
import Control.Applicative
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import Data.List hiding (concat, elem, maximumBy)
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Distribution.System (Platform (..))
import qualified Distribution.System as Cabal
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Prelude hiding (concat, elem) -- Fix AMP warning
import Stack.Types
import System.Process.Read
data Tool
= Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512
| ToolGhcjs CompilerVersion -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2
toolString :: Tool -> String
toolString (Tool ident) = packageIdentifierString ident
toolString (ToolGhcjs cv) = compilerVersionString cv
toolNameString :: Tool -> String
toolNameString (Tool ident) = packageNameString $ packageIdentifierName ident
toolNameString ToolGhcjs{} = "ghcjs"
parseToolText :: Text -> Maybe Tool
parseToolText (parseCompilerVersion -> Just (cv@GhcjsVersion{})) = Just (ToolGhcjs cv)
parseToolText (parsePackageIdentifierFromString . T.unpack -> Just pkgId) = Just (Tool pkgId)
parseToolText _ = Nothing
markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m ()
markInstalled programsPath tool = do
fpRel <- parseRelFile $ toolString tool ++ ".installed"
liftIO $ writeFile (toFilePath $ programsPath fpRel) "installed"
unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m ()
unmarkInstalled programsPath tool = do
fpRel <- parseRelFile $ toolString tool ++ ".installed"
removeFileIfExists $ programsPath fpRel
listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> Path Abs Dir
-> m [Tool]
listInstalled programsPath = do
createTree programsPath
(_, files) <- listDirectory programsPath
return $ mapMaybe toTool files
where
toTool fp = do
x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp
parseToolText x
getCompilerVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)
=> EnvOverride -> WhichCompiler -> m CompilerVersion
getCompilerVersion menv wc =
case wc of
Ghc -> do
bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"]
let (_, ghcVersion) = versionFromEnd bs
GhcVersion <$> parseVersion ghcVersion
Ghcjs -> do
-- Output looks like
--
-- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2)
bs <- readProcessStdout Nothing menv "ghcjs" ["--version"]
let (rest, ghcVersion) = versionFromEnd bs
(_, ghcjsVersion) = versionFromEnd rest
GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion
where
versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid
isValid c = c == '.' || ('0' <= c && c <= '9')
-- | Binary directories for the given installed package
extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)
=> Tool
-> m ExtraDirs
extraDirs tool = do
config <- asks getConfig
dir <- installDir (configLocalPrograms config) tool
case (configPlatform config, toolNameString tool) of
(Platform _ Cabal.Windows, isGHC -> True) -> return mempty
{ edBins = goList
[ dir $(mkRelDir "bin")
, dir $(mkRelDir "mingw") $(mkRelDir "bin")
]
}
(Platform _ Cabal.Windows, "msys2") -> return mempty
{ edBins = goList
[ dir $(mkRelDir "usr") $(mkRelDir "bin")
]
, edInclude = goList
[ dir $(mkRelDir "mingw64") $(mkRelDir "include")
, dir $(mkRelDir "mingw32") $(mkRelDir "include")
]
, edLib = goList
[ dir $(mkRelDir "mingw64") $(mkRelDir "lib")
, dir $(mkRelDir "mingw32") $(mkRelDir "lib")
]
}
(_, isGHC -> True) -> return mempty
{ edBins = goList
[ dir $(mkRelDir "bin")
]
}
(_, isGHCJS -> True) -> return mempty
{ edBins = goList
[ dir $(mkRelDir "bin")
]
}
(Platform _ x, toolName) -> do
$logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName))
return mempty
where
goList = map toFilePathNoTrailingSep
isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n
isGHCJS n = "ghcjs" == n
data ExtraDirs = ExtraDirs
{ edBins :: ![FilePath]
, edInclude :: ![FilePath]
, edLib :: ![FilePath]
}
instance Monoid ExtraDirs where
mempty = ExtraDirs [] [] []
mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs
(a ++ x)
(b ++ y)
(c ++ z)
installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)
=> Path Abs Dir
-> Tool
-> m (Path Abs Dir)
installDir programsDir tool = do
reldir <- parseRelDir $ toolString tool
return $ programsDir reldir
stack-0.1.10.0/src/Stack/Solver.hs 0000644 0000000 0000000 00000023470 12623647202 014676 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Solver
( cabalSolver
, solveExtraDeps
) where
import Control.Applicative
import Control.Exception.Enclosed (tryIO)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings)
import qualified Data.ByteString as S
import Data.Either
import qualified Data.HashMap.Strict as HashMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Yaml as Yaml
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO (parseRelAsAbsDir)
import Prelude
import Stack.BuildPlan
import Stack.Setup.Installed
import Stack.Types
import System.Directory (copyFile,
createDirectoryIfMissing,
getTemporaryDirectory)
import qualified System.FilePath as FP
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Read
cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)
=> WhichCompiler
-> [Path Abs Dir] -- ^ cabal files
-> Map PackageName Version -- ^ constraints
-> Map PackageName (Map FlagName Bool) -- ^ user-specified flags
-> [String] -- ^ additional arguments
-> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool))
cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do
when (null cabalfps) $ throwM SolverNoCabalFiles
configLines <- getCabalConfig dir constraints
let configFile = dir FP. "cabal.config"
liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines
menv0 <- getMinimalEnvOverride
mghc <- findExecutable menv0 "ghc"
platform <- asks getPlatform
menv <-
case mghc of
Just _ -> return menv0
Nothing -> do
localPrograms <- asks $ configLocalPrograms . getConfig
tools <- listInstalled localPrograms
let ghcName = $(mkPackageName "ghc")
case [version | Tool (PackageIdentifier name version) <- tools, name == ghcName] of
[] -> throwM SolverMissingGHC
versions -> do
let version = maximum versions
$logInfo $ "No GHC on path, selecting: " <>
T.pack (versionString version)
ed <- extraDirs $ Tool $ PackageIdentifier ghcName version
mkEnvOverride platform
$ augmentPathMap (edBins ed)
$ unEnvOverride menv0
mcabal <- findExecutable menv "cabal"
case mcabal of
Nothing -> throwM SolverMissingCabalInstall
Just _ -> return ()
compilerVersion <- getCompilerVersion menv wc
-- Run from a temporary directory to avoid cabal getting confused by any
-- sandbox files, see:
-- https://github.com/commercialhaskell/stack/issues/356
--
-- In theory we could use --ignore-sandbox, but not all versions of cabal
-- support it.
tmpdir <- liftIO getTemporaryDirectory >>= parseRelAsAbsDir
let args = ("--config-file=" ++ configFile)
: "install"
: "--enable-tests"
: "--enable-benchmarks"
: "-v"
: "--dry-run"
: "--only-dependencies"
: "--reorder-goals"
: "--max-backjumps=-1"
: "--package-db=clear"
: "--package-db=global"
: cabalArgs ++
toConstraintArgs userFlags ++
fmap toFilePath cabalfps ++
["--ghcjs" | wc == Ghcjs]
$logInfo "Asking cabal to calculate a build plan, please wait"
menv' <- mkEnvOverride platform
$ Map.delete "GHCJS_PACKAGE_PATH"
$ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv
bs <- readProcessStdout (Just tmpdir) menv' "cabal" args
let ls = drop 1
$ dropWhile (not . T.isPrefixOf "In order, ")
$ T.lines
$ decodeUtf8 bs
(errs, pairs) = partitionEithers $ map parseLine ls
if null errs
then return (compilerVersion, Map.fromList pairs)
else error $ "Could not parse cabal-install output: " ++ show errs
where
parseLine t0 = maybe (Left t0) Right $ do
-- get rid of (new package) and (latest: ...) bits
ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0
PackageIdentifier name version <-
parsePackageIdentifierFromString $ T.unpack ident'
flags <- mapM parseFlag flags'
Just (name, (version, Map.fromList flags))
parseFlag t0 = do
flag <- parseFlagNameFromString $ T.unpack t1
return (flag, enabled)
where
(t1, enabled) =
case T.stripPrefix "-" t0 of
Nothing ->
case T.stripPrefix "+" t0 of
Nothing -> (t0, True)
Just x -> (x, True)
Just x -> (x, False)
toConstraintArgs userFlagMap =
[formatFlagConstraint package flag enabled | (package, fs) <- Map.toList userFlagMap
, (flag, enabled) <- Map.toList fs]
formatFlagConstraint package flag enabled =
let sign = if enabled then '+' else '-'
in
"--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag]
getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)
=> FilePath -- ^ temp dir
-> Map PackageName Version -- ^ constraints
-> m [Text]
getCabalConfig dir constraints = do
indices <- asks $ configPackageIndices . getConfig
remotes <- mapM goIndex indices
let cache = T.pack $ "remote-repo-cache: " ++ dir
return $ cache : remotes ++ map goConstraint (Map.toList constraints)
where
goIndex index = do
src <- configPackageIndex $ indexName index
let dstdir = dir FP. T.unpack (indexNameText $ indexName index)
dst = dstdir FP. "00-index.tar"
liftIO $ void $ tryIO $ do
createDirectoryIfMissing True dstdir
copyFile (toFilePath src) dst
return $ T.concat
[ "remote-repo: "
, indexNameText $ indexName index
, ":http://0.0.0.0/fake-url"
]
goConstraint (name, version) = T.concat
[ "constraint: "
, T.pack $ packageNameString name
, "=="
, T.pack $ versionString version
]
-- | Determine missing extra-deps
solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env)
=> Bool -- ^ modify stack.yaml?
-> m ()
solveExtraDeps modStackYaml = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
snapshot <-
case bcResolver bconfig of
ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName
ResolverCompiler _ -> return Map.empty
ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan
(bcStackYaml bconfig)
url
let packages = Map.union
(bcExtraDeps bconfig)
(mpiVersion <$> snapshot)
wc <- getWhichCompiler
(_compilerVersion, extraDeps) <- cabalSolver
wc
(Map.keys $ envConfigPackages econfig)
packages
(bcFlags bconfig)
[]
let newDeps = extraDeps `Map.difference` packages
newFlags = Map.filter (not . Map.null) $ fmap snd newDeps
$logInfo "This command is not guaranteed to give you a perfect build plan"
if Map.null newDeps
then $logInfo "No needed changes found"
else do
$logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking"
let o = object
$ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps))
: (if Map.null newFlags
then []
else ["flags" .= newFlags])
mapM_ $logInfo $ T.lines $ decodeUtf8 $ Yaml.encode o
if modStackYaml
then do
let fp = toFilePath $ bcStackYaml bconfig
obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
(ProjectAndConfigMonoid project _, warnings) <-
liftIO (Yaml.decodeFileEither fp) >>= either throwM return
logJSONWarnings fp warnings
let obj' =
HashMap.insert "extra-deps"
(toJSON $ map fromTuple $ Map.toList
$ Map.union (projectExtraDeps project) (fmap fst newDeps))
$ HashMap.insert ("flags" :: Text)
(toJSON $ Map.union (projectFlags project) newFlags)
obj
liftIO $ Yaml.encodeFile fp obj'
$logInfo $ T.pack $ "Updated " ++ fp
else do
$logInfo ""
$logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'"
stack-0.1.10.0/src/Stack/Types.hs 0000644 0000000 0000000 00000001044 12630352213 014512 0 ustar 00 0000000 0000000 -- | All types.
module Stack.Types
(module X)
where
import Stack.Types.BuildPlan as X
import Stack.Types.FlagName as X
import Stack.Types.GhcPkgId as X
import Stack.Types.PackageIdentifier as X
import Stack.Types.PackageIndex as X
import Stack.Types.PackageName as X
import Stack.Types.Version as X
import Stack.Types.Config as X
import Stack.Types.Docker as X
import Stack.Types.Nix as X
import Stack.Types.Image as X
import Stack.Types.Build as X
import Stack.Types.Package as X
import Stack.Types.Compiler as X
import Stack.Types.Sig as X
stack-0.1.10.0/src/Stack/Types/Internal.hs 0000644 0000000 0000000 00000004005 12630352213 016266 0 ustar 00 0000000 0000000 -- | Internal types to the library.
module Stack.Types.Internal where
import Control.Concurrent.MVar
import Control.Monad.Logger (LogLevel)
import Data.Text (Text)
import Network.HTTP.Client.Conduit (Manager,HasHttpManager(..))
import Stack.Types.Config
-- | Monadic environment.
data Env config =
Env {envConfig :: !config
,envLogLevel :: !LogLevel
,envTerminal :: !Bool
,envReExec :: !Bool
,envManager :: !Manager
,envSticky :: !Sticky
,envSupportsUnicode :: !Bool}
instance HasStackRoot config => HasStackRoot (Env config) where
getStackRoot = getStackRoot . envConfig
instance HasPlatform config => HasPlatform (Env config) where
getPlatform = getPlatform . envConfig
getPlatformVariant = getPlatformVariant . envConfig
instance HasGHCVariant config => HasGHCVariant (Env config) where
getGHCVariant = getGHCVariant . envConfig
instance HasConfig config => HasConfig (Env config) where
getConfig = getConfig . envConfig
instance HasBuildConfig config => HasBuildConfig (Env config) where
getBuildConfig = getBuildConfig . envConfig
instance HasEnvConfig config => HasEnvConfig (Env config) where
getEnvConfig = getEnvConfig . envConfig
instance HasHttpManager (Env config) where
getHttpManager = envManager
class HasLogLevel r where
getLogLevel :: r -> LogLevel
instance HasLogLevel (Env config) where
getLogLevel = envLogLevel
instance HasLogLevel LogLevel where
getLogLevel = id
class HasTerminal r where
getTerminal :: r -> Bool
instance HasTerminal (Env config) where
getTerminal = envTerminal
class HasReExec r where
getReExec :: r -> Bool
instance HasReExec (Env config) where
getReExec = envReExec
class HasSupportsUnicode r where
getSupportsUnicode :: r -> Bool
instance HasSupportsUnicode (Env config) where
getSupportsUnicode = envSupportsUnicode
newtype Sticky = Sticky
{ unSticky :: Maybe (MVar (Maybe Text))
}
class HasSticky r where
getSticky :: r -> Sticky
instance HasSticky (Env config) where
getSticky = envSticky
stack-0.1.10.0/src/Stack/Types/BuildPlan.hs 0000644 0000000 0000000 00000034322 12601012655 016372 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Shared types for various stackage packages.
module Stack.Types.BuildPlan
( -- * Types
BuildPlan (..)
, PackagePlan (..)
, PackageConstraints (..)
, TestState (..)
, SystemInfo (..)
, Maintainer (..)
, ExeName (..)
, SimpleDesc (..)
, DepInfo (..)
, Component (..)
, SnapName (..)
, MiniBuildPlan (..)
, MiniPackageInfo (..)
, renderSnapName
, parseSnapName
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow, throwM)
import Data.Aeson (FromJSON (..), ToJSON (..),
object, withObject, withText,
(.!=), (.:), (.:?), (.=))
import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HashMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Set (Set)
import Data.String (IsString, fromString)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Read (decimal)
import Data.Time (Day)
import qualified Data.Traversable as T
import Data.Typeable (TypeRep, Typeable, typeOf)
import Data.Vector (Vector)
import Distribution.System (Arch, OS (..))
import qualified Distribution.Text as DT
import qualified Distribution.Version as C
import GHC.Generics (Generic)
import Prelude -- Fix AMP warning
import Safe (readMay)
import Stack.Types.Compiler
import Stack.Types.FlagName
import Stack.Types.PackageName
import Stack.Types.Version
-- | The name of an LTS Haskell or Stackage Nightly snapshot.
data SnapName
= LTS !Int !Int
| Nightly !Day
deriving (Show, Eq, Ord)
data BuildPlan = BuildPlan
{ bpSystemInfo :: SystemInfo
, bpTools :: Vector (PackageName, Version)
, bpPackages :: Map PackageName PackagePlan
, bpGithubUsers :: Map Text (Set Text)
}
deriving (Show, Eq)
instance ToJSON BuildPlan where
toJSON BuildPlan {..} = object
[ "system-info" .= bpSystemInfo
, "tools" .= fmap goTool bpTools
, "packages" .= bpPackages
, "github-users" .= bpGithubUsers
]
where
goTool (k, v) = object
[ "name" .= k
, "version" .= v
]
instance FromJSON BuildPlan where
parseJSON = withObject "BuildPlan" $ \o -> do
bpSystemInfo <- o .: "system-info"
bpTools <- o .: "tools" >>= T.mapM goTool
bpPackages <- o .: "packages"
bpGithubUsers <- o .:? "github-users" .!= mempty
return BuildPlan {..}
where
goTool = withObject "Tool" $ \o -> (,)
<$> o .: "name"
<*> o .: "version"
data PackagePlan = PackagePlan
{ ppVersion :: Version
, ppGithubPings :: Set Text
, ppUsers :: Set PackageName
, ppConstraints :: PackageConstraints
, ppDesc :: SimpleDesc
}
deriving (Show, Eq)
instance ToJSON PackagePlan where
toJSON PackagePlan {..} = object
[ "version" .= ppVersion
, "github-pings" .= ppGithubPings
, "users" .= ppUsers
, "constraints" .= ppConstraints
, "description" .= ppDesc
]
instance FromJSON PackagePlan where
parseJSON = withObject "PackageBuild" $ \o -> do
ppVersion <- o .: "version"
ppGithubPings <- o .:? "github-pings" .!= mempty
ppUsers <- o .:? "users" .!= mempty
ppConstraints <- o .: "constraints"
ppDesc <- o .: "description"
return PackagePlan {..}
display :: DT.Text a => a -> Text
display = fromString . DT.display
simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a
simpleParse orig = withTypeRep $ \rep ->
case DT.simpleParse str of
Nothing -> throwM (ParseFailedException rep (pack str))
Just v -> return v
where
str = unpack orig
withTypeRep :: Typeable a => (TypeRep -> m a) -> m a
withTypeRep f =
res
where
res = f (typeOf (unwrap res))
unwrap :: m a -> a
unwrap _ = error "unwrap"
data BuildPlanTypesException
= ParseSnapNameException Text
| ParseFailedException TypeRep Text
deriving Typeable
instance Exception BuildPlanTypesException
instance Show BuildPlanTypesException where
show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t
show (ParseFailedException rep t) =
"Unable to parse " ++ show t ++ " as " ++ show rep
data PackageConstraints = PackageConstraints
{ pcVersionRange :: VersionRange
, pcMaintainer :: Maybe Maintainer
, pcTests :: TestState
, pcHaddocks :: TestState
, pcBuildBenchmarks :: Bool
, pcFlagOverrides :: Map FlagName Bool
, pcEnableLibProfile :: Bool
}
deriving (Show, Eq)
instance ToJSON PackageConstraints where
toJSON PackageConstraints {..} = object $ addMaintainer
[ "version-range" .= display pcVersionRange
, "tests" .= pcTests
, "haddocks" .= pcHaddocks
, "build-benchmarks" .= pcBuildBenchmarks
, "flags" .= pcFlagOverrides
, "library-profiling" .= pcEnableLibProfile
]
where
addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer
instance FromJSON PackageConstraints where
parseJSON = withObject "PackageConstraints" $ \o -> do
pcVersionRange <- (o .: "version-range")
>>= either (fail . show) return . simpleParse
pcTests <- o .: "tests"
pcHaddocks <- o .: "haddocks"
pcBuildBenchmarks <- o .: "build-benchmarks"
pcFlagOverrides <- o .: "flags"
pcMaintainer <- o .:? "maintainer"
pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")
return PackageConstraints {..}
data TestState = ExpectSuccess
| ExpectFailure
| Don'tBuild -- ^ when the test suite will pull in things we don't want
deriving (Show, Eq, Ord, Bounded, Enum)
testStateToText :: TestState -> Text
testStateToText ExpectSuccess = "expect-success"
testStateToText ExpectFailure = "expect-failure"
testStateToText Don'tBuild = "do-not-build"
instance ToJSON TestState where
toJSON = toJSON . testStateToText
instance FromJSON TestState where
parseJSON = withText "TestState" $ \t ->
case HashMap.lookup t states of
Nothing -> fail $ "Invalid state: " ++ unpack t
Just v -> return v
where
states = HashMap.fromList
$ map (\x -> (testStateToText x, x)) [minBound..maxBound]
data SystemInfo = SystemInfo
{ siCompilerVersion :: CompilerVersion
, siOS :: OS
, siArch :: Arch
, siCorePackages :: Map PackageName Version
, siCoreExecutables :: Set ExeName
}
deriving (Show, Eq, Ord)
instance ToJSON SystemInfo where
toJSON SystemInfo {..} = object $
(case siCompilerVersion of
GhcVersion version -> "ghc-version" .= version
_ -> "compiler-version" .= siCompilerVersion) :
[ "os" .= display siOS
, "arch" .= display siArch
, "core-packages" .= siCorePackages
, "core-executables" .= siCoreExecutables
]
instance FromJSON SystemInfo where
parseJSON = withObject "SystemInfo" $ \o -> do
let helper name = (o .: name) >>= either (fail . show) return . simpleParse
ghcVersion <- o .:? "ghc-version"
compilerVersion <- o .:? "compiler-version"
siCompilerVersion <-
case (ghcVersion, compilerVersion) of
(Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields"
(Just ghc, _) -> return (GhcVersion ghc)
(_, Just compiler) -> return compiler
_ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present"
siOS <- helper "os"
siArch <- helper "arch"
siCorePackages <- o .: "core-packages"
siCoreExecutables <- o .: "core-executables"
return SystemInfo {..}
newtype Maintainer = Maintainer { unMaintainer :: Text }
deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)
-- | Name of an executable.
newtype ExeName = ExeName { unExeName :: ByteString }
deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData)
instance HasStructuralInfo ExeName
instance ToJSON ExeName where
toJSON = toJSON . S8.unpack . unExeName
instance FromJSON ExeName where
parseJSON = withText "ExeName" $ return . ExeName . encodeUtf8
-- | A simplified package description that tracks:
--
-- * Package dependencies
--
-- * Build tool dependencies
--
-- * Provided executables
--
-- It has fully resolved all conditionals
data SimpleDesc = SimpleDesc
{ sdPackages :: Map PackageName DepInfo
, sdTools :: Map ExeName DepInfo
, sdProvidedExes :: Set ExeName
, sdModules :: Set Text
-- ^ modules exported by the library
}
deriving (Show, Eq)
instance Monoid SimpleDesc where
mempty = SimpleDesc mempty mempty mempty mempty
mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc
(Map.unionWith (<>) a w)
(Map.unionWith (<>) b x)
(c <> y)
(d <> z)
instance ToJSON SimpleDesc where
toJSON SimpleDesc {..} = object
[ "packages" .= sdPackages
, "tools" .= sdTools
, "provided-exes" .= sdProvidedExes
, "modules" .= sdModules
]
instance FromJSON SimpleDesc where
parseJSON = withObject "SimpleDesc" $ \o -> do
sdPackages <- o .: "packages"
sdTools <- o .: "tools"
sdProvidedExes <- o .: "provided-exes"
sdModules <- o .: "modules"
return SimpleDesc {..}
data DepInfo = DepInfo
{ diComponents :: Set Component
, diRange :: VersionRange
}
deriving (Show, Eq)
instance Monoid DepInfo where
mempty = DepInfo mempty C.anyVersion
DepInfo a x `mappend` DepInfo b y = DepInfo
(mappend a b)
(C.intersectVersionRanges x y)
instance ToJSON DepInfo where
toJSON DepInfo {..} = object
[ "components" .= diComponents
, "range" .= display diRange
]
instance FromJSON DepInfo where
parseJSON = withObject "DepInfo" $ \o -> do
diComponents <- o .: "components"
diRange <- o .: "range" >>= either (fail . show) return . simpleParse
return DepInfo {..}
data Component = CompLibrary
| CompExecutable
| CompTestSuite
| CompBenchmark
deriving (Show, Read, Eq, Ord, Enum, Bounded)
compToText :: Component -> Text
compToText CompLibrary = "library"
compToText CompExecutable = "executable"
compToText CompTestSuite = "test-suite"
compToText CompBenchmark = "benchmark"
instance ToJSON Component where
toJSON = toJSON . compToText
instance FromJSON Component where
parseJSON = withText "Component" $ \t -> maybe
(fail $ "Invalid component: " ++ unpack t)
return
(HashMap.lookup t comps)
where
comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound]
-- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@,
-- @nightly-2015-03-05@.
renderSnapName :: SnapName -> Text
renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y]
renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d
-- | Parse the short representation of a 'SnapName'.
parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName t0 =
case lts <|> nightly of
Nothing -> throwM $ ParseSnapNameException t0
Just sn -> return sn
where
lts = do
t1 <- T.stripPrefix "lts-" t0
Right (x, t2) <- Just $ decimal t1
t3 <- T.stripPrefix "." t2
Right (y, "") <- Just $ decimal t3
return $ LTS x y
nightly = do
t1 <- T.stripPrefix "nightly-" t0
Nightly <$> readMay (T.unpack t1)
instance ToJSON a => ToJSON (Map ExeName a) where
toJSON = toJSON . Map.mapKeysWith const (S8.unpack . unExeName)
instance FromJSON a => FromJSON (Map ExeName a) where
parseJSON = fmap (Map.mapKeysWith const (ExeName . encodeUtf8)) . parseJSON
-- | A simplified version of the 'BuildPlan' + cabal file.
data MiniBuildPlan = MiniBuildPlan
{ mbpCompilerVersion :: !CompilerVersion
, mbpPackages :: !(Map PackageName MiniPackageInfo)
}
deriving (Generic, Show, Eq)
instance Binary MiniBuildPlan
instance NFData MiniBuildPlan
instance HasStructuralInfo MiniBuildPlan
instance HasSemanticVersion MiniBuildPlan
-- | Information on a single package for the 'MiniBuildPlan'.
data MiniPackageInfo = MiniPackageInfo
{ mpiVersion :: !Version
, mpiFlags :: !(Map FlagName Bool)
, mpiPackageDeps :: !(Set PackageName)
, mpiToolDeps :: !(Set ByteString)
-- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the
-- executable name, the package name, or something else. We have to guess
-- based on what's available, which is why we store this is an unwrapped
-- 'ByteString'.
, mpiExes :: !(Set ExeName)
-- ^ Executables provided by this package
, mpiHasLibrary :: !Bool
-- ^ Is there a library present?
}
deriving (Generic, Show, Eq)
instance Binary MiniPackageInfo
instance HasStructuralInfo MiniPackageInfo
instance NFData MiniPackageInfo
stack-0.1.10.0/src/Stack/Types/Compiler.hs 0000644 0000000 0000000 00000007321 12623647202 016277 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
module Stack.Types.Compiler where
import Control.DeepSeq
import Data.Aeson
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import qualified Data.Text as T
import GHC.Generics (Generic)
import Stack.Types.Version
-- | Variety of compiler to use.
data WhichCompiler
= Ghc
| Ghcjs
deriving (Show, Eq, Ord)
-- | Specifies a compiler and its version number(s).
--
-- Note that despite having this datatype, stack isn't in a hurry to
-- support compilers other than GHC.
--
-- NOTE: updating this will change its binary serialization. The
-- version number in the 'BinarySchema' instance for 'MiniBuildPlan'
-- should be updated.
data CompilerVersion
= GhcVersion {-# UNPACK #-} !Version
| GhcjsVersion
{-# UNPACK #-} !Version -- GHCJS version
{-# UNPACK #-} !Version -- GHC version
deriving (Generic, Show, Eq, Ord)
instance Binary CompilerVersion
instance HasStructuralInfo CompilerVersion
instance NFData CompilerVersion
instance ToJSON CompilerVersion where
toJSON = toJSON . compilerVersionText
instance FromJSON CompilerVersion where
parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t)
parseJSON _ = fail "Invalid CompilerVersion, must be String"
instance FromJSON a => FromJSON (Map CompilerVersion a) where
-- TODO: Dedupe with similar code in Stack.Types.Version?
--
-- Maybe this ought to be abstracted into a 'JSONKey' class, so that a
-- fully generic definition for Map can be provided.
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = do
let mparsed = parseCompilerVersion (T.pack k)
case mparsed of
Nothing -> fail $ "Failed to parse CompilerVersion " ++ k
Just parsed -> return (parsed, v)
parseCompilerVersion :: T.Text -> Maybe CompilerVersion
parseCompilerVersion t
| Just t' <- T.stripPrefix "ghc-" t
, Just v <- parseVersionFromString $ T.unpack t'
= Just (GhcVersion v)
| Just t' <- T.stripPrefix "ghcjs-" t
, [tghcjs, tghc] <- T.splitOn "_ghc-" t'
, Just vghcjs <- parseVersionFromString $ T.unpack tghcjs
, Just vghc <- parseVersionFromString $ T.unpack tghc
= Just (GhcjsVersion vghcjs vghc)
| otherwise
= Nothing
compilerVersionText :: CompilerVersion -> T.Text
compilerVersionText (GhcVersion vghc) =
"ghc-" <> versionText vghc
compilerVersionText (GhcjsVersion vghcjs vghc) =
"ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc
compilerVersionString :: CompilerVersion -> String
compilerVersionString = T.unpack . compilerVersionText
whichCompiler :: CompilerVersion -> WhichCompiler
whichCompiler GhcVersion {} = Ghc
whichCompiler GhcjsVersion {} = Ghcjs
isWantedCompiler :: VersionCheck -> CompilerVersion -> CompilerVersion -> Bool
isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) =
checkVersion check wanted actual
isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) =
checkVersion check wanted actual && checkVersion check wantedGhc actualGhc
isWantedCompiler _ _ _ = False
getGhcVersion :: CompilerVersion -> Version
getGhcVersion (GhcVersion v) = v
getGhcVersion (GhcjsVersion _ v) = v
compilerExeName :: WhichCompiler -> String
compilerExeName Ghc = "ghc"
compilerExeName Ghcjs = "ghcjs"
haddockExeName :: WhichCompiler -> String
haddockExeName Ghc = "haddock"
haddockExeName Ghcjs = "haddock-ghcjs"
stack-0.1.10.0/src/Stack/Types/Config.hs 0000644 0000000 0000000 00000176744 12630352213 015743 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | The Config type.
module Stack.Types.Config
(
-- * Main configuration types and classes
-- ** HasPlatform & HasStackRoot
HasPlatform(..)
,HasStackRoot(..)
,PlatformVariant(..)
-- ** Config & HasConfig
,Config(..)
,HasConfig(..)
,askConfig
,askLatestSnapshotUrl
,explicitSetupDeps
,getMinimalEnvOverride
-- ** BuildConfig & HasBuildConfig
,BuildConfig(..)
,bcRoot
,bcWorkDir
,HasBuildConfig(..)
-- ** GHCVariant & HasGHCVariant
,GHCVariant(..)
,ghcVariantName
,ghcVariantSuffix
,parseGHCVariant
,HasGHCVariant(..)
,snapshotsDir
-- ** EnvConfig & HasEnvConfig
,EnvConfig(..)
,HasEnvConfig(..)
,getWhichCompiler
-- * Details
-- ** ApplyGhcOptions
,ApplyGhcOptions(..)
-- ** ConfigException
,ConfigException(..)
-- ** ConfigMonoid
,ConfigMonoid(..)
-- ** EnvSettings
,EnvSettings(..)
,minimalEnvSettings
-- ** GlobalOpts & GlobalOptsMonoid
,GlobalOpts(..)
,GlobalOptsMonoid(..)
,defaultLogLevel
-- ** LoadConfig
,LoadConfig(..)
-- ** PackageEntry & PackageLocation
,PackageEntry(..)
,peExtraDep
,PackageLocation(..)
,RemotePackageType(..)
-- ** PackageIndex, IndexName & IndexLocation
,PackageIndex(..)
,IndexName(..)
,configPackageIndex
,configPackageIndexCache
,configPackageIndexGz
,configPackageIndexRoot
,configPackageTarball
,indexNameText
,IndexLocation(..)
-- ** Project & ProjectAndConfigMonoid
,Project(..)
,ProjectAndConfigMonoid(..)
-- ** PvpBounds
,PvpBounds(..)
,parsePvpBounds
-- ** Resolver & AbstractResolver
,Resolver(..)
,parseResolverText
,resolverName
,AbstractResolver(..)
-- ** SCM
,SCM(..)
-- * Paths
,bindirSuffix
,configInstalledCache
,configMiniBuildPlanCache
,configProjectWorkDir
,docDirSuffix
,flagCacheLocal
,extraBinDirs
,hpcReportDir
,installationRootDeps
,installationRootLocal
,packageDatabaseDeps
,packageDatabaseExtra
,packageDatabaseLocal
,platformOnlyRelDir
,platformVariantRelDir
,useShaPathOnWindows
,getWorkDir
-- * Command-specific types
-- ** Eval
,EvalOpts(..)
-- ** Exec
,ExecOpts(..)
,SpecialExecCmd(..)
,ExecOptsExtra(..)
-- ** Setup
,DownloadInfo(..)
,VersionedDownloadInfo(..)
,SetupInfo(..)
,SetupInfoLocation(..)
-- ** Docker entrypoint
,DockerEntrypoint(..)
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception
import Control.Monad (liftM, mzero, forM)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger (LogLevel(..))
import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
import Data.Aeson.Extended
(ToJSON, toJSON, FromJSON, parseJSON, withText, object,
(.=), (..:), (..:?), (..!=), Value(String, Object),
withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning,
jsonSubWarningsT, jsonSubWarningsTT)
import Data.Attoparsec.Args
import Data.Binary (Binary)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Either (partitionEithers)
import Data.List (stripPrefix)
import Data.Hashable (Hashable)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Typeable
import Data.Yaml (ParseException)
import Distribution.System (Platform)
import qualified Distribution.Text
import Distribution.Version (anyVersion)
import Network.HTTP.Client (parseUrl)
import Path
import qualified Paths_stack as Meta
import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
import Stack.Types.Compiler
import Stack.Types.Docker
import Stack.Types.Nix
import Stack.Types.FlagName
import Stack.Types.Image
import Stack.Types.PackageIdentifier
import Stack.Types.PackageIndex
import Stack.Types.PackageName
import Stack.Types.Version
import System.PosixCompat.Types (UserID, GroupID)
import System.Process.Read (EnvOverride)
#ifdef mingw32_HOST_OS
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as B16
#endif
-- | The top-level Stackage configuration.
data Config =
Config {configStackRoot :: !(Path Abs Dir)
-- ^ ~/.stack more often than not
,configWorkDir :: !(Path Rel Dir)
-- ^ this allows to override .stack-work directory
,configUserConfigPath :: !(Path Abs File)
-- ^ Path to user configuration file (usually ~/.stack/config.yaml)
,configDocker :: !DockerOpts
-- ^ Docker configuration
,configNix :: !NixOpts
-- ^ Execution environment (e.g nix-shell) configuration
,configEnvOverride :: !(EnvSettings -> IO EnvOverride)
-- ^ Environment variables to be passed to external tools
,configLocalProgramsBase :: !(Path Abs Dir)
-- ^ Non-platform-specific path containing local installations
,configLocalPrograms :: !(Path Abs Dir)
-- ^ Path containing local installations (mainly GHC)
,configConnectionCount :: !Int
-- ^ How many concurrent connections are allowed when downloading
,configHideTHLoading :: !Bool
-- ^ Hide the Template Haskell "Loading package ..." messages from the
-- console
,configPlatform :: !Platform
-- ^ The platform we're building for, used in many directory names
,configPlatformVariant :: !PlatformVariant
-- ^ Variant of the platform, also used in directory names
,configGHCVariant0 :: !(Maybe GHCVariant)
-- ^ The variant of GHC requested by the user.
-- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,
-- which will have an auto-detected default.
,configLatestSnapshotUrl :: !Text
-- ^ URL for a JSON file containing information on the latest
-- snapshots available.
,configPackageIndices :: ![PackageIndex]
-- ^ Information on package indices. This is left biased, meaning that
-- packages in an earlier index will shadow those in a later index.
--
-- Warning: if you override packages in an index vs what's available
-- upstream, you may correct your compiled snapshots, as different
-- projects may have different definitions of what pkg-ver means! This
-- feature is primarily intended for adding local packages, not
-- overriding. Overriding is better accomplished by adding to your
-- list of packages.
--
-- Note that indices specified in a later config file will override
-- previous indices, /not/ extend them.
--
-- Using an assoc list instead of a Map to keep track of priority
,configSystemGHC :: !Bool
-- ^ Should we use the system-installed GHC (on the PATH) if
-- available? Can be overridden by command line options.
,configInstallGHC :: !Bool
-- ^ Should we automatically install GHC if missing or the wrong
-- version is available? Can be overridden by command line options.
,configSkipGHCCheck :: !Bool
-- ^ Don't bother checking the GHC version or architecture.
,configSkipMsys :: !Bool
-- ^ On Windows: don't use a locally installed MSYS
,configCompilerCheck :: !VersionCheck
-- ^ Specifies which versions of the compiler are acceptable.
,configLocalBin :: !(Path Abs Dir)
-- ^ Directory we should install executables into
,configRequireStackVersion :: !VersionRange
-- ^ Require a version of stack within this range.
,configJobs :: !Int
-- ^ How many concurrent jobs to run, defaults to number of capabilities
,configExtraIncludeDirs :: !(Set Text)
-- ^ --extra-include-dirs arguments
,configExtraLibDirs :: !(Set Text)
-- ^ --extra-lib-dirs arguments
,configConfigMonoid :: !ConfigMonoid
-- ^ @ConfigMonoid@ used to generate this
,configConcurrentTests :: !Bool
-- ^ Run test suites concurrently
,configImage :: !ImageOpts
,configTemplateParams :: !(Map Text Text)
-- ^ Parameters for templates.
,configScmInit :: !(Maybe SCM)
-- ^ Initialize SCM (e.g. git) when creating new projects.
,configGhcOptions :: !(Map (Maybe PackageName) [Text])
-- ^ Additional GHC options to apply to either all packages (Nothing)
-- or a specific package (Just).
,configSetupInfoLocations :: ![SetupInfoLocation]
-- ^ Additional SetupInfo (inline or remote) to use to find tools.
,configPvpBounds :: !PvpBounds
-- ^ How PVP upper bounds should be added to packages
,configModifyCodePage :: !Bool
-- ^ Force the code page to UTF-8 on Windows
,configExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
-- ^ See 'explicitSetupDeps'. 'Nothing' provides the default value.
,configRebuildGhcOptions :: !Bool
-- ^ Rebuild on GHC options changes
,configApplyGhcOptions :: !ApplyGhcOptions
-- ^ Which packages to ghc-options on the command line apply to?
,configAllowNewer :: !Bool
-- ^ Ignore version ranges in .cabal files. Funny naming chosen to
-- match cabal.
}
-- | Which packages to ghc-options on the command line apply to?
data ApplyGhcOptions = AGOTargets -- ^ all local targets
| AGOLocals -- ^ all local packages, even non-targets
| AGOEverything -- ^ every package
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON ApplyGhcOptions where
parseJSON = withText "ApplyGhcOptions" $ \t ->
case t of
"targets" -> return AGOTargets
"locals" -> return AGOLocals
"everything" -> return AGOEverything
_ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
-- | Information on a single package index
data PackageIndex = PackageIndex
{ indexName :: !IndexName
, indexLocation :: !IndexLocation
, indexDownloadPrefix :: !Text
-- ^ URL prefix for downloading packages
, indexGpgVerify :: !Bool
-- ^ GPG-verify the package index during download. Only applies to Git
-- repositories for now.
, indexRequireHashes :: !Bool
-- ^ Require that hashes and package size information be available for packages in this index
}
deriving Show
instance FromJSON (PackageIndex, [JSONWarning]) where
parseJSON = withObjectWarnings "PackageIndex" $ \o -> do
name <- o ..: "name"
prefix <- o ..: "download-prefix"
mgit <- o ..:? "git"
mhttp <- o ..:? "http"
loc <-
case (mgit, mhttp) of
(Nothing, Nothing) -> fail $
"Must provide either Git or HTTP URL for " ++
T.unpack (indexNameText name)
(Just git, Nothing) -> return $ ILGit git
(Nothing, Just http) -> return $ ILHttp http
(Just git, Just http) -> return $ ILGitHttp git http
gpgVerify <- o ..:? "gpg-verify" ..!= False
reqHashes <- o ..:? "require-hashes" ..!= False
return PackageIndex
{ indexName = name
, indexLocation = loc
, indexDownloadPrefix = prefix
, indexGpgVerify = gpgVerify
, indexRequireHashes = reqHashes
}
-- | Unique name for a package index
newtype IndexName = IndexName { unIndexName :: ByteString }
deriving (Show, Eq, Ord, Hashable, Binary)
indexNameText :: IndexName -> Text
indexNameText = decodeUtf8 . unIndexName
instance ToJSON IndexName where
toJSON = toJSON . indexNameText
instance FromJSON IndexName where
parseJSON = withText "IndexName" $ \t ->
case parseRelDir (T.unpack t) of
Left e -> fail $ "Invalid index name: " ++ show e
Right _ -> return $ IndexName $ encodeUtf8 t
-- | Location of the package index. This ensures that at least one of Git or
-- HTTP is available.
data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text
deriving (Show, Eq, Ord)
-- | Controls which version of the environment is used
data EnvSettings = EnvSettings
{ esIncludeLocals :: !Bool
-- ^ include local project bin directory, GHC_PACKAGE_PATH, etc
, esIncludeGhcPackagePath :: !Bool
-- ^ include the GHC_PACKAGE_PATH variable
, esStackExe :: !Bool
-- ^ set the STACK_EXE variable to the current executable name
, esLocaleUtf8 :: !Bool
-- ^ set the locale to C.UTF-8
}
deriving (Show, Eq, Ord)
data ExecOpts = ExecOpts
{ eoCmd :: !SpecialExecCmd
, eoArgs :: ![String]
, eoExtra :: !ExecOptsExtra
} deriving (Show)
data SpecialExecCmd
= ExecCmd String
| ExecGhc
| ExecRunGhc
deriving (Show, Eq)
data ExecOptsExtra
= ExecOptsPlain
| ExecOptsEmbellished
{ eoEnvSettings :: !EnvSettings
, eoPackages :: ![String]
}
deriving (Show)
data EvalOpts = EvalOpts
{ evalArg :: !String
, evalExtra :: !ExecOptsExtra
} deriving (Show)
-- | Parsed global command-line options.
data GlobalOpts = GlobalOpts
{ globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
, globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
-- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
, globalLogLevel :: !LogLevel -- ^ Log level
, globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
, globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override
, globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override
, globalTerminal :: !Bool -- ^ We're in a terminal?
, globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml
} deriving (Show)
-- | Parsed global command-line options monoid.
data GlobalOptsMonoid = GlobalOptsMonoid
{ globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
, globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint)
-- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
, globalMonoidLogLevel :: !(Maybe LogLevel) -- ^ Log level
, globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
, globalMonoidResolver :: !(Maybe AbstractResolver) -- ^ Resolver override
, globalMonoidCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override
, globalMonoidTerminal :: !(Maybe Bool) -- ^ We're in a terminal?
, globalMonoidStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml
} deriving (Show)
instance Monoid GlobalOptsMonoid where
mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing
mappend l r = GlobalOptsMonoid
{ globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r
, globalMonoidDockerEntrypoint =
globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r
, globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r
, globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r
, globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r
, globalMonoidCompiler = globalMonoidCompiler l <|> globalMonoidCompiler r
, globalMonoidTerminal = globalMonoidTerminal l <|> globalMonoidTerminal r
, globalMonoidStackYaml = globalMonoidStackYaml l <|> globalMonoidStackYaml r }
-- | Either an actual resolver value, or an abstract description of one (e.g.,
-- latest nightly).
data AbstractResolver
= ARLatestNightly
| ARLatestLTS
| ARLatestLTSMajor !Int
| ARResolver !Resolver
| ARGlobal
deriving Show
-- | Default logging level should be something useful but not crazy.
defaultLogLevel :: LogLevel
defaultLogLevel = LevelInfo
-- | A superset of 'Config' adding information on how to build code. The reason
-- for this breakdown is because we will need some of the information from
-- 'Config' in order to determine the values here.
data BuildConfig = BuildConfig
{ bcConfig :: !Config
, bcResolver :: !Resolver
-- ^ How we resolve which dependencies to install given a set of
-- packages.
, bcWantedCompiler :: !CompilerVersion
-- ^ Compiler version wanted for this build
, bcPackageEntries :: ![PackageEntry]
-- ^ Local packages identified by a path, Bool indicates whether it is
-- a non-dependency (the opposite of 'peExtraDep')
, bcExtraDeps :: !(Map PackageName Version)
-- ^ Extra dependencies specified in configuration.
--
-- These dependencies will not be installed to a shared location, and
-- will override packages provided by the resolver.
, bcExtraPackageDBs :: ![Path Abs Dir]
-- ^ Extra package databases
, bcStackYaml :: !(Path Abs File)
-- ^ Location of the stack.yaml file.
--
-- Note: if the STACK_YAML environment variable is used, this may be
-- different from bcRoot "stack.yaml"
, bcFlags :: !(Map PackageName (Map FlagName Bool))
-- ^ Per-package flag overrides
, bcImplicitGlobal :: !Bool
-- ^ Are we loading from the implicit global stack.yaml? This is useful
-- for providing better error messages.
, bcGHCVariant :: !GHCVariant
-- ^ The variant of GHC used to select a GHC bindist.
, bcPackageCaches :: !(Map PackageIdentifier (PackageIndex, PackageCache))
-- ^ Shared package cache map
}
-- | Directory containing the project's stack.yaml file
bcRoot :: BuildConfig -> Path Abs Dir
bcRoot = parent . bcStackYaml
-- | @"'bcRoot'/.stack-work"@
bcWorkDir :: (MonadReader env m, HasConfig env) => BuildConfig -> m (Path Abs Dir)
bcWorkDir bconfig = do
workDir <- getWorkDir
return (bcRoot bconfig workDir)
-- | Configuration after the environment has been setup.
data EnvConfig = EnvConfig
{envConfigBuildConfig :: !BuildConfig
,envConfigCabalVersion :: !Version
,envConfigCompilerVersion :: !CompilerVersion
,envConfigPackages :: !(Map (Path Abs Dir) Bool)}
instance HasBuildConfig EnvConfig where
getBuildConfig = envConfigBuildConfig
instance HasConfig EnvConfig
instance HasPlatform EnvConfig
instance HasGHCVariant EnvConfig
instance HasStackRoot EnvConfig
class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where
getEnvConfig :: r -> EnvConfig
instance HasEnvConfig EnvConfig where
getEnvConfig = id
-- | Value returned by 'Stack.Config.loadConfig'.
data LoadConfig m = LoadConfig
{ lcConfig :: !Config
-- ^ Top-level Stack configuration.
, lcLoadBuildConfig :: !(Maybe CompilerVersion -> m BuildConfig)
-- ^ Action to load the remaining 'BuildConfig'.
, lcProjectRoot :: !(Maybe (Path Abs Dir))
-- ^ The project root directory, if in a project.
}
data PackageEntry = PackageEntry
{ peExtraDepMaybe :: !(Maybe Bool)
-- ^ Is this package a dependency? This means the local package will be
-- treated just like an extra-deps: it will only be built as a dependency
-- for others, and its test suite/benchmarks will not be run.
--
-- Useful modifying an upstream package, see:
-- https://github.com/commercialhaskell/stack/issues/219
-- https://github.com/commercialhaskell/stack/issues/386
, peValidWanted :: !(Maybe Bool)
-- ^ Deprecated name meaning the opposite of peExtraDep. Only present to
-- provide deprecation warnings to users.
, peLocation :: !PackageLocation
, peSubdirs :: ![FilePath]
}
deriving Show
-- | Once peValidWanted is removed, this should just become the field name in PackageEntry.
peExtraDep :: PackageEntry -> Bool
peExtraDep pe =
case peExtraDepMaybe pe of
Just x -> x
Nothing ->
case peValidWanted pe of
Just x -> not x
Nothing -> False
instance ToJSON PackageEntry where
toJSON pe | not (peExtraDep pe) && null (peSubdirs pe) =
toJSON $ peLocation pe
toJSON pe = object
[ "extra-dep" .= peExtraDep pe
, "location" .= peLocation pe
, "subdirs" .= peSubdirs pe
]
instance FromJSON (PackageEntry, [JSONWarning]) where
parseJSON (String t) = do
(loc, _::[JSONWarning]) <- parseJSON $ String t
return (PackageEntry
{ peExtraDepMaybe = Nothing
, peValidWanted = Nothing
, peLocation = loc
, peSubdirs = []
}, [])
parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
<$> o ..:? "extra-dep"
<*> o ..:? "valid-wanted"
<*> jsonSubWarnings (o ..: "location")
<*> o ..:? "subdirs" ..!= []) v
data PackageLocation
= PLFilePath FilePath
-- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse
-- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.
| PLRemote Text RemotePackageType
-- ^ URL and further details
deriving Show
data RemotePackageType
= RPTHttpTarball
| RPTGit Text -- ^ Commit
| RPTHg Text -- ^ Commit
deriving Show
instance ToJSON PackageLocation where
toJSON (PLFilePath fp) = toJSON fp
toJSON (PLRemote t RPTHttpTarball) = toJSON t
toJSON (PLRemote x (RPTGit y)) = toJSON $ T.unwords ["git", x, y]
toJSON (PLRemote x (RPTHg y)) = toJSON $ T.unwords ["hg", x, y]
instance FromJSON (PackageLocation, [JSONWarning]) where
parseJSON v
= ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v)
<|> git v
<|> hg v
where
file t = pure $ PLFilePath $ T.unpack t
http t =
case parseUrl $ T.unpack t of
Left _ -> mzero
Right _ -> return $ PLRemote t RPTHttpTarball
git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote
<$> o ..: "git"
<*> (RPTGit <$> o ..: "commit")
hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote
<$> o ..: "hg"
<*> (RPTHg <$> o ..: "commit")
-- | A project is a collection of packages. We can have multiple stack.yaml
-- files, but only one of them may contain project information.
data Project = Project
{ projectPackages :: ![PackageEntry]
-- ^ Components of the package list
, projectExtraDeps :: !(Map PackageName Version)
-- ^ Components of the package list referring to package/version combos,
-- see: https://github.com/fpco/stack/issues/41
, projectFlags :: !(Map PackageName (Map FlagName Bool))
-- ^ Per-package flag overrides
, projectResolver :: !Resolver
-- ^ How we resolve which dependencies to use
, projectCompiler :: !(Maybe CompilerVersion)
-- ^ When specified, overrides which compiler to use
, projectExtraPackageDBs :: ![FilePath]
}
deriving Show
instance ToJSON Project where
toJSON p = object $
(maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p))
[ "packages" .= projectPackages p
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
, "flags" .= projectFlags p
, "resolver" .= projectResolver p
, "extra-package-dbs" .= projectExtraPackageDBs p
]
-- | How we resolve which dependencies to install given a set of packages.
data Resolver
= ResolverSnapshot SnapName
-- ^ Use an official snapshot from the Stackage project, either an LTS
-- Haskell or Stackage Nightly
| ResolverCompiler !CompilerVersion
-- ^ Require a specific compiler version, but otherwise provide no build plan.
-- Intended for use cases where end user wishes to specify all upstream
-- dependencies manually, such as using a dependency solver.
| ResolverCustom !Text !Text
-- ^ A custom resolver based on the given name and URL. This file is assumed
-- to be completely immutable.
deriving (Show)
instance ToJSON Resolver where
toJSON (ResolverCustom name location) = object
[ "name" .= name
, "location" .= location
]
toJSON x = toJSON $ resolverName x
instance FromJSON (Resolver,[JSONWarning]) where
-- Strange structuring is to give consistent error messages
parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom
<$> o ..: "name"
<*> o ..: "location") v
parseJSON (String t) = either (fail . show) return ((,[]) <$> parseResolverText t)
parseJSON _ = fail $ "Invalid Resolver, must be Object or String"
-- | Convert a Resolver into its @Text@ representation, as will be used by
-- directory names
resolverName :: Resolver -> Text
resolverName (ResolverSnapshot name) = renderSnapName name
resolverName (ResolverCompiler v) = compilerVersionText v
resolverName (ResolverCustom name _) = "custom-" <> name
-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).
parseResolverText :: MonadThrow m => Text -> m Resolver
parseResolverText t
| Right x <- parseSnapName t = return $ ResolverSnapshot x
| Just v <- parseCompilerVersion t = return $ ResolverCompiler v
| otherwise = throwM $ ParseResolverException t
-- | Class for environment values which have access to the stack root
class HasStackRoot env where
getStackRoot :: env -> Path Abs Dir
default getStackRoot :: HasConfig env => env -> Path Abs Dir
getStackRoot = configStackRoot . getConfig
{-# INLINE getStackRoot #-}
-- | Class for environment values which have a Platform
class HasPlatform env where
getPlatform :: env -> Platform
default getPlatform :: HasConfig env => env -> Platform
getPlatform = configPlatform . getConfig
{-# INLINE getPlatform #-}
getPlatformVariant :: env -> PlatformVariant
default getPlatformVariant :: HasConfig env => env -> PlatformVariant
getPlatformVariant = configPlatformVariant . getConfig
{-# INLINE getPlatformVariant #-}
instance HasPlatform (Platform,PlatformVariant) where
getPlatform (p,_) = p
getPlatformVariant (_,v) = v
-- | Class for environment values which have a GHCVariant
class HasGHCVariant env where
getGHCVariant :: env -> GHCVariant
default getGHCVariant :: HasBuildConfig env => env -> GHCVariant
getGHCVariant = bcGHCVariant . getBuildConfig
{-# INLINE getGHCVariant #-}
instance HasGHCVariant GHCVariant where
getGHCVariant = id
-- | Class for environment values that can provide a 'Config'.
class (HasStackRoot env, HasPlatform env) => HasConfig env where
getConfig :: env -> Config
default getConfig :: HasBuildConfig env => env -> Config
getConfig = bcConfig . getBuildConfig
{-# INLINE getConfig #-}
instance HasStackRoot Config
instance HasPlatform Config
instance HasConfig Config where
getConfig = id
{-# INLINE getConfig #-}
-- | Class for environment values that can provide a 'BuildConfig'.
class HasConfig env => HasBuildConfig env where
getBuildConfig :: env -> BuildConfig
instance HasStackRoot BuildConfig
instance HasPlatform BuildConfig
instance HasGHCVariant BuildConfig
instance HasConfig BuildConfig
instance HasBuildConfig BuildConfig where
getBuildConfig = id
{-# INLINE getBuildConfig #-}
-- An uninterpreted representation of configuration options.
-- Configurations may be "cascaded" using mappend (left-biased).
data ConfigMonoid =
ConfigMonoid
{ configMonoidWorkDir :: !(Maybe FilePath)
-- ^ See: 'configWorkDir'.
, configMonoidDockerOpts :: !DockerOptsMonoid
-- ^ Docker options.
, configMonoidNixOpts :: !NixOptsMonoid
-- ^ Options for the execution environment (nix-shell or container)
, configMonoidConnectionCount :: !(Maybe Int)
-- ^ See: 'configConnectionCount'
, configMonoidHideTHLoading :: !(Maybe Bool)
-- ^ See: 'configHideTHLoading'
, configMonoidLatestSnapshotUrl :: !(Maybe Text)
-- ^ See: 'configLatestSnapshotUrl'
, configMonoidPackageIndices :: !(Maybe [PackageIndex])
-- ^ See: 'configPackageIndices'
, configMonoidSystemGHC :: !(Maybe Bool)
-- ^ See: 'configSystemGHC'
,configMonoidInstallGHC :: !(Maybe Bool)
-- ^ See: 'configInstallGHC'
,configMonoidSkipGHCCheck :: !(Maybe Bool)
-- ^ See: 'configSkipGHCCheck'
,configMonoidSkipMsys :: !(Maybe Bool)
-- ^ See: 'configSkipMsys'
,configMonoidCompilerCheck :: !(Maybe VersionCheck)
-- ^ See: 'configCompilerCheck'
,configMonoidRequireStackVersion :: !VersionRange
-- ^ See: 'configRequireStackVersion'
,configMonoidOS :: !(Maybe String)
-- ^ Used for overriding the platform
,configMonoidArch :: !(Maybe String)
-- ^ Used for overriding the platform
,configMonoidGHCVariant :: !(Maybe GHCVariant)
-- ^ Used for overriding the GHC variant
,configMonoidJobs :: !(Maybe Int)
-- ^ See: 'configJobs'
,configMonoidExtraIncludeDirs :: !(Set Text)
-- ^ See: 'configExtraIncludeDirs'
,configMonoidExtraLibDirs :: !(Set Text)
-- ^ See: 'configExtraLibDirs'
,configMonoidConcurrentTests :: !(Maybe Bool)
-- ^ See: 'configConcurrentTests'
,configMonoidLocalBinPath :: !(Maybe FilePath)
-- ^ Used to override the binary installation dir
,configMonoidImageOpts :: !ImageOptsMonoid
-- ^ Image creation options.
,configMonoidTemplateParameters :: !(Map Text Text)
-- ^ Template parameters.
,configMonoidScmInit :: !(Maybe SCM)
-- ^ Initialize SCM (e.g. git init) when making new projects?
,configMonoidGhcOptions :: !(Map (Maybe PackageName) [Text])
-- ^ See 'configGhcOptions'
,configMonoidExtraPath :: ![Path Abs Dir]
-- ^ Additional paths to search for executables in
,configMonoidSetupInfoLocations :: ![SetupInfoLocation]
-- ^ Additional setup info (inline or remote) to use for installing tools
,configMonoidPvpBounds :: !(Maybe PvpBounds)
-- ^ See 'configPvpBounds'
,configMonoidModifyCodePage :: !(Maybe Bool)
-- ^ See 'configModifyCodePage'
,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
-- ^ See 'configExplicitSetupDeps'
,configMonoidRebuildGhcOptions :: !(Maybe Bool)
-- ^ See 'configMonoidRebuildGhcOptions'
,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions)
-- ^ See 'configApplyGhcOptions'
,configMonoidAllowNewer :: !(Maybe Bool)
-- ^ See 'configMonoidAllowNewer'
}
deriving Show
instance Monoid ConfigMonoid where
mempty = ConfigMonoid
{ configMonoidWorkDir = Nothing
, configMonoidDockerOpts = mempty
, configMonoidNixOpts = mempty
, configMonoidConnectionCount = Nothing
, configMonoidHideTHLoading = Nothing
, configMonoidLatestSnapshotUrl = Nothing
, configMonoidPackageIndices = Nothing
, configMonoidSystemGHC = Nothing
, configMonoidInstallGHC = Nothing
, configMonoidSkipGHCCheck = Nothing
, configMonoidSkipMsys = Nothing
, configMonoidRequireStackVersion = anyVersion
, configMonoidOS = Nothing
, configMonoidArch = Nothing
, configMonoidGHCVariant = Nothing
, configMonoidJobs = Nothing
, configMonoidExtraIncludeDirs = Set.empty
, configMonoidExtraLibDirs = Set.empty
, configMonoidConcurrentTests = Nothing
, configMonoidLocalBinPath = Nothing
, configMonoidImageOpts = mempty
, configMonoidTemplateParameters = mempty
, configMonoidScmInit = Nothing
, configMonoidCompilerCheck = Nothing
, configMonoidGhcOptions = mempty
, configMonoidExtraPath = []
, configMonoidSetupInfoLocations = mempty
, configMonoidPvpBounds = Nothing
, configMonoidModifyCodePage = Nothing
, configMonoidExplicitSetupDeps = mempty
, configMonoidRebuildGhcOptions = Nothing
, configMonoidApplyGhcOptions = Nothing
, configMonoidAllowNewer = Nothing
}
mappend l r = ConfigMonoid
{ configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r
, configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
, configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r
, configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r
, configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r
, configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r
, configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r
, configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r
, configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r
, configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r
, configMonoidSkipMsys = configMonoidSkipMsys l <|> configMonoidSkipMsys r
, configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l)
(configMonoidRequireStackVersion r)
, configMonoidOS = configMonoidOS l <|> configMonoidOS r
, configMonoidArch = configMonoidArch l <|> configMonoidArch r
, configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r
, configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r
, configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)
, configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)
, configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
, configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r
, configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r
, configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r
, configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r
, configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r
, configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r)
, configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r
, configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r
, configMonoidPvpBounds = configMonoidPvpBounds l <|> configMonoidPvpBounds r
, configMonoidModifyCodePage = configMonoidModifyCodePage l <|> configMonoidModifyCodePage r
, configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r
, configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r
, configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r
, configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r
}
instance FromJSON (ConfigMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON
-- | Parse a partial configuration. Used both to parse both a standalone config
-- file and a project file, so that a sub-parser is not required, which would interfere with
-- warnings for missing fields.
parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
parseConfigMonoidJSON obj = do
configMonoidWorkDir <- obj ..:? configMonoidWorkDirName
configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)
configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)
configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName
configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName
configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName
configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)
configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName
configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName
configMonoidSkipGHCCheck <- obj ..:? configMonoidSkipGHCCheckName
configMonoidSkipMsys <- obj ..:? configMonoidSkipMsysName
configMonoidRequireStackVersion <- unVersionRangeJSON <$>
obj ..:? configMonoidRequireStackVersionName
..!= VersionRangeJSON anyVersion
configMonoidOS <- obj ..:? configMonoidOSName
configMonoidArch <- obj ..:? configMonoidArchName
configMonoidGHCVariant <- obj ..:? configMonoidGHCVariantName
configMonoidJobs <- obj ..:? configMonoidJobsName
configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty
configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty
configMonoidConcurrentTests <- obj ..:? configMonoidConcurrentTestsName
configMonoidLocalBinPath <- obj ..:? configMonoidLocalBinPathName
configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty)
templates <- obj ..:? "templates"
(configMonoidScmInit,configMonoidTemplateParameters) <-
case templates of
Nothing -> return (Nothing,M.empty)
Just tobj -> do
scmInit <- tobj ..:? configMonoidScmInitName
params <- tobj ..:? configMonoidTemplateParametersName
return (scmInit,fromMaybe M.empty params)
configMonoidCompilerCheck <- obj ..:? configMonoidCompilerCheckName
mghcoptions <- obj ..:? configMonoidGhcOptionsName
configMonoidGhcOptions <-
case mghcoptions of
Nothing -> return mempty
Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m
extraPath <- obj ..:? configMonoidExtraPathName ..!= []
configMonoidExtraPath <- forM extraPath $
either (fail . show) return . parseAbsDir . T.unpack
configMonoidSetupInfoLocations <-
maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)
configMonoidPvpBounds <- obj ..:? configMonoidPvpBoundsName
configMonoidModifyCodePage <- obj ..:? configMonoidModifyCodePageName
configMonoidExplicitSetupDeps <-
(obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)
>>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList
configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName
configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName
configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName
return ConfigMonoid {..}
where
handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])
handleGhcOptions (name', vals') = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right x -> return $ Just x
case parseArgs Escaping vals' of
Left e -> fail e
Right vals -> return (name, map T.pack vals)
handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)
handleExplicitSetupDep (name', b) = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right x -> return $ Just x
return (name, b)
configMonoidWorkDirName :: Text
configMonoidWorkDirName = "work-dir"
configMonoidDockerOptsName :: Text
configMonoidDockerOptsName = "docker"
configMonoidNixOptsName :: Text
configMonoidNixOptsName = "nix"
configMonoidConnectionCountName :: Text
configMonoidConnectionCountName = "connection-count"
configMonoidHideTHLoadingName :: Text
configMonoidHideTHLoadingName = "hide-th-loading"
configMonoidLatestSnapshotUrlName :: Text
configMonoidLatestSnapshotUrlName = "latest-snapshot-url"
configMonoidPackageIndicesName :: Text
configMonoidPackageIndicesName = "package-indices"
configMonoidSystemGHCName :: Text
configMonoidSystemGHCName = "system-ghc"
configMonoidInstallGHCName :: Text
configMonoidInstallGHCName = "install-ghc"
configMonoidSkipGHCCheckName :: Text
configMonoidSkipGHCCheckName = "skip-ghc-check"
configMonoidSkipMsysName :: Text
configMonoidSkipMsysName = "skip-msys"
configMonoidRequireStackVersionName :: Text
configMonoidRequireStackVersionName = "require-stack-version"
configMonoidOSName :: Text
configMonoidOSName = "os"
configMonoidArchName :: Text
configMonoidArchName = "arch"
configMonoidGHCVariantName :: Text
configMonoidGHCVariantName = "ghc-variant"
configMonoidJobsName :: Text
configMonoidJobsName = "jobs"
configMonoidExtraIncludeDirsName :: Text
configMonoidExtraIncludeDirsName = "extra-include-dirs"
configMonoidExtraLibDirsName :: Text
configMonoidExtraLibDirsName = "extra-lib-dirs"
configMonoidConcurrentTestsName :: Text
configMonoidConcurrentTestsName = "concurrent-tests"
configMonoidLocalBinPathName :: Text
configMonoidLocalBinPathName = "local-bin-path"
configMonoidImageOptsName :: Text
configMonoidImageOptsName = "image"
configMonoidScmInitName :: Text
configMonoidScmInitName = "scm-init"
configMonoidTemplateParametersName :: Text
configMonoidTemplateParametersName = "params"
configMonoidCompilerCheckName :: Text
configMonoidCompilerCheckName = "compiler-check"
configMonoidGhcOptionsName :: Text
configMonoidGhcOptionsName = "ghc-options"
configMonoidExtraPathName :: Text
configMonoidExtraPathName = "extra-path"
configMonoidSetupInfoLocationsName :: Text
configMonoidSetupInfoLocationsName = "setup-info"
configMonoidPvpBoundsName :: Text
configMonoidPvpBoundsName = "pvp-bounds"
configMonoidModifyCodePageName :: Text
configMonoidModifyCodePageName = "modify-code-page"
configMonoidExplicitSetupDepsName :: Text
configMonoidExplicitSetupDepsName = "explicit-setup-deps"
configMonoidRebuildGhcOptionsName :: Text
configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"
configMonoidApplyGhcOptionsName :: Text
configMonoidApplyGhcOptionsName = "apply-ghc-options"
configMonoidAllowNewerName :: Text
configMonoidAllowNewerName = "allow-newer"
data ConfigException
= ParseConfigFileException (Path Abs File) ParseException
| ParseResolverException Text
| NoProjectConfigFound (Path Abs Dir) (Maybe Text)
| UnexpectedTarballContents [Path Abs Dir] [Path Abs File]
| BadStackVersionException VersionRange
| NoMatchingSnapshot [SnapName]
| NoSuchDirectory FilePath
| ParseGHCVariantException String
deriving Typeable
instance Show ConfigException where
show (ParseConfigFileException configFile exception) = concat
[ "Could not parse '"
, toFilePath configFile
, "':\n"
, show exception
, "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md."
]
show (ParseResolverException t) = concat
[ "Invalid resolver value: "
, T.unpack t
, ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. "
, "See https://www.stackage.org/snapshots for a complete list."
]
show (NoProjectConfigFound dir mcmd) = concat
[ "Unable to find a stack.yaml file in the current directory ("
, toFilePath dir
, ") or its ancestors"
, case mcmd of
Nothing -> ""
Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
]
show (UnexpectedTarballContents dirs files) = concat
[ "When unpacking a tarball specified in your stack.yaml file, "
, "did not find expected contents. Expected: a single directory. Found: "
, show ( map (toFilePath . dirname) dirs
, map (toFilePath . filename) files
)
]
show (BadStackVersionException requiredRange) = concat
[ "The version of stack you are using ("
, show (fromCabalVersion Meta.version)
, ") is outside the required\n"
,"version range specified in stack.yaml ("
, T.unpack (versionRangeText requiredRange)
, ")." ]
show (NoMatchingSnapshot names) = concat
[ "There was no snapshot found that matched the package "
, "bounds in your .cabal files.\n"
, "Please choose one of the following commands to get started.\n\n"
, unlines $ map
(\name -> " stack init --resolver " ++ T.unpack (renderSnapName name))
names
, "\nYou'll then need to add some extra-deps. See:\n\n"
, " https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md#extra-deps"
, "\n\nYou can also try falling back to a dependency solver with:\n\n"
, " stack init --solver"
]
show (NoSuchDirectory dir) = concat
["No directory could be located matching the supplied path: "
,dir
]
show (ParseGHCVariantException v) = concat
[ "Invalid ghc-variant value: "
, v
]
instance Exception ConfigException
-- | Helper function to ask the environment and apply getConfig
askConfig :: (MonadReader env m, HasConfig env) => m Config
askConfig = liftM getConfig ask
-- | Get the URL to request the information on the latest snapshots
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
askLatestSnapshotUrl = asks (configLatestSnapshotUrl . getConfig)
-- | Root for a specific package index
configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir)
configPackageIndexRoot (IndexName name) = do
config <- asks getConfig
dir <- parseRelDir $ S8.unpack name
return (configStackRoot config $(mkRelDir "indices") dir)
-- | Location of the 00-index.cache file
configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexCache = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot
-- | Location of the 00-index.tar file
configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndex = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot
-- | Location of the 00-index.tar.gz file
configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexGz = liftM ( $(mkRelFile "00-index.tar.gz")) . configPackageIndexRoot
-- | Location of a package tarball
configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File)
configPackageTarball iname ident = do
root <- configPackageIndexRoot iname
name <- parseRelDir $ packageNameString $ packageIdentifierName ident
ver <- parseRelDir $ versionString $ packageIdentifierVersion ident
base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz"
return (root $(mkRelDir "packages") name ver base)
-- | @".stack-work"@
getWorkDir :: (MonadReader env m, HasConfig env) => m (Path Rel Dir)
getWorkDir = configWorkDir `liftM` asks getConfig
-- | Per-project work dir
configProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)
configProjectWorkDir = do
bc <- asks getBuildConfig
workDir <- getWorkDir
return (bcRoot bc workDir)
-- | File containing the installed cache, see "Stack.PackageDump"
configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)
configInstalledCache = liftM ( $(mkRelFile "installed-cache.bin")) configProjectWorkDir
-- | Relative directory for the platform identifier
platformOnlyRelDir
:: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m (Path Rel Dir)
platformOnlyRelDir = do
platform <- asks getPlatform
platformVariant <- asks getPlatformVariant
parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
-- | Directory containing snapshots
snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir)
snapshotsDir = do
config <- asks getConfig
platform <- platformVariantRelDir
return $ configStackRoot config $(mkRelDir "snapshots") platform
-- | Installation root for dependencies
installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootDeps = do
config <- asks getConfig
-- TODO: also useShaPathOnWindows here, once #1173 is resolved.
psc <- platformSnapAndCompilerRel
return $ configStackRoot config $(mkRelDir "snapshots") psc
-- | Installation root for locals
installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootLocal = do
bc <- asks getBuildConfig
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ configProjectWorkDir bc $(mkRelDir "install") psc
-- | Path for platform followed by snapshot name followed by compiler
-- name.
platformSnapAndCompilerRel
:: (MonadReader env m, HasPlatform env, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformSnapAndCompilerRel = do
bc <- asks getBuildConfig
platform <- platformVariantRelDir
name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc
ghc <- compilerVersionDir
useShaPathOnWindows (platform name ghc)
-- | Relative directory for the platform identifier
platformVariantRelDir
:: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
=> m (Path Rel Dir)
platformVariantRelDir = do
platform <- asks getPlatform
platformVariant <- asks getPlatformVariant
ghcVariant <- asks getGHCVariant
parseRelDir (mconcat [ Distribution.Text.display platform
, platformVariantSuffix platformVariant
, ghcVariantSuffix ghcVariant ])
-- | This is an attempt to shorten stack paths on Windows to decrease our
-- chances of hitting 260 symbol path limit. The idea is to calculate
-- SHA1 hash of the path used on other architectures, encode with base
-- 16 and take first 8 symbols of it.
useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows =
#ifdef mingw32_HOST_OS
parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath
#else
return
#endif
compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
compilerVersionDir = do
compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
parseRelDir $ case compilerVersion of
GhcVersion version -> versionString version
GhcjsVersion {} -> compilerVersionString compilerVersion
-- | Package database for installing dependencies into
packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseDeps = do
root <- installationRootDeps
return $ root $(mkRelDir "pkgdb")
-- | Package database for installing local packages into
packageDatabaseLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseLocal = do
root <- installationRootLocal
return $ root $(mkRelDir "pkgdb")
-- | Extra package databases
packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
packageDatabaseExtra = do
bc <- asks getBuildConfig
return $ bcExtraPackageDBs bc
-- | Directory for holding flag cache information
flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
flagCacheLocal = do
root <- installationRootLocal
return $ root $(mkRelDir "flag-cache")
-- | Where to store mini build plan caches
configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env)
=> SnapName
-> m (Path Abs File)
configMiniBuildPlanCache name = do
root <- asks getStackRoot
platform <- platformVariantRelDir
file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"
-- Yes, cached plans differ based on platform
return (root $(mkRelDir "build-plan-cache") platform file)
-- | Suffix applied to an installation root to get the bin dir
bindirSuffix :: Path Rel Dir
bindirSuffix = $(mkRelDir "bin")
-- | Suffix applied to an installation root to get the doc dir
docDirSuffix :: Path Rel Dir
docDirSuffix = $(mkRelDir "doc")
-- | Where HPC reports and tix files get stored.
hpcReportDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Path Abs Dir)
hpcReportDir = do
root <- installationRootLocal
return $ root $(mkRelDir "hpc")
-- | Get the extra bin directories (for the PATH). Puts more local first
--
-- Bool indicates whether or not to include the locals
extraBinDirs :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Bool -> [Path Abs Dir])
extraBinDirs = do
deps <- installationRootDeps
local <- installationRootLocal
return $ \locals -> if locals
then [local bindirSuffix, deps bindirSuffix]
else [deps bindirSuffix]
-- | Get the minimal environment override, useful for just calling external
-- processes like git or ghc
getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride
getMinimalEnvOverride = do
config <- asks getConfig
liftIO $ configEnvOverride config minimalEnvSettings
minimalEnvSettings :: EnvSettings
minimalEnvSettings =
EnvSettings
{ esIncludeLocals = False
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = False
}
getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler
getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig)
data ProjectAndConfigMonoid
= ProjectAndConfigMonoid !Project !ConfigMonoid
instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where
parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir]
extraDeps' <- o ..:? "extra-deps" ..!= []
extraDeps <-
case partitionEithers $ goDeps extraDeps' of
([], x) -> return $ Map.fromList x
(errs, _) -> fail $ unlines errs
flags <- o ..:? "flags" ..!= mempty
resolver <- jsonSubWarnings (o ..: "resolver")
compiler <- o ..:? "compiler"
config <- parseConfigMonoidJSON o
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
let project = Project
{ projectPackages = dirs
, projectExtraDeps = extraDeps
, projectFlags = flags
, projectResolver = resolver
, projectCompiler = compiler
, projectExtraPackageDBs = extraPackageDBs
}
return $ ProjectAndConfigMonoid project config
where
goDeps =
map toSingle . Map.toList . Map.unionsWith Set.union . map toMap
where
toMap i = Map.singleton
(packageIdentifierName i)
(Set.singleton (packageIdentifierVersion i))
toSingle (k, s) =
case Set.toList s of
[x] -> Right (k, x)
xs -> Left $ concat
[ "Multiple versions for package "
, packageNameString k
, ": "
, unwords $ map versionString xs
]
-- | A PackageEntry for the current directory, used as a default
packageEntryCurrDir :: PackageEntry
packageEntryCurrDir = PackageEntry
{ peValidWanted = Nothing
, peExtraDepMaybe = Nothing
, peLocation = PLFilePath "."
, peSubdirs = []
}
-- | A software control system.
data SCM = Git
deriving (Show)
instance FromJSON SCM where
parseJSON v = do
s <- parseJSON v
case s of
"git" -> return Git
_ -> fail ("Unknown or unsupported SCM: " <> s)
instance ToJSON SCM where
toJSON Git = toJSON ("git" :: Text)
-- | A variant of the platform, used to differentiate Docker builds from host
data PlatformVariant = PlatformVariantNone
| PlatformVariant String
-- | Render a platform variant to a String suffix.
platformVariantSuffix :: PlatformVariant -> String
platformVariantSuffix PlatformVariantNone = ""
platformVariantSuffix (PlatformVariant v) = "-" ++ v
-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)
data GHCVariant
= GHCStandard -- ^ Standard bindist
| GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66)
| GHCArch -- ^ Bindist built on Arch Linux (bleeding-edge)
| GHCIntegerSimple -- ^ Bindist that uses integer-simple
| GHCCustom String -- ^ Other bindists
deriving (Show)
instance FromJSON GHCVariant where
-- Strange structuring is to give consistent error messages
parseJSON =
withText
"GHCVariant"
(either (fail . show) return . parseGHCVariant . T.unpack)
-- | Render a GHC variant to a String.
ghcVariantName :: GHCVariant -> String
ghcVariantName GHCStandard = "standard"
ghcVariantName GHCGMP4 = "gmp4"
ghcVariantName GHCArch = "arch"
ghcVariantName GHCIntegerSimple = "integersimple"
ghcVariantName (GHCCustom name) = "custom-" ++ name
-- | Render a GHC variant to a String suffix.
ghcVariantSuffix :: GHCVariant -> String
ghcVariantSuffix GHCStandard = ""
ghcVariantSuffix v = "-" ++ ghcVariantName v
-- | Parse GHC variant from a String.
parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant
parseGHCVariant s =
case stripPrefix "custom-" s of
Just name -> return (GHCCustom name)
Nothing
| s == "" -> return GHCStandard
| s == "standard" -> return GHCStandard
| s == "gmp4" -> return GHCGMP4
| s == "arch" -> return GHCArch
| s == "integersimple" -> return GHCIntegerSimple
| otherwise -> return (GHCCustom s)
-- | Information for a file to download.
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
, downloadInfoContentLength :: Maybe Int
, downloadInfoSha1 :: Maybe ByteString
} deriving (Show)
instance FromJSON (DownloadInfo, [JSONWarning]) where
parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject
-- | Parse JSON in existing object for 'DownloadInfo'
parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo
parseDownloadInfoFromObject o = do
url <- o ..: "url"
contentLength <- o ..:? "content-length"
sha1TextMay <- o ..:? "sha1"
return
DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
, downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
}
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
deriving Show
instance FromJSON (VersionedDownloadInfo, [JSONWarning]) where
parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do
version <- o ..: "version"
downloadInfo <- parseDownloadInfoFromObject o
return VersionedDownloadInfo
{ vdiVersion = version
, vdiDownloadInfo = downloadInfo
}
data SetupInfo = SetupInfo
{ siSevenzExe :: Maybe DownloadInfo
, siSevenzDll :: Maybe DownloadInfo
, siMsys2 :: Map Text VersionedDownloadInfo
, siGHCs :: Map Text (Map Version DownloadInfo)
, siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo)
, siStack :: Map Text (Map Version DownloadInfo)
}
deriving Show
instance FromJSON (SetupInfo, [JSONWarning]) where
parseJSON = withObjectWarnings "SetupInfo" $ \o -> do
siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")
siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")
siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)
siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)
siStack <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
return SetupInfo {..}
-- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged.
-- For all fields the values from the last @SetupInfo@ win.
instance Monoid SetupInfo where
mempty =
SetupInfo
{ siSevenzExe = Nothing
, siSevenzDll = Nothing
, siMsys2 = Map.empty
, siGHCs = Map.empty
, siGHCJSs = Map.empty
, siStack = Map.empty
}
mappend l r =
SetupInfo
{ siSevenzExe = siSevenzExe r <|> siSevenzExe l
, siSevenzDll = siSevenzDll r <|> siSevenzDll l
, siMsys2 = siMsys2 r <> siMsys2 l
, siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l)
, siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l)
, siStack = Map.unionWith (<>) (siStack l) (siStack r) }
-- | Remote or inline 'SetupInfo'
data SetupInfoLocation
= SetupInfoFileOrURL String
| SetupInfoInline SetupInfo
deriving (Show)
instance FromJSON (SetupInfoLocation, [JSONWarning]) where
parseJSON v =
((, []) <$>
withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>
inline
where
inline = do
(si,w) <- parseJSON v
return (SetupInfoInline si, w)
-- | How PVP bounds should be added to .cabal files
data PvpBounds
= PvpBoundsNone
| PvpBoundsUpper
| PvpBoundsLower
| PvpBoundsBoth
deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
pvpBoundsText :: PvpBounds -> Text
pvpBoundsText PvpBoundsNone = "none"
pvpBoundsText PvpBoundsUpper = "upper"
pvpBoundsText PvpBoundsLower = "lower"
pvpBoundsText PvpBoundsBoth = "both"
parsePvpBounds :: Text -> Either String PvpBounds
parsePvpBounds t =
case Map.lookup t m of
Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t
Just x -> Right x
where
m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
instance ToJSON PvpBounds where
toJSON = toJSON . pvpBoundsText
instance FromJSON PvpBounds where
parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
-- | Provide an explicit list of package dependencies when running a custom Setup.hs
explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool
explicitSetupDeps name = do
m <- asks $ configExplicitSetupDeps . getConfig
return $
-- Yes there are far cleverer ways to write this. I honestly consider
-- the explicit pattern matching much easier to parse at a glance.
case Map.lookup (Just name) m of
Just b -> b
Nothing ->
case Map.lookup Nothing m of
Just b -> b
Nothing -> False -- default value
-- | Data passed into Docker container for the Docker entrypoint's use
data DockerEntrypoint = DockerEntrypoint
{ deUidGid :: !(Maybe (UserID, GroupID))
-- ^ UID/GID of host user, if we wish to perform UID/GID switch in container
} deriving (Read,Show)
stack-0.1.10.0/src/Stack/Types/Docker.hs 0000644 0000000 0000000 00000030543 12623647202 015736 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-}
-- | Docker types.
module Stack.Types.Docker where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Data.Aeson.Extended
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Distribution.Text (simpleParse)
import Distribution.Version (anyVersion)
import Path
import Stack.Types.Version
-- | Docker configuration.
data DockerOpts = DockerOpts
{dockerEnable :: !Bool
-- ^ Is using Docker enabled?
,dockerImage :: !String
-- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag.
,dockerRegistryLogin :: !Bool
-- ^ Does registry require login for pulls?
,dockerRegistryUsername :: !(Maybe String)
-- ^ Optional username for Docker registry.
,dockerRegistryPassword :: !(Maybe String)
-- ^ Optional password for Docker registry.
,dockerAutoPull :: !Bool
-- ^ Automatically pull new images.
,dockerDetach :: !Bool
-- ^ Whether to run a detached container
,dockerPersist :: !Bool
-- ^ Create a persistent container (don't remove it when finished). Implied by
-- `dockerDetach`.
,dockerContainerName :: !(Maybe String)
-- ^ Container name to use, only makes sense from command-line with `dockerPersist`
-- or `dockerDetach`.
,dockerRunArgs :: ![String]
-- ^ Arguments to pass directly to @docker run@.
,dockerMount :: ![Mount]
-- ^ Volumes to mount in the container.
,dockerEnv :: ![String]
-- ^ Environment variables to set in the container.
,dockerDatabasePath :: !(Path Abs File)
-- ^ Location of image usage database.
,dockerStackExe :: !(Maybe DockerStackExe)
-- ^ Location of container-compatible stack executable
,dockerSetUser :: !(Maybe Bool)
-- ^ Set in-container user to match host's
,dockerRequireDockerVersion :: !VersionRange
-- ^ Require a version of Docker within this range.
}
deriving (Show)
-- | An uninterpreted representation of docker options.
-- Configurations may be "cascaded" using mappend (left-biased).
data DockerOptsMonoid = DockerOptsMonoid
{dockerMonoidDefaultEnable :: !Bool
-- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)?
,dockerMonoidEnable :: !(Maybe Bool)
-- ^ Is using Docker enabled?
,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)
-- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@)
,dockerMonoidRegistryLogin :: !(Maybe Bool)
-- ^ Does registry require login for pulls?
,dockerMonoidRegistryUsername :: !(Maybe String)
-- ^ Optional username for Docker registry.
,dockerMonoidRegistryPassword :: !(Maybe String)
-- ^ Optional password for Docker registry.
,dockerMonoidAutoPull :: !(Maybe Bool)
-- ^ Automatically pull new images.
,dockerMonoidDetach :: !(Maybe Bool)
-- ^ Whether to run a detached container
,dockerMonoidPersist :: !(Maybe Bool)
-- ^ Create a persistent container (don't remove it when finished). Implied by
-- `dockerDetach`.
,dockerMonoidContainerName :: !(Maybe String)
-- ^ Container name to use, only makes sense from command-line with `dockerPersist`
-- or `dockerDetach`.
,dockerMonoidRunArgs :: ![String]
-- ^ Arguments to pass directly to @docker run@
,dockerMonoidMount :: ![Mount]
-- ^ Volumes to mount in the container
,dockerMonoidEnv :: ![String]
-- ^ Environment variables to set in the container
,dockerMonoidDatabasePath :: !(Maybe String)
-- ^ Location of image usage database.
,dockerMonoidStackExe :: !(Maybe String)
-- ^ Location of container-compatible stack executable
,dockerMonoidSetUser :: !(Maybe Bool)
-- ^ Set in-container user to match host's
,dockerMonoidRequireDockerVersion :: !VersionRange
-- ^ See: 'dockerRequireDockerVersion'
}
deriving (Show)
-- | Decode uninterpreted docker options from JSON/YAML.
instance FromJSON (DockerOptsMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do dockerMonoidDefaultEnable <- pure True
dockerMonoidEnable <- o ..:? dockerEnableArgName
dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|>
((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|>
pure Nothing
dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName
dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName
dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName
dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName
dockerMonoidDetach <- o ..:? dockerDetachArgName
dockerMonoidPersist <- o ..:? dockerPersistArgName
dockerMonoidContainerName <- o ..:? dockerContainerNameArgName
dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName
dockerMonoidStackExe <- o ..:? dockerStackExeArgName
dockerMonoidSetUser <- o ..:? dockerSetUserArgName
dockerMonoidRequireDockerVersion
<- unVersionRangeJSON <$>
o ..:? dockerRequireDockerVersionArgName
..!= VersionRangeJSON anyVersion
return DockerOptsMonoid{..})
-- | Left-biased combine Docker options
instance Monoid DockerOptsMonoid where
mempty = DockerOptsMonoid
{dockerMonoidDefaultEnable = False
,dockerMonoidEnable = Nothing
,dockerMonoidRepoOrImage = Nothing
,dockerMonoidRegistryLogin = Nothing
,dockerMonoidRegistryUsername = Nothing
,dockerMonoidRegistryPassword = Nothing
,dockerMonoidAutoPull = Nothing
,dockerMonoidDetach = Nothing
,dockerMonoidPersist = Nothing
,dockerMonoidContainerName = Nothing
,dockerMonoidRunArgs = []
,dockerMonoidMount = []
,dockerMonoidEnv = []
,dockerMonoidDatabasePath = Nothing
,dockerMonoidStackExe = Nothing
,dockerMonoidSetUser = Nothing
,dockerMonoidRequireDockerVersion = anyVersion
}
mappend l r = DockerOptsMonoid
{dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r
,dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r
,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r
,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r
,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r
,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r
,dockerMonoidAutoPull = dockerMonoidAutoPull l <|> dockerMonoidAutoPull r
,dockerMonoidDetach = dockerMonoidDetach l <|> dockerMonoidDetach r
,dockerMonoidPersist = dockerMonoidPersist l <|> dockerMonoidPersist r
,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r
,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l
,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l
,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l
,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r
,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r
,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r
,dockerMonoidRequireDockerVersion
= intersectVersionRanges (dockerMonoidRequireDockerVersion l)
(dockerMonoidRequireDockerVersion r)
}
-- | Where to get the `stack` executable to run in Docker containers
data DockerStackExe
= DockerStackExeDownload -- ^ Download from official bindist
| DockerStackExeHost -- ^ Host's `stack` (linux-x86_64 only)
| DockerStackExeImage -- ^ Docker image's `stack` (versions must match)
| DockerStackExePath (Path Abs File) -- ^ Executable at given path
deriving (Show)
-- | Parse 'DockerStackExe'.
parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe
parseDockerStackExe t
| t == dockerStackExeDownloadVal = return DockerStackExeDownload
| t == dockerStackExeHostVal = return DockerStackExeHost
| t == dockerStackExeImageVal = return DockerStackExeImage
| otherwise = liftM DockerStackExePath (parseAbsFile t)
-- | Docker volume mount.
data Mount = Mount String String
-- | For optparse-applicative.
instance Read Mount where
readsPrec _ s =
case break (== ':') s of
(a,':':b) -> [(Mount a b,"")]
(a,[]) -> [(Mount a a,"")]
_ -> fail "Invalid value for Docker mount (expect '/host/path:/container/path')"
-- | Show instance.
instance Show Mount where
show (Mount a b) = if a == b
then a
else concat [a,":",b]
-- | For YAML.
instance FromJSON Mount where
parseJSON v = fmap read (parseJSON v)
-- | Options for Docker repository or image.
data DockerMonoidRepoOrImage
= DockerMonoidRepo String
| DockerMonoidImage String
deriving (Show)
-- | Newtype for non-orphan FromJSON instance.
newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
-- | Parse VersionRange.
instance FromJSON VersionRangeJSON where
parseJSON = withText "VersionRange"
(\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s))
(return . VersionRangeJSON)
(Distribution.Text.simpleParse (T.unpack s)))
-- | Docker enable argument name.
dockerEnableArgName :: Text
dockerEnableArgName = "enable"
-- | Docker repo arg argument name.
dockerRepoArgName :: Text
dockerRepoArgName = "repo"
-- | Docker image argument name.
dockerImageArgName :: Text
dockerImageArgName = "image"
-- | Docker registry login argument name.
dockerRegistryLoginArgName :: Text
dockerRegistryLoginArgName = "registry-login"
-- | Docker registry username argument name.
dockerRegistryUsernameArgName :: Text
dockerRegistryUsernameArgName = "registry-username"
-- | Docker registry password argument name.
dockerRegistryPasswordArgName :: Text
dockerRegistryPasswordArgName = "registry-password"
-- | Docker auto-pull argument name.
dockerAutoPullArgName :: Text
dockerAutoPullArgName = "auto-pull"
-- | Docker detach argument name.
dockerDetachArgName :: Text
dockerDetachArgName = "detach"
-- | Docker run args argument name.
dockerRunArgsArgName :: Text
dockerRunArgsArgName = "run-args"
-- | Docker mount argument name.
dockerMountArgName :: Text
dockerMountArgName = "mount"
-- | Docker environment variable argument name.
dockerEnvArgName :: Text
dockerEnvArgName = "env"
-- | Docker container name argument name.
dockerContainerNameArgName :: Text
dockerContainerNameArgName = "container-name"
-- | Docker persist argument name.
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
-- | Docker database path argument name.
dockerDatabasePathArgName :: Text
dockerDatabasePathArgName = "database-path"
-- | Docker database path argument name.
dockerStackExeArgName :: Text
dockerStackExeArgName = "stack-exe"
-- | Value for @--docker-stack-exe=download@
dockerStackExeDownloadVal :: String
dockerStackExeDownloadVal = "download"
-- | Value for @--docker-stack-exe=host@
dockerStackExeHostVal :: String
dockerStackExeHostVal = "host"
-- | Value for @--docker-stack-exe=image@
dockerStackExeImageVal :: String
dockerStackExeImageVal = "image"
-- | Docker @set-user@ argument name
dockerSetUserArgName :: Text
dockerSetUserArgName = "set-user"
-- | Docker @require-version@ argument name
dockerRequireDockerVersionArgName :: Text
dockerRequireDockerVersionArgName = "require-docker-version"
-- | Argument name used to pass docker entrypoint data (only used internally)
dockerEntrypointArgName :: String
dockerEntrypointArgName = "internal-docker-entrypoint"
stack-0.1.10.0/src/Stack/Types/FlagName.hs 0000644 0000000 0000000 00000010451 12623647202 016175 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
-- | Names for flags.
module Stack.Types.FlagName
(FlagName
,FlagNameParseFail(..)
,flagNameParser
,parseFlagName
,parseFlagNameFromString
,flagNameString
,flagNameText
,fromCabalFlagName
,toCabalFlagName
,mkFlagName)
where
import Control.Applicative
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinators
import Data.Binary.VersionTagged
import qualified Data.ByteString as S
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Char (isLetter)
import Data.Data
import Data.Hashable
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.Word8 as Word8
import qualified Distribution.PackageDescription as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-- | A parse fail.
data FlagNameParseFail
= FlagNameParseFail ByteString
deriving (Typeable)
instance Exception FlagNameParseFail
instance Show FlagNameParseFail where
show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs
-- | A flag name.
newtype FlagName =
FlagName ByteString
deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
instance HasStructuralInfo FlagName
instance Eq FlagName where
x == y = compare x y == EQ
instance Ord FlagName where
compare (FlagName x) (FlagName y) =
compare (S.map Word8.toLower x) (S.map Word8.toLower y)
instance Lift FlagName where
lift (FlagName n) =
appE (conE 'FlagName)
(stringE (S8.unpack n))
instance Show FlagName where
show (FlagName n) = S8.unpack n
instance FromJSON FlagName where
parseJSON j =
do s <- parseJSON j
case parseFlagNameFromString s of
Nothing ->
fail ("Couldn't parse flag name: " ++ s)
Just ver -> return ver
-- | Attoparsec parser for a flag name from bytestring.
flagNameParser :: Parser FlagName
flagNameParser =
fmap (FlagName . S8.pack)
(appending (many1 (satisfy isLetter))
(concating (many (alternating
(pured (satisfy isAlphaNum))
(appending (pured (satisfy separator))
(pured (satisfy isAlphaNum)))))))
where separator c = c == '-' || c == '_'
isAlphaNum c = isLetter c || isDigit c
-- | Make a flag name.
mkFlagName :: String -> Q Exp
mkFlagName s =
case parseFlagNameFromString s of
Nothing -> error ("Invalid flag name: " ++ show s)
Just pn -> [|pn|]
-- | Convenient way to parse a flag name from a bytestring.
parseFlagName :: MonadThrow m => ByteString -> m FlagName
parseFlagName x = go x
where go =
either (const (throwM (FlagNameParseFail x))) return .
parseOnly (flagNameParser <* endOfInput)
-- | Migration function.
parseFlagNameFromString :: MonadThrow m => String -> m FlagName
parseFlagNameFromString =
parseFlagName . S8.pack
-- | Produce a string representation of a flag name.
flagNameString :: FlagName -> String
flagNameString (FlagName n) = S8.unpack n
-- | Produce a string representation of a flag name.
flagNameText :: FlagName -> Text
flagNameText (FlagName n) = T.decodeUtf8 n
-- | Convert from a Cabal flag name.
fromCabalFlagName :: Cabal.FlagName -> FlagName
fromCabalFlagName (Cabal.FlagName name) =
let !x = S8.pack name
in FlagName x
-- | Convert to a Cabal flag name.
toCabalFlagName :: FlagName -> Cabal.FlagName
toCabalFlagName (FlagName name) =
let !x = S8.unpack name
in Cabal.FlagName x
instance ToJSON a => ToJSON (Map FlagName a) where
toJSON = toJSON . Map.mapKeysWith const flagNameText
instance FromJSON a => FromJSON (Map FlagName a) where
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = fmap (, v) $ either (fail . show) return $ parseFlagNameFromString k
stack-0.1.10.0/src/Stack/Types/GhcPkgId.hs 0000644 0000000 0000000 00000004723 12623647202 016150 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | A ghc-pkg id.
module Stack.Types.GhcPkgId
(GhcPkgId
,ghcPkgIdParser
,parseGhcPkgId
,ghcPkgIdString)
where
import Control.Applicative
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8 as A8
import Data.Binary (getWord8, putWord8)
import Data.Binary.VersionTagged
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Data
import Data.Hashable
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics
import Prelude -- Fix AMP warning
-- | A parse fail.
data GhcPkgIdParseFail
= GhcPkgIdParseFail ByteString
deriving Typeable
instance Show GhcPkgIdParseFail where
show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs
instance Exception GhcPkgIdParseFail
-- | A ghc-pkg package identifier.
newtype GhcPkgId = GhcPkgId ByteString
deriving (Eq,Ord,Data,Typeable,Generic)
instance Hashable GhcPkgId
instance Binary GhcPkgId where
put (GhcPkgId x) = do
-- magic string
putWord8 1
putWord8 3
putWord8 4
putWord8 7
put x
get = do
1 <- getWord8
3 <- getWord8
4 <- getWord8
7 <- getWord8
fmap GhcPkgId get
instance NFData GhcPkgId
instance HasStructuralInfo GhcPkgId
instance Show GhcPkgId where
show = show . ghcPkgIdString
instance FromJSON GhcPkgId where
parseJSON = withText "GhcPkgId" $ \t ->
case parseGhcPkgId $ encodeUtf8 t of
Left e -> fail $ show (e, t)
Right x -> return x
instance ToJSON GhcPkgId where
toJSON g =
toJSON (ghcPkgIdString g)
-- | Convenient way to parse a package name from a bytestring.
parseGhcPkgId :: MonadThrow m => ByteString -> m GhcPkgId
parseGhcPkgId x = go x
where go =
either (const (throwM (GhcPkgIdParseFail x))) return .
parseOnly (ghcPkgIdParser <* endOfInput)
-- | A parser for a package-version-hash pair.
ghcPkgIdParser :: Parser GhcPkgId
ghcPkgIdParser =
fmap GhcPkgId (A8.takeWhile isValid)
where
isValid c =
('A' <= c && c <= 'Z') ||
('a' <= c && c <= 'z') ||
('0' <= c && c <= '9') ||
c == '.' ||
c == '-' ||
c == '_'
-- | Get a string representation of GHC package id.
ghcPkgIdString :: GhcPkgId -> String
ghcPkgIdString (GhcPkgId x) = S8.unpack x
stack-0.1.10.0/src/Stack/Types/Image.hs 0000644 0000000 0000000 00000007444 12571621073 015555 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Types.Image where
import Control.Applicative
import Data.Aeson.Extended
import Data.Monoid
import Data.Map (Map)
import Data.Text (Text)
import Prelude -- Fix redundant import warnings
-- | Image options. Currently only Docker image options.
data ImageOpts = ImageOpts
{ imgDocker :: !(Maybe ImageDockerOpts)
-- ^ Maybe a section for docker image settings.
} deriving (Show)
data ImageDockerOpts = ImageDockerOpts
{ imgDockerBase :: !(Maybe String)
-- ^ Maybe have a docker base image name. (Although we will not
-- be able to create any Docker images without this.)
, imgDockerEntrypoints :: !(Maybe [String])
-- ^ Maybe have a specific ENTRYPOINT list that will be used to
-- create images.
, imgDockerAdd :: !(Map FilePath FilePath)
-- ^ Maybe have some static project content to include in a
-- specific directory in all the images.
, imgDockerImageName :: !(Maybe String)
-- ^ Maybe have a name for the image we are creating
} deriving (Show)
data ImageOptsMonoid = ImageOptsMonoid
{ imgMonoidDocker :: !(Maybe ImageDockerOptsMonoid)
} deriving (Show)
data ImageDockerOptsMonoid = ImageDockerOptsMonoid
{ imgDockerMonoidBase :: !(Maybe String)
, imgDockerMonoidEntrypoints :: !(Maybe [String])
, imgDockerMonoidAdd :: !(Maybe (Map String FilePath))
, imgDockerMonoidImageName :: !(Maybe String)
} deriving (Show)
instance FromJSON (ImageOptsMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings
"ImageOptsMonoid"
(\o ->
do imgMonoidDocker <- jsonSubWarningsT (o ..:? imgDockerArgName)
return
ImageOptsMonoid
{ ..
})
instance Monoid ImageOptsMonoid where
mempty = ImageOptsMonoid
{ imgMonoidDocker = Nothing
}
mappend l r = ImageOptsMonoid
{ imgMonoidDocker = imgMonoidDocker l <|> imgMonoidDocker r
}
instance FromJSON (ImageDockerOptsMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings
"ImageDockerOptsMonoid"
(\o ->
do imgDockerMonoidBase <- o ..:? imgDockerBaseArgName
imgDockerMonoidEntrypoints <- o ..:?
imgDockerEntrypointsArgName
imgDockerMonoidAdd <- o ..:? imgDockerAddArgName
imgDockerMonoidImageName <- o ..:? imgDockerImageNameArgName
return
ImageDockerOptsMonoid
{ ..
})
instance Monoid ImageDockerOptsMonoid where
mempty = ImageDockerOptsMonoid
{ imgDockerMonoidBase = Nothing
, imgDockerMonoidEntrypoints = Nothing
, imgDockerMonoidAdd = Nothing
, imgDockerMonoidImageName = Nothing
}
mappend l r = ImageDockerOptsMonoid
{ imgDockerMonoidBase = imgDockerMonoidBase l <|> imgDockerMonoidBase r
, imgDockerMonoidEntrypoints = imgDockerMonoidEntrypoints l <|> imgDockerMonoidEntrypoints
r
, imgDockerMonoidAdd = imgDockerMonoidAdd l <|> imgDockerMonoidAdd r
, imgDockerMonoidImageName = imgDockerMonoidImageName l <|> imgDockerMonoidImageName r
}
imgArgName :: Text
imgArgName = "image"
imgDockerArgName :: Text
imgDockerArgName = "container"
imgDockerBaseArgName :: Text
imgDockerBaseArgName = "base"
imgDockerAddArgName :: Text
imgDockerAddArgName = "add"
imgDockerEntrypointsArgName :: Text
imgDockerEntrypointsArgName = "entrypoints"
imgDockerImageNameArgName :: Text
imgDockerImageNameArgName = "name"
stack-0.1.10.0/src/Stack/Types/Nix.hs 0000644 0000000 0000000 00000005610 12630352213 015253 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Nix types.
module Stack.Types.Nix where
import Control.Applicative
import Data.Aeson.Extended
import Data.Monoid
import Data.Text (Text)
-- | Nix configuration.
data NixOpts = NixOpts
{nixEnable :: !Bool
,nixPackages :: ![Text]
-- ^ The system packages to be installed in the environment before it runs
,nixInitFile :: !(Maybe String)
-- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
,nixShellOptions :: ![Text]
-- ^ Options to be given to the nix-shell command line
}
deriving (Show)
-- | An uninterpreted representation of nix options.
-- Configurations may be "cascaded" using mappend (left-biased).
data NixOptsMonoid = NixOptsMonoid
{nixMonoidDefaultEnable :: !Bool
-- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)?
,nixMonoidEnable :: !(Maybe Bool)
-- ^ Is using nix-shell enabled?
,nixMonoidPackages :: ![Text]
-- ^ System packages to use (given to nix-shell)
,nixMonoidInitFile :: !(Maybe String)
-- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
,nixMonoidShellOptions :: ![Text]
-- ^ Options to be given to the nix-shell command line
}
deriving (Show)
-- | Decode uninterpreted nix options from JSON/YAML.
instance FromJSON (NixOptsMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do nixMonoidDefaultEnable <- pure True
nixMonoidEnable <- o ..:? nixEnableArgName
nixMonoidPackages <- o ..:? nixPackagesArgName ..!= []
nixMonoidInitFile <- o ..:? nixInitFileArgName
nixMonoidShellOptions <- o ..:? nixShellOptsArgName ..!= []
return NixOptsMonoid{..})
-- | Left-biased combine nix options
instance Monoid NixOptsMonoid where
mempty = NixOptsMonoid
{nixMonoidDefaultEnable = False
,nixMonoidEnable = Nothing
,nixMonoidPackages = []
,nixMonoidInitFile = Nothing
,nixMonoidShellOptions = []
}
mappend l r = NixOptsMonoid
{nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r
,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r
,nixMonoidPackages = nixMonoidPackages l <> nixMonoidPackages r
,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r
,nixMonoidShellOptions = nixMonoidShellOptions l <> nixMonoidShellOptions r
}
-- | Nix enable argument name.
nixEnableArgName :: Text
nixEnableArgName = "enable"
-- | Nix packages (build inputs) argument name.
nixPackagesArgName :: Text
nixPackagesArgName = "packages"
-- | shell.nix file path argument name.
nixInitFileArgName :: Text
nixInitFileArgName = "shell-file"
-- | Extra options for the nix-shell command argument name.
nixShellOptsArgName :: Text
nixShellOptsArgName = "nix-shell-options"
stack-0.1.10.0/src/Stack/Types/PackageIdentifier.hs 0000644 0000000 0000000 00000007267 12623647202 020074 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS -fno-warn-unused-do-bind #-}
-- | Package identifier (name-version).
module Stack.Types.PackageIdentifier
( PackageIdentifier(..)
, toTuple
, fromTuple
, parsePackageIdentifier
, parsePackageIdentifierFromString
, packageIdentifierParser
, packageIdentifierString
, packageIdentifierText )
where
import Control.Applicative
import Control.DeepSeq
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow, throwM)
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Data
import Data.Hashable
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics
import Prelude hiding (FilePath)
import Stack.Types.PackageName
import Stack.Types.Version
-- | A parse fail.
data PackageIdentifierParseFail
= PackageIdentifierParseFail ByteString
deriving (Typeable)
instance Show PackageIdentifierParseFail where
show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs
instance Exception PackageIdentifierParseFail
-- | A pkg-ver combination.
data PackageIdentifier = PackageIdentifier
{ -- | Get the name part of the identifier.
packageIdentifierName :: !PackageName
-- | Get the version part of the identifier.
, packageIdentifierVersion :: !Version
} deriving (Eq,Ord,Generic,Data,Typeable)
instance NFData PackageIdentifier where
rnf (PackageIdentifier !p !v) =
seq (rnf p) (rnf v)
instance Hashable PackageIdentifier
instance Binary PackageIdentifier
instance HasStructuralInfo PackageIdentifier
instance Show PackageIdentifier where
show = show . packageIdentifierString
instance ToJSON PackageIdentifier where
toJSON = toJSON . packageIdentifierString
instance FromJSON PackageIdentifier where
parseJSON = withText "PackageIdentifier" $ \t ->
case parsePackageIdentifier $ encodeUtf8 t of
Left e -> fail $ show (e, t)
Right x -> return x
-- | Convert from a package identifier to a tuple.
toTuple :: PackageIdentifier -> (PackageName,Version)
toTuple (PackageIdentifier n v) = (n,v)
-- | Convert from a tuple to a package identifier.
fromTuple :: (PackageName,Version) -> PackageIdentifier
fromTuple (n,v) = PackageIdentifier n v
-- | A parser for a package-version pair.
packageIdentifierParser :: Parser PackageIdentifier
packageIdentifierParser =
do name <- packageNameParser
char8 '-'
version <- versionParser
return (PackageIdentifier name version)
-- | Convenient way to parse a package identifier from a bytestring.
parsePackageIdentifier :: MonadThrow m => ByteString -> m PackageIdentifier
parsePackageIdentifier x = go x
where go =
either (const (throwM (PackageIdentifierParseFail x))) return .
parseOnly (packageIdentifierParser <* endOfInput)
-- | Migration function.
parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier
parsePackageIdentifierFromString =
parsePackageIdentifier . S8.pack
-- | Get a string representation of the package identifier; name-ver.
packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v
-- | Get a Text representation of the package identifier; name-ver.
packageIdentifierText :: PackageIdentifier -> Text
packageIdentifierText = T.pack . packageIdentifierString
stack-0.1.10.0/src/Stack/Types/PackageIndex.hs 0000644 0000000 0000000 00000004147 12623647202 017053 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Types.PackageIndex
( PackageDownload (..)
, PackageCache (..)
, PackageCacheMap (..)
) where
import Control.Monad (mzero)
import Data.Aeson.Extended
import qualified Data.Binary as Binary
import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word64)
import GHC.Generics (Generic)
import Stack.Types.PackageIdentifier
data PackageCache = PackageCache
{ pcOffset :: !Int64
-- ^ offset in bytes into the 00-index.tar file for the .cabal file contents
, pcSize :: !Int64
-- ^ size in bytes of the .cabal file
, pcDownload :: !(Maybe PackageDownload)
}
deriving (Generic)
instance Binary PackageCache
instance NFData PackageCache
instance HasStructuralInfo PackageCache
newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)
deriving (Generic, Binary, NFData)
instance HasStructuralInfo PackageCacheMap
instance HasSemanticVersion PackageCacheMap
data PackageDownload = PackageDownload
{ pdSHA512 :: !ByteString
, pdUrl :: !ByteString
, pdSize :: !Word64
}
deriving (Show, Generic)
instance Binary.Binary PackageDownload
instance HasStructuralInfo PackageDownload
instance NFData PackageDownload
instance FromJSON PackageDownload where
parseJSON = withObject "Package" $ \o -> do
hashes <- o .: "package-hashes"
sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes)
locs <- o .: "package-locations"
url <-
case reverse locs of
[] -> mzero
x:_ -> return x
size <- o .: "package-size"
return PackageDownload
{ pdSHA512 = encodeUtf8 sha512
, pdUrl = encodeUtf8 url
, pdSize = size
}
stack-0.1.10.0/src/Stack/Types/PackageName.hs 0000644 0000000 0000000 00000013613 12623647202 016662 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
-- | Names for packages.
module Stack.Types.PackageName
(PackageName
,PackageNameParseFail(..)
,packageNameParser
,parsePackageName
,parsePackageNameFromString
,packageNameByteString
,packageNameString
,packageNameText
,fromCabalPackageName
,toCabalPackageName
,parsePackageNameFromFilePath
,mkPackageName
,packageNameArgument)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinators
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Char (isLetter)
import Data.Data
import Data.Hashable
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Distribution.Package as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Path
import qualified Options.Applicative as O
-- | A parse fail.
data PackageNameParseFail
= PackageNameParseFail ByteString
| CabalFileNameParseFail FilePath
| CabalFileNameInvalidPackageName FilePath
deriving (Typeable)
instance Exception PackageNameParseFail
instance Show PackageNameParseFail where
show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs
show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp
show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp
-- | A package name.
newtype PackageName =
PackageName ByteString
deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData)
instance Lift PackageName where
lift (PackageName n) =
appE (conE 'PackageName)
(stringE (S8.unpack n))
instance Show PackageName where
show (PackageName n) = S8.unpack n
instance HasStructuralInfo PackageName
instance ToJSON PackageName where
toJSON = toJSON . packageNameText
instance FromJSON PackageName where
parseJSON j =
do s <- parseJSON j
case parsePackageNameFromString s of
Nothing ->
fail ("Couldn't parse package name: " ++ s)
Just ver -> return ver
-- | Attoparsec parser for a package name from bytestring.
packageNameParser :: Parser PackageName
packageNameParser =
fmap (PackageName . S8.pack . intercalate "-")
(sepBy1 word (char '-'))
where
word = concat <$> sequence [many digit,
pured letter,
many (alternating letter digit)]
letter = satisfy isLetter
-- | Make a package name.
mkPackageName :: String -> Q Exp
mkPackageName s =
case parsePackageNameFromString s of
Nothing -> error ("Invalid package name: " ++ show s)
Just pn -> [|pn|]
-- | Convenient way to parse a package name from a bytestring.
parsePackageName :: MonadThrow m => ByteString -> m PackageName
parsePackageName x = go x
where go =
either (const (throwM (PackageNameParseFail x))) return .
parseOnly (packageNameParser <* endOfInput)
-- | Migration function.
parsePackageNameFromString :: MonadThrow m => String -> m PackageName
parsePackageNameFromString =
parsePackageName . S8.pack
-- | Produce a bytestring representation of a package name.
packageNameByteString :: PackageName -> ByteString
packageNameByteString (PackageName n) = n
-- | Produce a string representation of a package name.
packageNameString :: PackageName -> String
packageNameString (PackageName n) = S8.unpack n
-- | Produce a string representation of a package name.
packageNameText :: PackageName -> Text
packageNameText (PackageName n) = T.decodeUtf8 n
-- | Convert from a Cabal package name.
fromCabalPackageName :: Cabal.PackageName -> PackageName
fromCabalPackageName (Cabal.PackageName name) =
let !x = S8.pack name
in PackageName x
-- | Convert to a Cabal package name.
toCabalPackageName :: PackageName -> Cabal.PackageName
toCabalPackageName (PackageName name) =
let !x = S8.unpack name
in Cabal.PackageName x
-- | Parse a package name from a file path.
parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
parsePackageNameFromFilePath fp = do
base <- clean $ toFilePath $ filename fp
case parsePackageNameFromString base of
Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp
Just x -> return x
where clean = liftM reverse . strip . reverse
strip ('l':'a':'b':'a':'c':'.':xs) = return xs
strip _ = throwM (CabalFileNameParseFail (toFilePath fp))
instance ToJSON a => ToJSON (Map PackageName a) where
toJSON = toJSON . Map.mapKeysWith const packageNameText
instance FromJSON a => FromJSON (Map PackageName a) where
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k
-- | An argument which accepts a template name of the format
-- @foo.hsfiles@.
packageNameArgument :: O.Mod O.ArgumentFields PackageName
-> O.Parser PackageName
packageNameArgument =
O.argument
(do s <- O.str
either O.readerError return (p s))
where
p s =
case parsePackageNameFromString s of
Just x -> Right x
Nothing -> Left ("Expected valid package name, but got: " ++ s)
stack-0.1.10.0/src/Stack/Types/TemplateName.hs 0000644 0000000 0000000 00000005623 12623647202 017104 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Template name handling.
module Stack.Types.TemplateName where
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import qualified Options.Applicative as O
import Path
import Path.Internal
-- | A template name.
data TemplateName = TemplateName !Text !(Either (Path Abs File) (Path Rel File))
deriving (Ord,Eq,Show)
-- | An argument which accepts a template name of the format
-- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@.
templateNameArgument :: O.Mod O.ArgumentFields TemplateName
-> O.Parser TemplateName
templateNameArgument =
O.argument
(do string <- O.str
either O.readerError return (parseTemplateNameFromString string))
-- | An argument which accepts a @key:value@ pair for specifying parameters.
templateParamArgument :: O.Mod O.OptionFields (Text,Text)
-> O.Parser (Text,Text)
templateParamArgument =
O.option
(do string <- O.str
either O.readerError return (parsePair string))
where
parsePair :: String -> Either String (Text, Text)
parsePair s =
case break (==':') s of
(key,':':value@(_:_)) -> Right (T.pack key, T.pack value)
_ -> Left ("Expected key:value format for argument: " <> s)
-- | Parse a template name from a string.
parseTemplateNameFromString :: String -> Either String TemplateName
parseTemplateNameFromString fname =
case T.stripSuffix ".hsfiles" (T.pack fname) of
Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles")
Just prefix -> parseValidFile prefix fname
where
parseValidFile prefix str =
case parseRelFile str of
Nothing ->
case parseAbsFile str of
Nothing -> Left expected
Just fp -> return (TemplateName prefix (Left fp))
Just fp -> return (TemplateName prefix (Right fp))
expected = "Expected a template filename like: foo or foo.hsfiles"
-- | Make a template name.
mkTemplateName :: String -> Q Exp
mkTemplateName s =
case parseTemplateNameFromString s of
Left{} -> error ("Invalid template name: " ++ show s)
Right (TemplateName (T.unpack -> prefix) p) ->
[|TemplateName (T.pack prefix) $(pn)|]
where pn =
case p of
Left (Path fp) -> [|Left (Path fp)|]
Right (Path fp) -> [|Right (Path fp)|]
-- | Get a text representation of the template name.
templateName :: TemplateName -> Text
templateName (TemplateName prefix _) = prefix
-- | Get the path of the template.
templatePath :: TemplateName -> Either (Path Abs File) (Path Rel File)
templatePath (TemplateName _ fp) = fp
stack-0.1.10.0/src/Stack/Types/Version.hs 0000644 0000000 0000000 00000016475 12630352213 016155 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Versions for packages.
module Stack.Types.Version
(Version
,Cabal.VersionRange -- TODO in the future should have a newtype wrapper
,VersionCheck(..)
,versionParser
,parseVersion
,parseVersionFromString
,versionString
,versionText
,toCabalVersion
,fromCabalVersion
,mkVersion
,versionRangeText
,withinRange
,Stack.Types.Version.intersectVersionRanges
,toMajorVersion
,latestApplicableVersion
,checkVersion
,nextMajorVersion)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Data
import Data.Hashable
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector.Binary ()
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as V
import Data.Word
import Distribution.Text (disp)
import qualified Distribution.Version as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude -- Fix warning: Word in Prelude from base-4.8.
import Text.PrettyPrint (render)
-- | A parse fail.
data VersionParseFail =
VersionParseFail ByteString
deriving (Typeable)
instance Exception VersionParseFail
instance Show VersionParseFail where
show (VersionParseFail bs) = "Invalid version: " ++ show bs
-- | A package version.
newtype Version =
Version {unVersion :: Vector Word}
deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData)
instance HasStructuralInfo Version
instance Hashable Version where
hashWithSalt i = hashWithSalt i . V.toList . unVersion
instance Lift Version where
lift (Version n) =
appE (conE 'Version)
(appE (varE 'V.fromList)
(listE (map (litE . IntegerL . fromIntegral)
(V.toList n))))
instance Show Version where
show (Version v) =
intercalate "."
(map show (V.toList v))
instance ToJSON Version where
toJSON = toJSON . versionText
instance FromJSON Version where
parseJSON j =
do s <- parseJSON j
case parseVersionFromString s of
Nothing ->
fail ("Couldn't parse package version: " ++ s)
Just ver -> return ver
instance FromJSON a => FromJSON (Map Version a) where
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = do
k' <- either (fail . show) return $ parseVersionFromString k
return (k', v)
-- | Attoparsec parser for a package version from bytestring.
versionParser :: Parser Version
versionParser =
do ls <- ((:) <$> num <*> many num')
let !v = V.fromList ls
return (Version v)
where num = decimal
num' = point *> num
point = satisfy (== '.')
-- | Convenient way to parse a package version from a bytestring.
parseVersion :: MonadThrow m => ByteString -> m Version
parseVersion x = go x
where go =
either (const (throwM (VersionParseFail x))) return .
parseOnly (versionParser <* endOfInput)
-- | Migration function.
parseVersionFromString :: MonadThrow m => String -> m Version
parseVersionFromString =
parseVersion . S8.pack
-- | Get a string representation of a package version.
versionString :: Version -> String
versionString (Version v) =
intercalate "."
(map show (V.toList v))
-- | Get a string representation of a package version.
versionText :: Version -> Text
versionText (Version v) =
T.intercalate
"."
(map (T.pack . show)
(V.toList v))
-- | Convert to a Cabal version.
toCabalVersion :: Version -> Cabal.Version
toCabalVersion (Version v) =
Cabal.Version (map fromIntegral (V.toList v)) []
-- | Convert from a Cabal version.
fromCabalVersion :: Cabal.Version -> Version
fromCabalVersion (Cabal.Version vs _) =
let !v = V.fromList (map fromIntegral vs)
in Version v
-- | Make a package version.
mkVersion :: String -> Q Exp
mkVersion s =
case parseVersionFromString s of
Nothing -> error ("Invalid package version: " ++ show s)
Just pn -> [|pn|]
-- | Display a version range
versionRangeText :: Cabal.VersionRange -> Text
versionRangeText = T.pack . render . disp
-- | Check if a version is within a version range.
withinRange :: Version -> Cabal.VersionRange -> Bool
withinRange v r = toCabalVersion v `Cabal.withinRange` r
-- | A modified intersection which also simplifies, for better display.
intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange
intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y
-- | Returns the first two components, defaulting to 0 if not present
toMajorVersion :: Version -> Version
toMajorVersion (Version v) =
case V.length v of
0 -> Version (V.fromList [0, 0])
1 -> Version (V.fromList [V.head v, 0])
_ -> Version (V.fromList [V.head v, v V.! 1])
-- | Given a version range and a set of versions, find the latest version from
-- the set that is within the range.
latestApplicableVersion :: Cabal.VersionRange -> Set Version -> Maybe Version
latestApplicableVersion r = listToMaybe . filter (`withinRange` r) . Set.toDescList
-- | Get the next major version number for the given version
nextMajorVersion :: Version -> Version
nextMajorVersion (Version v) =
case V.length v of
0 -> Version (V.fromList [0, 1])
1 -> Version (V.fromList [V.head v, 1])
_ -> Version (V.fromList [V.head v, (v V.! 1) + 1])
data VersionCheck
= MatchMinor
| MatchExact
| NewerMinor
deriving (Show, Eq, Ord)
instance ToJSON VersionCheck where
toJSON MatchMinor = String "match-minor"
toJSON MatchExact = String "match-exact"
toJSON NewerMinor = String "newer-minor"
instance FromJSON VersionCheck where
parseJSON = withText expected $ \t ->
case t of
"match-minor" -> return MatchMinor
"match-exact" -> return MatchExact
"newer-minor" -> return NewerMinor
_ -> fail ("Expected " ++ expected ++ ", but got " ++ show t)
where
expected = "VersionCheck value (match-minor, match-exact, or newer-minor)"
checkVersion :: VersionCheck -> Version -> Version -> Bool
checkVersion check (Version wanted) (Version actual) =
case check of
MatchMinor -> V.and (V.take 3 matching)
MatchExact -> V.length wanted == V.length actual && V.and matching
NewerMinor -> V.and (V.take 2 matching) && newerMinor
where
matching = V.zipWith (==) wanted actual
newerMinor =
case (wanted V.!? 2, actual V.!? 2) of
(Nothing, _) -> True
(Just _, Nothing) -> False
(Just w, Just a) -> a >= w
stack-0.1.10.0/src/Stack/Types/Sig.hs 0000644 0000000 0000000 00000006007 12630352213 015240 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module : Stack.Types.Sig
Description : Signature Types
Copyright : (c) FPComplete.com, 2015
License : BSD3
Maintainer : Tim Dysinger
Stability : experimental
Portability : POSIX
-}
module Stack.Types.Sig
(Signature(..), Fingerprint(..), SigException(..))
where
import Control.Exception (Exception)
import Data.Aeson (Value(..), ToJSON(..), FromJSON(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as SB
import Data.Char (isDigit, isAlpha, isSpace)
import Data.Monoid ((<>))
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import Stack.Types.PackageName
-- | A GPG signature.
newtype Signature =
Signature ByteString
deriving (Ord,Eq)
instance Show Signature where
show (Signature s) = "Signature " ++
(if SB.length s > 140
then show (SB.take 140 s) ++
"..."
else show (SB.take 140 s))
-- | The GPG fingerprint.
newtype Fingerprint = Fingerprint
{ fingerprintSample :: Text
} deriving (Eq,Ord,Show)
instance FromJSON Fingerprint where
parseJSON j = do
s <- parseJSON j
let withoutSpaces = T.filter (not . isSpace) s
if T.null withoutSpaces ||
T.all
(\c ->
isAlpha c || isDigit c || isSpace c)
withoutSpaces
then return (Fingerprint withoutSpaces)
else fail ("Expected fingerprint, but got: " ++ T.unpack s)
instance ToJSON Fingerprint where
toJSON (Fingerprint txt) = String txt
instance IsString Fingerprint where
fromString = Fingerprint . T.pack
instance FromJSON (Aeson PackageName) where
parseJSON j = do
s <- parseJSON j
case (parsePackageName . T.encodeUtf8) s of
Just name -> return (Aeson name)
Nothing -> fail ("Invalid package name: " <> T.unpack s)
-- | Handy wrapper for orphan instances.
newtype Aeson a = Aeson
{ _unAeson :: a
} deriving (Ord,Eq)
-- | Exceptions
data SigException
= GPGFingerprintException String
| GPGSignException String
| GPGVerifyException String
| SigInvalidSDistTarBall
| SigNoProjectRootException
| SigServiceException String
deriving (Typeable)
instance Exception SigException
instance Show SigException where
show (GPGFingerprintException e) =
"Error extracting a GPG fingerprint " <> e
show (GPGSignException e) = "Error signing with GPG " <> e
show (GPGVerifyException e) = "Error verifying with GPG " <> e
show SigNoProjectRootException = "Missing Project Root"
show SigInvalidSDistTarBall = "Invalid sdist tarball"
show (SigServiceException e) = "Error with the Signature Service " <> e
stack-0.1.10.0/src/Stack/Types/StackT.hs 0000644 0000000 0000000 00000033130 12630352213 015704 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | The monad used for the command-line executable @stack@.
module Stack.Types.StackT
(StackT
,StackLoggingT
,runStackT
,runStackTGlobal
,runStackLoggingT
,runStackLoggingTGlobal
,runInnerStackT
,runInnerStackLoggingT
,newTLSManager
,logSticky
,logStickyDone)
where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import Data.Char
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.IO as T
import Data.Time
import GHC.Foreign (withCString, peekCString)
import Language.Haskell.TH
import Network.HTTP.Client.Conduit (HasHttpManager(..))
import Network.HTTP.Conduit
import Prelude -- Fix AMP warning
import Stack.Types.Internal
import Stack.Types.Config (GlobalOpts (..))
import System.IO
import System.Log.FastLogger
#ifndef MIN_VERSION_time
#define MIN_VERSION_time(x, y, z) 0
#endif
#if !MIN_VERSION_time(1, 5, 0)
import System.Locale
#endif
--------------------------------------------------------------------------------
-- Main StackT monad transformer
-- | The monad used for the executable @stack@.
newtype StackT config m a =
StackT {unStackT :: ReaderT (Env config) m a}
deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadCatch,MonadMask,MonadTrans)
deriving instance (MonadBase b m) => MonadBase b (StackT config m)
instance MonadBaseControl b m => MonadBaseControl b (StackT config m) where
type StM (StackT config m) a = ComposeSt (StackT config) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl (StackT config) where
type StT (StackT config) a = StT (ReaderT (Env config)) a
liftWith = defaultLiftWith StackT unStackT
restoreT = defaultRestoreT StackT
-- | Takes the configured log level into account.
instance (MonadIO m) => MonadLogger (StackT config m) where
monadLoggerLog = stickyLoggerFunc
-- | Run a Stack action, using global options.
runStackTGlobal :: (MonadIO m,MonadBaseControl IO m)
=> Manager -> config -> GlobalOpts -> StackT config m a -> m a
runStackTGlobal manager config GlobalOpts{..} =
runStackT manager globalLogLevel config globalTerminal (isJust globalReExecVersion)
-- | Run a Stack action.
runStackT :: (MonadIO m,MonadBaseControl IO m)
=> Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a
runStackT manager logLevel config terminal reExec m = do
canUseUnicode <- liftIO getCanUseUnicode
withSticky
terminal
(\sticky ->
runReaderT
(unStackT m)
(Env config logLevel terminal reExec manager sticky canUseUnicode))
-- | Taken from GHC: determine if we should use Unicode syntax
getCanUseUnicode :: IO Bool
getCanUseUnicode = do
let enc = localeEncoding
str = "\x2018\x2019"
test = withCString enc str $ \cstr -> do
str' <- peekCString enc cstr
return (str == str')
test `catchIOError` \_ -> return False
--------------------------------------------------------------------------------
-- Logging only StackLoggingT monad transformer
-- | Monadic environment for 'StackLoggingT'.
data LoggingEnv = LoggingEnv
{ lenvLogLevel :: !LogLevel
, lenvTerminal :: !Bool
, lenvReExec :: !Bool
, lenvManager :: !Manager
, lenvSticky :: !Sticky
, lenvSupportsUnicode :: !Bool
}
-- | The monad used for logging in the executable @stack@ before
-- anything has been initialized.
newtype StackLoggingT m a = StackLoggingT
{ unStackLoggingT :: ReaderT LoggingEnv m a
} deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader LoggingEnv,MonadCatch,MonadMask,MonadTrans)
deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m)
instance MonadBaseControl b m => MonadBaseControl b (StackLoggingT m) where
type StM (StackLoggingT m) a = ComposeSt StackLoggingT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl StackLoggingT where
type StT StackLoggingT a = StT (ReaderT LoggingEnv) a
liftWith = defaultLiftWith StackLoggingT unStackLoggingT
restoreT = defaultRestoreT StackLoggingT
-- | Takes the configured log level into account.
instance (MonadIO m) => MonadLogger (StackLoggingT m) where
monadLoggerLog = stickyLoggerFunc
instance HasSticky LoggingEnv where
getSticky = lenvSticky
instance HasLogLevel LoggingEnv where
getLogLevel = lenvLogLevel
instance HasHttpManager LoggingEnv where
getHttpManager = lenvManager
instance HasTerminal LoggingEnv where
getTerminal = lenvTerminal
instance HasReExec LoggingEnv where
getReExec = lenvReExec
instance HasSupportsUnicode LoggingEnv where
getSupportsUnicode = lenvSupportsUnicode
runInnerStackT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m)
=> config -> StackT config IO a -> m a
runInnerStackT config inner = do
manager <- asks getHttpManager
logLevel <- asks getLogLevel
terminal <- asks getTerminal
reExec <- asks getReExec
liftIO $ runStackT manager logLevel config terminal reExec inner
runInnerStackLoggingT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m)
=> StackLoggingT IO a -> m a
runInnerStackLoggingT inner = do
manager <- asks getHttpManager
logLevel <- asks getLogLevel
terminal <- asks getTerminal
reExec <- asks getReExec
liftIO $ runStackLoggingT manager logLevel terminal reExec inner
-- | Run the logging monad, using global options.
runStackLoggingTGlobal :: MonadIO m
=> Manager -> GlobalOpts -> StackLoggingT m a -> m a
runStackLoggingTGlobal manager GlobalOpts{..} =
runStackLoggingT manager globalLogLevel globalTerminal (isJust globalReExecVersion)
-- | Run the logging monad.
runStackLoggingT :: MonadIO m
=> Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a
runStackLoggingT manager logLevel terminal reExec m = do
canUseUnicode <- liftIO getCanUseUnicode
withSticky
terminal
(\sticky ->
runReaderT
(unStackLoggingT m)
LoggingEnv
{ lenvLogLevel = logLevel
, lenvManager = manager
, lenvSticky = sticky
, lenvTerminal = terminal
, lenvReExec = reExec
, lenvSupportsUnicode = canUseUnicode
})
-- | Convenience for getting a 'Manager'
newTLSManager :: MonadIO m => m Manager
newTLSManager = liftIO $ newManager tlsManagerSettings
--------------------------------------------------------------------------------
-- Logging functionality
stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r (t m), MonadTrans t, MonadIO (t m))
=> Loc -> LogSource -> LogLevel -> msg -> t m ()
stickyLoggerFunc loc src level msg = do
Sticky mref <- asks getSticky
case mref of
Nothing ->
loggerFunc
loc
src
(case level of
LevelOther "sticky-done" -> LevelInfo
LevelOther "sticky" -> LevelInfo
_ -> level)
msg
Just ref -> do
sticky <- liftIO (takeMVar ref)
let backSpaceChar =
'\8'
repeating =
S8.replicate
(maybe 0 T.length sticky)
clear =
liftIO
(S8.putStr
(repeating backSpaceChar <>
repeating ' ' <>
repeating backSpaceChar))
maxLogLevel <- asks getLogLevel
-- Convert some GHC-generated Unicode characters as necessary
supportsUnicode <- asks getSupportsUnicode
let msgText
| supportsUnicode = msgTextRaw
| otherwise = T.map replaceUnicode msgTextRaw
newState <-
case level of
LevelOther "sticky-done" -> do
clear
liftIO (T.putStrLn msgText)
return Nothing
LevelOther "sticky" -> do
clear
liftIO (T.putStr msgText)
return (Just msgText)
_
| level >= maxLogLevel -> do
clear
loggerFunc loc src level $ toLogStr msgText
case sticky of
Nothing ->
return Nothing
Just line -> do
liftIO (T.putStr line)
return sticky
| otherwise ->
return sticky
liftIO (putMVar ref newState)
where
msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes
msgBytes = fromLogStr (toLogStr msg)
-- | Replace Unicode characters with non-Unicode equivalents
replaceUnicode :: Char -> Char
replaceUnicode '\x2018' = '`'
replaceUnicode '\x2019' = '\''
replaceUnicode c = c
-- | Logging function takes the log level into account.
loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)
=> Loc -> Text -> LogLevel -> msg -> m ()
loggerFunc loc _src level msg =
do maxLogLevel <- asks getLogLevel
when (level >= maxLogLevel)
(liftIO (do out <- getOutput maxLogLevel
T.hPutStrLn outputChannel out))
where outputChannel = stderr
getOutput maxLogLevel =
do timestamp <- getTimestamp
l <- getLevel
lc <- getLoc
return (T.pack timestamp <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc)
where getTimestamp
| maxLogLevel <= LevelDebug =
do now <- getZonedTime
return (formatTime' now ++ ": ")
| otherwise = return ""
where
formatTime' =
take timestampLength . formatTime defaultTimeLocale "%F %T.%q"
getLevel
| maxLogLevel <= LevelDebug =
return ("[" ++
map toLower (drop 5 (show level)) ++
"] ")
| otherwise = return ""
getLoc
| maxLogLevel <= LevelDebug =
return (" @(" ++ fileLocStr ++ ")")
| otherwise = return ""
fileLocStr =
loc_package loc ++
':' :
loc_module loc ++
' ' :
loc_filename loc ++
':' :
line loc ++
':' :
char loc
where line = show . fst . loc_start
char = show . snd . loc_start
-- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ".
-- This definition is top-level in order to avoid multiple reevaluation at runtime.
timestampLength :: Int
timestampLength =
length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0))
-- | With a sticky state, do the thing.
withSticky :: (MonadIO m)
=> Bool -> (Sticky -> m b) -> m b
withSticky terminal m =
if terminal
then do state <- liftIO (newMVar Nothing)
originalMode <- liftIO (hGetBuffering stdout)
liftIO (hSetBuffering stdout NoBuffering)
a <- m (Sticky (Just state))
state' <- liftIO (takeMVar state)
liftIO (when (isJust state') (S8.putStr "\n"))
liftIO (hSetBuffering stdout originalMode)
return a
else m (Sticky Nothing)
-- | Write a "sticky" line to the terminal. Any subsequent lines will
-- overwrite this one, and that same line will be repeated below
-- again. In other words, the line sticks at the bottom of the output
-- forever. Running this function again will replace the sticky line
-- with a new sticky line. When you want to get rid of the sticky
-- line, run 'logStickyDone'.
--
logSticky :: Q Exp
logSticky =
logOther "sticky"
-- | This will print out the given message with a newline and disable
-- any further stickiness of the line until a new call to 'logSticky'
-- happens.
--
-- It might be better at some point to have a 'runSticky' function
-- that encompasses the logSticky->logStickyDone pairing.
logStickyDone :: Q Exp
logStickyDone =
logOther "sticky-done"
stack-0.1.10.0/src/Stack/Types/Build.hs 0000644 0000000 0000000 00000074667 12630352213 015576 0 ustar 00 0000000 0000000 {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
-- | Build-specific types.
module Stack.Types.Build
(StackBuildException(..)
,FlagSource(..)
,UnusedFlags(..)
,InstallLocation(..)
,ModTime
,modTime
,Installed(..)
,PackageInstallInfo(..)
,Task(..)
,taskLocation
,LocalPackage(..)
,BaseConfigOpts(..)
,Plan(..)
,TestOpts(..)
,BenchmarkOpts(..)
,FileWatchOpts(..)
,BuildOpts(..)
,BuildSubset(..)
,defaultBuildOpts
,TaskType(..)
,TaskConfigOpts(..)
,ConfigCache(..)
,ConstructPlanException(..)
,configureOpts
,BadDependency(..)
,wantedLocalPackages
,FileCacheInfo (..)
,ConfigureOpts (..)
,PrecompiledCache (..))
where
import Control.DeepSeq
import Control.Exception
import Data.Binary (getWord8, putWord8, gput, gget)
import Data.Binary.VersionTagged
import qualified Data.ByteString as S
import Data.Char (isSpace)
import Data.Data
import Data.Hashable
import Data.List (dropWhileEnd, nub, intercalate)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time.Calendar
import Data.Time.Clock
import Distribution.System (Arch)
import Distribution.PackageDescription (TestSuiteInterface)
import Distribution.Text (display)
import GHC.Generics
import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ())
import Path.Extra (toFilePathNoTrailingSep)
import Prelude
import Stack.Types.FlagName
import Stack.Types.GhcPkgId
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import System.Exit (ExitCode (ExitFailure))
import System.FilePath (pathSeparator)
import System.Process.Log (showProcessArgDebug)
----------------------------------------------
-- Exceptions
data StackBuildException
= Couldn'tFindPkgId PackageName
| CompilerVersionMismatch
(Maybe (CompilerVersion, Arch))
(CompilerVersion, Arch)
GHCVariant
VersionCheck
(Maybe (Path Abs File))
Text -- recommended resolution
-- ^ Path to the stack.yaml file
| Couldn'tParseTargets [Text]
| UnknownTargets
(Set PackageName) -- no known version
(Map PackageName Version) -- not in snapshot, here's the most recent version in the index
(Path Abs File) -- stack.yaml
| TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
| TestSuiteTypeUnsupported TestSuiteInterface
| ConstructPlanExceptions
[ConstructPlanException]
(Path Abs File) -- stack.yaml
| CabalExitedUnsuccessfully
ExitCode
PackageIdentifier
(Path Abs File) -- cabal Executable
[String] -- cabal arguments
(Maybe (Path Abs File)) -- logfiles location
[S.ByteString] -- log contents
| ExecutionFailure [SomeException]
| LocalPackageDoesn'tMatchTarget
PackageName
Version -- local version
Version -- version specified on command line
| NoSetupHsFound (Path Abs Dir)
| InvalidFlagSpecification (Set UnusedFlags)
| TargetParseException [Text]
| DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])]
| SolverMissingCabalInstall
| SolverMissingGHC
| SolverNoCabalFiles
| SomeTargetsNotBuildable [(PackageName, NamedComponent)]
deriving Typeable
data FlagSource = FSCommandLine | FSStackYaml
deriving (Show, Eq, Ord)
data UnusedFlags = UFNoPackage FlagSource PackageName
| UFFlagsNotDefined FlagSource Package (Set FlagName)
| UFSnapshot PackageName
deriving (Show, Eq, Ord)
instance Show StackBuildException where
show (Couldn'tFindPkgId name) =
("After installing " <> packageNameString name <>
", the package id couldn't be found " <> "(via ghc-pkg describe " <>
packageNameString name <> "). This shouldn't happen, " <>
"please report as a bug")
show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat
[ case mactual of
Nothing -> "No compiler found, expected "
Just (actual, arch) -> concat
[ "Compiler version mismatched, found "
, compilerVersionString actual
, " ("
, display arch
, ")"
, ", but expected "
]
, case check of
MatchMinor -> "minor version match with "
MatchExact -> "exact version "
NewerMinor -> "minor version match or newer with "
, compilerVersionString expected
, " ("
, display earch
, ghcVariantSuffix ghcVariant
, ") (based on "
, case mstack of
Nothing -> "command line arguments"
Just stack -> "resolver setting in " ++ toFilePath stack
, ").\n"
, T.unpack resolution
]
show (Couldn'tParseTargets targets) = unlines
$ "The following targets could not be parsed as package names or directories:"
: map T.unpack targets
show (UnknownTargets noKnown notInSnapshot stackYaml) =
unlines $ noKnown' ++ notInSnapshot'
where
noKnown'
| Set.null noKnown = []
| otherwise = return $
"The following target packages were not found: " ++
intercalate ", " (map packageNameString $ Set.toList noKnown)
notInSnapshot'
| Map.null notInSnapshot = []
| otherwise =
"The following packages are not in your snapshot, but exist"
: "in your package index. Recommended action: add them to your"
: ("extra-deps in " ++ toFilePath stackYaml)
: "(Note: these are the most recent versions,"
: "but there's no guarantee that they'll build together)."
: ""
: map
(\(name, version) -> "- " ++ packageIdentifierString
(PackageIdentifier name version))
(Map.toList notInSnapshot)
show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat
[ ["Test suite failure for package " ++ packageIdentifierString ident]
, flip map (Map.toList codes) $ \(name, mcode) -> concat
[ " "
, T.unpack name
, ": "
, case mcode of
Nothing -> " executable not found"
Just ec -> " exited with: " ++ show ec
]
, return $ case mlogFile of
Nothing -> "Logs printed to console"
-- TODO Should we load up the full error output and print it here?
Just logFile -> "Full log available at " ++ toFilePath logFile
, if S.null bs
then []
else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
]
where
indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
doubleIndent = indent . indent
show (TestSuiteTypeUnsupported interface) =
("Unsupported test suite type: " <> show interface)
show (ConstructPlanExceptions exceptions stackYaml) =
"While constructing the BuildPlan the following exceptions were encountered:" ++
appendExceptions exceptions' ++
if Map.null extras then "" else (unlines
$ ("\n\nRecommended action: try adding the following to your extra-deps in "
++ toFilePath stackYaml)
: map (\(name, version) -> concat
[ "- "
, packageNameString name
, "-"
, versionString version
]) (Map.toList extras)
++ ["", "You may also want to try the 'stack solver' command"]
)
where
exceptions' = removeDuplicates exceptions
appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""
removeDuplicates = nub
extras = Map.unions $ map getExtras exceptions'
getExtras (DependencyCycleDetected _) = Map.empty
getExtras (UnknownPackage _) = Map.empty
getExtras (DependencyPlanFailures _ m) =
Map.unions $ map go $ Map.toList m
where
go (name, (_range, Just version, NotInBuildPlan)) =
Map.singleton name version
go _ = Map.empty
-- Supressing duplicate output
show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
let fullCmd = unwords
$ dropQuotes (toFilePath execName)
: map (T.unpack . showProcessArgDebug) fullArgs
logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles
in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++
" " ++ fullCmd ++ "\n" ++
" Process exited with code: " ++ show exitCode ++
(if exitCode == ExitFailure (-9)
then " (THIS MAY INDICATE OUT OF MEMORY)"
else "") ++
logLocations ++
(if null bss
then ""
else "\n\n" ++ doubleIndent (map (T.unpack . decodeUtf8With lenientDecode) bss))
where
doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line)
dropQuotes = filter ('\"' /=)
show (ExecutionFailure es) = intercalate "\n\n" $ map show es
show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
[ "Version for local package "
, packageNameString name
, " is "
, versionString localV
, ", but you asked for "
, versionString requestedV
, " on the command line"
]
show (NoSetupHsFound dir) =
"No Setup.hs or Setup.lhs file found in " ++ toFilePath dir
show (InvalidFlagSpecification unused) = unlines
$ "Invalid flag specification:"
: map go (Set.toList unused)
where
showFlagSrc :: FlagSource -> String
showFlagSrc FSCommandLine = " (specified on command line)"
showFlagSrc FSStackYaml = " (specified in stack.yaml)"
go :: UnusedFlags -> String
go (UFNoPackage src name) = concat
[ "- Package '"
, packageNameString name
, "' not found"
, showFlagSrc src
]
go (UFFlagsNotDefined src pkg flags) = concat
[ "- Package '"
, name
, "' does not define the following flags"
, showFlagSrc src
, ":\n"
, intercalate "\n"
(map (\flag -> " " ++ flagNameString flag)
(Set.toList flags))
, "\n- Flags defined by package '" ++ name ++ "':\n"
, intercalate "\n"
(map (\flag -> " " ++ name ++ ":" ++ flagNameString flag)
(Set.toList pkgFlags))
]
where name = packageNameString (packageName pkg)
pkgFlags = packageDefinedFlags pkg
go (UFSnapshot name) = concat
[ "- Attempted to set flag on snapshot package "
, packageNameString name
, ", please add to extra-deps"
]
show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err
show (TargetParseException errs) = unlines
$ "The following errors occurred while parsing the build targets:"
: map (("- " ++) . T.unpack) errs
show (DuplicateLocalPackageNames pairs) = concat
$ "The same package name is used in multiple local packages\n"
: map go pairs
where
go (name, dirs) = unlines
$ ""
: (packageNameString name ++ " used in:")
: map goDir dirs
goDir dir = "- " ++ toFilePath dir
show SolverMissingCabalInstall = unlines
[ "Solver requires that cabal be on your PATH"
, "Try running 'stack install cabal-install'"
]
show SolverMissingGHC = unlines
[ "Solver requires that GHC be on your PATH"
, "Try running 'stack setup'"
]
show SolverNoCabalFiles = unlines
[ "No cabal files provided. Maybe this is due to not having a stack.yaml file?"
, "Try running 'stack init' to create a stack.yaml"
]
show (SomeTargetsNotBuildable xs) =
"The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++
T.unpack (renderPkgComponents xs) ++
"\nTo resolve this, either provide flags such that these components are buildable, or only specify buildable targets."
instance Exception StackBuildException
data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
| UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
-- ^ Recommend adding to extra-deps, give a helpful version number?
deriving (Typeable, Eq)
-- | For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe Version
-- | Reason why a dependency was not used
data BadDependency
= NotInBuildPlan
| Couldn'tResolveItsDependencies
| DependencyMismatch Version
deriving (Typeable, Eq)
instance Show ConstructPlanException where
show e =
let details = case e of
(DependencyCycleDetected pNames) ->
"While checking call stack,\n" ++
" dependency cycle detected in packages:" ++ indent (appendLines pNames)
(DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->
"Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++
" needed for package: " ++ packageIdentifierString pIdent
(UnknownPackage pName) ->
"While attempting to add dependency,\n" ++
" Could not find package " ++ show pName ++ " in known packages"
in indent details
where
appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
doubleIndent = indent . indent
appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""
showDep (name, (range, mlatestApplicable, badDep)) = concat
[ show name
, ": needed ("
, display range
, ")"
, ", "
, let latestApplicableStr =
case mlatestApplicable of
Nothing -> ""
Just la -> " (latest applicable is " ++ versionString la ++ ")"
in case badDep of
NotInBuildPlan -> "not present in build plan" ++ latestApplicableStr
Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"
DependencyMismatch version ->
case mlatestApplicable of
Just la
| la == version ->
versionString version ++
" found (latest applicable version available)"
_ -> versionString version ++ " found" ++ latestApplicableStr
]
{- TODO Perhaps change the showDep function to look more like this:
dropQuotes = filter ((/=) '\"')
(VersionOutsideRange pName pIdentifier versionRange) ->
"Exception: Stack.Build.VersionOutsideRange\n" ++
" While adding dependency for package " ++ show pName ++ ",\n" ++
" " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++
" Allowed version range is " ++ display versionRange ++ ",\n" ++
" should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"
-}
----------------------------------------------
-- | Which subset of packages to build
data BuildSubset
= BSAll
| BSOnlySnapshot
-- ^ Only install packages in the snapshot database, skipping
-- packages intended for the local database.
| BSOnlyDependencies
deriving (Show, Eq)
-- | Configuration for building.
data BuildOpts =
BuildOpts {boptsTargets :: ![Text]
,boptsLibProfile :: !Bool
,boptsExeProfile :: !Bool
,boptsHaddock :: !Bool
-- ^ Build haddocks?
,boptsHaddockDeps :: !(Maybe Bool)
-- ^ Build haddocks for dependencies?
,boptsDryrun :: !Bool
,boptsGhcOptions :: ![Text]
,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))
,boptsInstallExes :: !Bool
-- ^ Install executables to user path after building?
,boptsPreFetch :: !Bool
-- ^ Fetch all packages immediately
,boptsBuildSubset :: !BuildSubset
,boptsFileWatch :: !FileWatchOpts
-- ^ Watch files for changes and automatically rebuild
,boptsKeepGoing :: !(Maybe Bool)
-- ^ Keep building/running after failure
,boptsForceDirty :: !Bool
-- ^ Force treating all local packages as having dirty files
,boptsTests :: !Bool
-- ^ Turn on tests for local targets
,boptsTestOpts :: !TestOpts
-- ^ Additional test arguments
,boptsBenchmarks :: !Bool
-- ^ Turn on benchmarks for local targets
,boptsBenchmarkOpts :: !BenchmarkOpts
-- ^ Additional test arguments
,boptsExec :: ![(String, [String])]
-- ^ Commands (with arguments) to run after a successful build
,boptsOnlyConfigure :: !Bool
-- ^ Only perform the configure step when building
,boptsReconfigure :: !Bool
-- ^ Perform the configure step even if already configured
,boptsCabalVerbose :: !Bool
-- ^ Ask Cabal to be verbose in its builds
}
deriving (Show)
defaultBuildOpts :: BuildOpts
defaultBuildOpts = BuildOpts
{ boptsTargets = []
, boptsLibProfile = False
, boptsExeProfile = False
, boptsHaddock = False
, boptsHaddockDeps = Nothing
, boptsDryrun = False
, boptsGhcOptions = []
, boptsFlags = Map.empty
, boptsInstallExes = False
, boptsPreFetch = False
, boptsBuildSubset = BSAll
, boptsFileWatch = NoFileWatch
, boptsKeepGoing = Nothing
, boptsForceDirty = False
, boptsTests = False
, boptsTestOpts = defaultTestOpts
, boptsBenchmarks = False
, boptsBenchmarkOpts = defaultBenchmarkOpts
, boptsExec = []
, boptsOnlyConfigure = False
, boptsReconfigure = False
, boptsCabalVerbose = False
}
-- | Options for the 'FinalAction' 'DoTests'
data TestOpts =
TestOpts {toRerunTests :: !Bool -- ^ Whether successful tests will be run gain
,toAdditionalArgs :: ![String] -- ^ Arguments passed to the test program
,toCoverage :: !Bool -- ^ Generate a code coverage report
,toDisableRun :: !Bool -- ^ Disable running of tests
} deriving (Eq,Show)
defaultTestOpts :: TestOpts
defaultTestOpts = TestOpts
{ toRerunTests = True
, toAdditionalArgs = []
, toCoverage = False
, toDisableRun = False
}
-- | Options for the 'FinalAction' 'DoBenchmarks'
data BenchmarkOpts =
BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program
,beoDisableRun :: !Bool -- ^ Disable running of benchmarks
} deriving (Eq,Show)
defaultBenchmarkOpts :: BenchmarkOpts
defaultBenchmarkOpts = BenchmarkOpts
{ beoAdditionalArgs = Nothing
, beoDisableRun = False
}
data FileWatchOpts
= NoFileWatch
| FileWatch
| FileWatchPoll
deriving (Show,Eq)
-- | Package dependency oracle.
newtype PkgDepsOracle =
PkgDeps PackageName
deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- | Stored on disk to know whether the flags have changed or any
-- files have changed.
data ConfigCache = ConfigCache
{ configCacheOpts :: !ConfigureOpts
-- ^ All options used for this package.
, configCacheDeps :: !(Set GhcPkgId)
-- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take
-- the complete GhcPkgId (only a PackageIdentifier) in the configure
-- options, just using the previous value is insufficient to know if
-- dependencies have changed.
, configCacheComponents :: !(Set S.ByteString)
-- ^ The components to be built. It's a bit of a hack to include this in
-- here, as it's not a configure option (just a build option), but this
-- is a convenient way to force compilation when the components change.
, configCacheHaddock :: !Bool
-- ^ Are haddocks to be built?
}
deriving (Generic,Eq,Show)
instance Binary ConfigCache where
put x = do
-- magic string
putWord8 1
putWord8 3
putWord8 4
putWord8 8
gput $ from x
get = do
1 <- getWord8
3 <- getWord8
4 <- getWord8
8 <- getWord8
fmap to gget
instance NFData ConfigCache
instance HasStructuralInfo ConfigCache
instance HasSemanticVersion ConfigCache
-- | A task to perform when building
data Task = Task
{ taskProvides :: !PackageIdentifier
-- ^ the package/version to be built
, taskType :: !TaskType
-- ^ the task type, telling us how to build this
, taskConfigOpts :: !TaskConfigOpts
, taskPresent :: !(Map PackageIdentifier GhcPkgId)
-- ^ GhcPkgIds of already-installed dependencies
, taskAllInOne :: !Bool
-- ^ indicates that the package can be built in one step
}
deriving Show
-- | Given the IDs of any missing packages, produce the configure options
data TaskConfigOpts = TaskConfigOpts
{ tcoMissing :: !(Set PackageIdentifier)
-- ^ Dependencies for which we don't yet have an GhcPkgId
, tcoOpts :: !(Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-- ^ Produce the list of options given the missing @GhcPkgId@s
}
instance Show TaskConfigOpts where
show (TaskConfigOpts missing f) = concat
[ "Missing: "
, show missing
, ". Without those: "
, show $ f Map.empty
]
-- | The type of a task, either building local code or something from the
-- package index (upstream)
data TaskType = TTLocal LocalPackage
| TTUpstream Package InstallLocation
deriving Show
taskLocation :: Task -> InstallLocation
taskLocation task =
case taskType task of
TTLocal _ -> Local
TTUpstream _ loc -> loc
-- | A complete plan of what needs to be built and how to do it
data Plan = Plan
{ planTasks :: !(Map PackageName Task)
, planFinals :: !(Map PackageName Task)
-- ^ Final actions to be taken (test, benchmark, etc)
, planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text))
-- ^ Text is reason we're unregistering, for display only
, planInstallExes :: !(Map Text InstallLocation)
-- ^ Executables that should be installed after successful building
}
deriving Show
-- | Basic information used to calculate what the configure options are
data BaseConfigOpts = BaseConfigOpts
{ bcoSnapDB :: !(Path Abs Dir)
, bcoLocalDB :: !(Path Abs Dir)
, bcoSnapInstallRoot :: !(Path Abs Dir)
, bcoLocalInstallRoot :: !(Path Abs Dir)
, bcoBuildOpts :: !BuildOpts
, bcoExtraDBs :: ![(Path Abs Dir)]
}
-- | Render a @BaseConfigOpts@ to an actual list of options
configureOpts :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId -- ^ dependencies
-> Bool -- ^ wanted?
-> Bool -- ^ local non-extra-dep?
-> InstallLocation
-> Package
-> ConfigureOpts
configureOpts econfig bco deps wanted isLocal loc package = ConfigureOpts
{ coDirs = configureOptsDirs bco loc package
, coNoDirs = configureOptsNoDir econfig bco deps wanted isLocal package
}
configureOptsDirs :: BaseConfigOpts
-> InstallLocation
-> Package
-> [String]
configureOptsDirs bco loc package = concat
[ ["--user", "--package-db=clear", "--package-db=global"]
, map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case loc of
Snap -> bcoExtraDBs bco ++ [bcoSnapDB bco]
Local -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco]
, [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "lib"))
, "--bindir=" ++ toFilePathNoTrailingSep (installRoot bindirSuffix)
, "--datadir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "share"))
, "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "libexec"))
, "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "etc"))
, "--docdir=" ++ toFilePathNoTrailingSep docDir
, "--htmldir=" ++ toFilePathNoTrailingSep docDir
, "--haddockdir=" ++ toFilePathNoTrailingSep docDir]
]
where
installRoot =
case loc of
Snap -> bcoSnapInstallRoot bco
Local -> bcoLocalInstallRoot bco
docDir =
case pkgVerDir of
Nothing -> installRoot docDirSuffix
Just dir -> installRoot docDirSuffix dir
pkgVerDir =
parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)
(packageVersion package)) ++
[pathSeparator])
-- | Same as 'configureOpts', but does not include directory path options
configureOptsNoDir :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId -- ^ dependencies
-> Bool -- ^ wanted?
-> Bool -- ^ is this a local, non-extra-dep?
-> Package
-> [String]
configureOptsNoDir econfig bco deps wanted isLocal package = concat
[ depOptions
, ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]
, ["--enable-executable-profiling" | boptsExeProfile bopts]
, map (\(name,enabled) ->
"-f" <>
(if enabled
then ""
else "-") <>
flagNameString name)
(Map.toList (packageFlags package))
, concatMap (\x -> ["--ghc-options", T.unpack x]) allGhcOptions
, map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))
, map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))
, if whichCompiler (envConfigCompilerVersion econfig) == Ghcjs
then ["--ghcjs"]
else []
]
where
config = getConfig econfig
bopts = bcoBuildOpts bco
depOptions = map (uncurry toDepOption) $ Map.toList deps
where
toDepOption =
if envConfigCabalVersion econfig >= $(mkVersion "1.22")
then toDepOption1_22
else toDepOption1_18
toDepOption1_22 ident gid = concat
[ "--dependency="
, packageNameString $ packageIdentifierName ident
, "="
, ghcPkgIdString gid
]
toDepOption1_18 ident _gid = concat
[ "--constraint="
, packageNameString name
, "=="
, versionString version
]
where
PackageIdentifier name version = ident
allGhcOptions = concat
[ Map.findWithDefault [] Nothing (configGhcOptions config)
, Map.findWithDefault [] (Just $ packageName package) (configGhcOptions config)
, concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]
, if includeExtraOptions
then boptsGhcOptions bopts
else []
]
includeExtraOptions =
case configApplyGhcOptions config of
AGOTargets -> wanted
AGOLocals -> isLocal
AGOEverything -> True
-- | Get set of wanted package names from locals.
wantedLocalPackages :: [LocalPackage] -> Set PackageName
wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted
-- | One-way conversion to serialized time.
modTime :: UTCTime -> ModTime
modTime x =
ModTime
( toModifiedJulianDay
(utctDay x)
, toRational
(utctDayTime x))
-- | Configure options to be sent to Setup.hs configure
data ConfigureOpts = ConfigureOpts
{ coDirs :: ![String]
-- ^ Options related to various paths. We separate these out since they do
-- not have an impact on the contents of the compiled binary for checking
-- if we can use an existing precompiled cache.
, coNoDirs :: ![String]
}
deriving (Show, Eq, Generic)
instance Binary ConfigureOpts
instance HasStructuralInfo ConfigureOpts
instance NFData ConfigureOpts
-- | Information on a compiled package: the library conf file (if relevant),
-- and all of the executable paths.
data PrecompiledCache = PrecompiledCache
-- Use FilePath instead of Path Abs File for Binary instances
{ pcLibrary :: !(Maybe FilePath)
-- ^ .conf file inside the package database
, pcExes :: ![FilePath]
-- ^ Full paths to executables
}
deriving (Show, Eq, Generic)
instance Binary PrecompiledCache
instance HasSemanticVersion PrecompiledCache
instance HasStructuralInfo PrecompiledCache
instance NFData PrecompiledCache
stack-0.1.10.0/src/Stack/Types/Package.hs 0000644 0000000 0000000 00000035222 12630352213 016052 0 ustar 00 0000000 0000000 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- |
module Stack.Types.Package where
import Control.DeepSeq
import Control.Exception hiding (try,catch)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader
import Data.Binary
import Data.Binary.VersionTagged
import qualified Data.ByteString as S
import Data.Data
import Data.Function
import Data.List
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Distribution.InstalledPackageInfo (PError)
import Distribution.ModuleName (ModuleName)
import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
import Distribution.PackageDescription (TestSuiteInterface)
import Distribution.System (Platform (..))
import Distribution.Text (display)
import GHC.Generics
import Path as FL
import Prelude
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.FlagName
import Stack.Types.GhcPkgId
import Stack.Types.PackageName
import Stack.Types.PackageIdentifier
import Stack.Types.Version
-- | All exceptions thrown by the library.
data PackageException
= PackageInvalidCabalFile (Maybe (Path Abs File)) PError
| PackageNoCabalFileFound (Path Abs Dir)
| PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]
| MismatchedCabalName (Path Abs File) PackageName
deriving Typeable
instance Exception PackageException
instance Show PackageException where
show (PackageInvalidCabalFile mfile err) =
"Unable to parse cabal file" ++
(case mfile of
Nothing -> ""
Just file -> ' ' : toFilePath file) ++
": " ++
show err
show (PackageNoCabalFileFound dir) =
"No .cabal file found in directory " ++
toFilePath dir
show (PackageMultipleCabalFilesFound dir files) =
"Multiple .cabal files found in directory " ++
toFilePath dir ++
": " ++
intercalate ", " (map (toFilePath . filename) files)
show (MismatchedCabalName fp name) = concat
[ "cabal file path "
, toFilePath fp
, " does not match the package name it defines.\n"
, "Please rename the file to: "
, packageNameString name
, ".cabal\n"
, "For more information, see: https://github.com/commercialhaskell/stack/issues/317"
]
-- | Some package info.
data Package =
Package {packageName :: !PackageName -- ^ Name of the package.
,packageVersion :: !Version -- ^ Version of the package
,packageFiles :: !GetPackageFiles -- ^ Get all files of the package.
,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.
,packageTools :: ![Dependency] -- ^ A build tool name.
,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).
,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.
,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?
,packageTests :: !(Map Text TestSuiteInterface) -- ^ names and interfaces of test suites
,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks
,packageExes :: !(Set Text) -- ^ names of executables
,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC.
,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules?
,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple
,packageDefinedFlags :: !(Set FlagName) -- ^ All flags defined in the .cabal file
}
deriving (Show,Typeable)
-- | Files that the package depends on, relative to package directory.
-- Argument is the location of the .cabal file
newtype GetPackageOpts = GetPackageOpts
{ getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadLogger m, MonadCatch m)
=> SourceMap
-> InstalledMap
-> [PackageName]
-> Path Abs File
-> m (Map NamedComponent (Set ModuleName)
,Map NamedComponent (Set DotCabalPath)
,Map NamedComponent BuildInfoOpts)
}
instance Show GetPackageOpts where
show _ = ""
-- | GHC options based on cabal information and ghc-options.
data BuildInfoOpts = BuildInfoOpts
{ bioOpts :: [String]
, bioOneWordOpts :: [String]
-- ^ These options can safely have 'nubOrd' applied to them, as
-- there are no multi-word options (see
-- https://github.com/commercialhaskell/stack/issues/1255)
, bioCabalMacros :: Maybe (Path Abs File)
} deriving Show
-- | Files to get for a cabal package.
data CabalFileType
= AllFiles
| Modules
-- | Files that the package depends on, relative to package directory.
-- Argument is the location of the .cabal file
newtype GetPackageFiles = GetPackageFiles
{ getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> Path Abs File
-> m (Map NamedComponent (Set ModuleName)
,Map NamedComponent (Set DotCabalPath)
,Set (Path Abs File)
,[PackageWarning])
}
instance Show GetPackageFiles where
show _ = ""
-- | Warning generated when reading a package
data PackageWarning
= UnlistedModulesWarning (Path Abs File) (Maybe String) [ModuleName]
-- ^ Modules found that are not listed in cabal file
instance Show PackageWarning where
show (UnlistedModulesWarning cabalfp component [unlistedModule]) =
concat
[ "module not listed in "
, toFilePath (filename cabalfp)
, case component of
Nothing -> " for library"
Just c -> " for '" ++ c ++ "'"
, " component (add to other-modules): "
, display unlistedModule]
show (UnlistedModulesWarning cabalfp component unlistedModules) =
concat
[ "modules not listed in "
, toFilePath (filename cabalfp)
, case component of
Nothing -> " for library"
Just c -> " for '" ++ c ++ "'"
, " component (add to other-modules):\n "
, intercalate "\n " (map display unlistedModules)]
-- | Package build configuration
data PackageConfig =
PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?
,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?
,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.
,packageConfigCompilerVersion :: !CompilerVersion -- ^ GHC version
,packageConfigPlatform :: !Platform -- ^ host platform
}
deriving (Show,Typeable)
-- | Compares the package name.
instance Ord Package where
compare = on compare packageName
-- | Compares the package name.
instance Eq Package where
(==) = on (==) packageName
type SourceMap = Map PackageName PackageSource
-- | Where the package's source is located: local directory or package index
data PackageSource
= PSLocal LocalPackage
| PSUpstream Version InstallLocation (Map FlagName Bool)
-- ^ Upstream packages could be installed in either local or snapshot
-- databases; this is what 'InstallLocation' specifies.
deriving Show
instance PackageInstallInfo PackageSource where
piiVersion (PSLocal lp) = packageVersion $ lpPackage lp
piiVersion (PSUpstream v _ _) = v
piiLocation (PSLocal _) = Local
piiLocation (PSUpstream _ loc _) = loc
-- | Datatype which tells how which version of a package to install and where
-- to install it into
class PackageInstallInfo a where
piiVersion :: a -> Version
piiLocation :: a -> InstallLocation
-- | Information on a locally available package of source code
data LocalPackage = LocalPackage
{ lpPackage :: !Package
-- ^ The @Package@ info itself, after resolution with package flags,
-- with tests and benchmarks disabled
, lpComponents :: !(Set NamedComponent)
-- ^ Components to build, not including the library component.
, lpUnbuildable :: !(Set NamedComponent)
-- ^ Components explicitly requested for build, that are marked
-- "buildable: false".
, lpWanted :: !Bool
-- ^ Whether this package is wanted as a target.
, lpTestDeps :: !(Map PackageName VersionRange)
-- ^ Used for determining if we can use --enable-tests in a normal build.
, lpBenchDeps :: !(Map PackageName VersionRange)
-- ^ Used for determining if we can use --enable-benchmarks in a normal
-- build.
, lpTestBench :: !(Maybe Package)
-- ^ This stores the 'Package' with tests and benchmarks enabled, if
-- either is asked for by the user.
, lpDir :: !(Path Abs Dir)
-- ^ Directory of the package.
, lpCabalFile :: !(Path Abs File)
-- ^ The .cabal file
, lpDirtyFiles :: !(Maybe (Set FilePath))
-- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if
-- we forced the build to treat packages as dirty. Also, the Set may not
-- include all modified files.
, lpNewBuildCache :: !(Map FilePath FileCacheInfo)
-- ^ current state of the files
, lpFiles :: !(Set (Path Abs File))
-- ^ all files used by this package
}
deriving Show
-- | A single, fully resolved component of a package
data NamedComponent
= CLib
| CExe !Text
| CTest !Text
| CBench !Text
deriving (Show, Eq, Ord)
renderComponent :: NamedComponent -> S.ByteString
renderComponent CLib = "lib"
renderComponent (CExe x) = "exe:" <> encodeUtf8 x
renderComponent (CTest x) = "test:" <> encodeUtf8 x
renderComponent (CBench x) = "bench:" <> encodeUtf8 x
renderPkgComponents :: [(PackageName, NamedComponent)] -> Text
renderPkgComponents = T.intercalate " " . map renderPkgComponent
renderPkgComponent :: (PackageName, NamedComponent) -> Text
renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp)
exeComponents :: Set NamedComponent -> Set Text
exeComponents = Set.fromList . mapMaybe mExeName . Set.toList
where
mExeName (CExe name) = Just name
mExeName _ = Nothing
testComponents :: Set NamedComponent -> Set Text
testComponents = Set.fromList . mapMaybe mTestName . Set.toList
where
mTestName (CTest name) = Just name
mTestName _ = Nothing
benchComponents :: Set NamedComponent -> Set Text
benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList
where
mBenchName (CBench name) = Just name
mBenchName _ = Nothing
isCLib :: NamedComponent -> Bool
isCLib CLib{} = True
isCLib _ = False
isCExe :: NamedComponent -> Bool
isCExe CExe{} = True
isCExe _ = False
isCTest :: NamedComponent -> Bool
isCTest CTest{} = True
isCTest _ = False
isCBench :: NamedComponent -> Bool
isCBench CBench{} = True
isCBench _ = False
-- | A location to install a package into, either snapshot or local
data InstallLocation = Snap | Local
deriving (Show, Eq)
instance Monoid InstallLocation where
mempty = Snap
mappend Local _ = Local
mappend _ Local = Local
mappend Snap Snap = Snap
data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal
deriving (Show, Eq)
data FileCacheInfo = FileCacheInfo
{ fciModTime :: !ModTime
, fciSize :: !Word64
, fciHash :: !S.ByteString
}
deriving (Generic, Show)
instance Binary FileCacheInfo
instance HasStructuralInfo FileCacheInfo
instance NFData FileCacheInfo
-- | Used for storage and comparison.
newtype ModTime = ModTime (Integer,Rational)
deriving (Ord,Show,Generic,Eq,NFData,Binary)
instance HasStructuralInfo ModTime
instance HasSemanticVersion ModTime
-- | A descriptor from a .cabal file indicating one of the following:
--
-- exposed-modules: Foo
-- other-modules: Foo
-- or
-- main-is: Foo.hs
--
data DotCabalDescriptor
= DotCabalModule !ModuleName
| DotCabalMain !FilePath
| DotCabalFile !FilePath
| DotCabalCFile !FilePath
deriving (Eq,Ord,Show)
-- | Maybe get the module name from the .cabal descriptor.
dotCabalModule :: DotCabalDescriptor -> Maybe ModuleName
dotCabalModule (DotCabalModule m) = Just m
dotCabalModule _ = Nothing
-- | Maybe get the main name from the .cabal descriptor.
dotCabalMain :: DotCabalDescriptor -> Maybe FilePath
dotCabalMain (DotCabalMain m) = Just m
dotCabalMain _ = Nothing
-- | A path resolved from the .cabal file, which is either main-is or
-- an exposed/internal/referenced module.
data DotCabalPath
= DotCabalModulePath !(Path Abs File)
| DotCabalMainPath !(Path Abs File)
| DotCabalFilePath !(Path Abs File)
| DotCabalCFilePath !(Path Abs File)
deriving (Eq,Ord,Show)
-- | Get the module path.
dotCabalModulePath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalModulePath (DotCabalModulePath fp) = Just fp
dotCabalModulePath _ = Nothing
-- | Get the main path.
dotCabalMainPath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath (DotCabalMainPath fp) = Just fp
dotCabalMainPath _ = Nothing
-- | Get the c file path.
dotCabalCFilePath :: DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath (DotCabalCFilePath fp) = Just fp
dotCabalCFilePath _ = Nothing
-- | Get the path.
dotCabalGetPath :: DotCabalPath -> Path Abs File
dotCabalGetPath dcp =
case dcp of
DotCabalModulePath fp -> fp
DotCabalMainPath fp -> fp
DotCabalFilePath fp -> fp
DotCabalCFilePath fp -> fp
type InstalledMap = Map PackageName (InstallLocation, Installed)
data Installed = Library PackageIdentifier GhcPkgId | Executable PackageIdentifier
deriving (Show, Eq, Ord)
-- | Get the installed Version.
installedVersion :: Installed -> Version
installedVersion (Library (PackageIdentifier _ v) _) = v
installedVersion (Executable (PackageIdentifier _ v)) = v
stack-0.1.10.0/src/Stack/Build.hs 0000644 0000000 0000000 00000033211 12630352213 014446 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- | Build the project.
module Stack.Build
(build
,withLoadPackage
,mkBaseConfigOpts
,queryBuildInfo)
where
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import Data.Aeson (Value (Object, Array), (.=), object)
import Data.Function
import qualified Data.HashMap.Strict as HM
import Data.IORef.RunOnce (runOnce)
import Data.List ((\\))
import Data.List.Extra (groupSort)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as TIO
import Data.Text.Read (decimal)
import qualified Data.Vector as V
import qualified Data.Yaml as Yaml
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.ConstructPlan
import Stack.Build.Execute
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Build.Target
import Stack.Fetch as Fetch
import Stack.GhcPkg
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.FileLock (FileLock, unlockFile)
#ifdef WINDOWS
import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
import qualified Control.Monad.Catch as Catch
#endif
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
-- | Build.
--
-- If a buildLock is passed there is an important contract here. That lock must
-- protect the snapshot, and it must be safe to unlock it if there are no further
-- modifications to the snapshot to be performed by this build.
build :: M env m
=> (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
-> Maybe FileLock
-> BuildOpts
-> m ()
build setLocalFiles mbuildLk bopts = fixCodePage' $ do
menv <- getMinimalEnvOverride
(_, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts
-- Set local files, necessary for file watching
stackYaml <- asks $ bcStackYaml . getBuildConfig
liftIO $ setLocalFiles
$ Set.insert stackYaml
$ Set.unions
$ map lpFiles locals
(installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <-
getInstalled menv
GetInstalledOpts
{ getInstalledProfiling = profiling
, getInstalledHaddock = shouldHaddockDeps bopts }
sourceMap
baseConfigOpts <- mkBaseConfigOpts bopts
plan <- withLoadPackage menv $ \loadPackage ->
constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap
-- If our work to do is all local, let someone else have a turn with the snapshot.
-- They won't damage what's already in there.
case (mbuildLk, allLocal plan) of
-- NOTE: This policy is too conservative. In the future we should be able to
-- schedule unlocking as an Action that happens after all non-local actions are
-- complete.
(Just lk,True) -> do $logDebug "All installs are local; releasing snapshot lock early."
liftIO $ unlockFile lk
_ -> return ()
warnIfExecutablesWithSameNameCouldBeOverwritten locals plan
when (boptsPreFetch bopts) $
preFetch plan
if boptsDryrun bopts
then printPlan plan
else executePlan menv bopts baseConfigOpts locals
globalDumpPkgs
snapshotDumpPkgs
localDumpPkgs
installedMap
plan
where
profiling = boptsLibProfile bopts || boptsExeProfile bopts
-- | If all the tasks are local, they don't mutate anything outside of our local directory.
allLocal :: Plan -> Bool
allLocal =
all (== Local) .
map taskLocation .
Map.elems .
planTasks
-- | See https://github.com/commercialhaskell/stack/issues/1198.
warnIfExecutablesWithSameNameCouldBeOverwritten
:: MonadLogger m => [LocalPackage] -> Plan -> m ()
warnIfExecutablesWithSameNameCouldBeOverwritten locals plan =
forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do
let exe_s
| length toBuild > 1 = "several executables with the same name:"
| otherwise = "executable"
exesText pkgs =
T.intercalate
", "
["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs]
($logWarn . T.unlines . concat)
[ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ]
, [ "Only one of them will be available via 'stack exec' or locally installed."
| length toBuild > 1
]
, [ "Other executables with the same name might be overwritten: " <>
exesText otherLocals <> "."
| not (null otherLocals)
]
]
where
-- Cases of several local packages having executables with the same name.
-- The Map entries have the following form:
--
-- executable name: ( package names for executables that are being built
-- , package names for other local packages that have an
-- executable with the same name
-- )
warnings :: Map Text ([PackageName],[PackageName])
warnings =
Map.mapMaybe
(\(pkgsToBuild,localPkgs) ->
case (pkgsToBuild,NE.toList localPkgs \\ NE.toList pkgsToBuild) of
(_ :| [],[]) ->
-- We want to build the executable of single local package
-- and there are no other local packages with an executable of
-- the same name. Nothing to warn about, ignore.
Nothing
(_,otherLocals) ->
-- We could be here for two reasons (or their combination):
-- 1) We are building two or more executables with the same
-- name that will end up overwriting each other.
-- 2) In addition to the executable(s) that we want to build
-- there are other local packages with an executable of the
-- same name that might get overwritten.
-- Both cases warrant a warning.
Just (NE.toList pkgsToBuild,otherLocals))
(Map.intersectionWith (,) exesToBuild localExes)
exesToBuild :: Map Text (NonEmpty PackageName)
exesToBuild =
collect
[ (exe,pkgName)
| (pkgName,task) <- Map.toList (planTasks plan)
, isLocal task
, exe <- (Set.toList . exeComponents . lpComponents . taskLP) task
]
where
isLocal Task{taskType = (TTLocal _)} = True
isLocal _ = False
taskLP Task{taskType = (TTLocal lp)} = lp
taskLP _ = error "warnIfExecutablesWithSameNameCouldBeOverwritten/taskLP: task isn't local"
localExes :: Map Text (NonEmpty PackageName)
localExes =
collect
[ (exe,packageName pkg)
| pkg <- map (lpPackage) locals
, exe <- Set.toList (packageExes pkg)
]
collect :: Ord k => [(k,v)] -> Map k (NonEmpty v)
collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort
-- | Get the @BaseConfigOpts@ necessary for constructing configure options
mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> BuildOpts -> m BaseConfigOpts
mkBaseConfigOpts bopts = do
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
snapInstallRoot <- installationRootDeps
localInstallRoot <- installationRootLocal
packageExtraDBs <- packageDatabaseExtra
return BaseConfigOpts
{ bcoSnapDB = snapDBPath
, bcoLocalDB = localDBPath
, bcoSnapInstallRoot = snapInstallRoot
, bcoLocalInstallRoot = localInstallRoot
, bcoBuildOpts = bopts
, bcoExtraDBs = packageExtraDBs
}
-- | Provide a function for loading package information from the package index
withLoadPackage :: ( MonadIO m
, HasHttpManager env
, MonadReader env m
, MonadBaseControl IO m
, MonadCatch m
, MonadLogger m
, HasEnvConfig env)
=> EnvOverride
-> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)
-> m a
withLoadPackage menv inner = do
econfig <- asks getEnvConfig
withCabalLoader' <- runOnce $ withCabalLoader menv $ \cabalLoader ->
inner $ \name version flags -> do
bs <- cabalLoader $ PackageIdentifier name version -- TODO automatically update index the first time this fails
-- Intentionally ignore warnings, as it's not really
-- appropriate to print a bunch of warnings out while
-- resolving the package index.
(_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs
return pkg
withCabalLoader'
where
-- | Package config to be used for dependencies
depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig
depPackageConfig econfig flags = PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = flags
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform (getConfig econfig)
}
-- | Set the code page for this process as necessary. Only applies to Windows.
-- See: https://github.com/commercialhaskell/stack/issues/738
fixCodePage :: (MonadIO m, MonadMask m, MonadLogger m) => m a -> m a
#ifdef WINDOWS
fixCodePage inner = do
origCPI <- liftIO getConsoleCP
origCPO <- liftIO getConsoleOutputCP
let setInput = origCPI /= expected
setOutput = origCPO /= expected
fixInput
| setInput = Catch.bracket_
(liftIO $ do
setConsoleCP expected)
(liftIO $ setConsoleCP origCPI)
| otherwise = id
fixOutput
| setInput = Catch.bracket_
(liftIO $ do
setConsoleOutputCP expected)
(liftIO $ setConsoleOutputCP origCPO)
| otherwise = id
case (setInput, setOutput) of
(False, False) -> return ()
(True, True) -> warn ""
(True, False) -> warn " input"
(False, True) -> warn " output"
fixInput $ fixOutput inner
where
expected = 65001 -- UTF-8
warn typ = $logInfo $ T.concat
[ "Setting"
, typ
, " codepage to UTF-8 (65001) to ensure correct output from GHC"
]
#else
fixCodePage = id
#endif
fixCodePage' :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)
=> m a
-> m a
fixCodePage' inner = do
mcp <- asks $ configModifyCodePage . getConfig
if mcp
then fixCodePage inner
else inner
-- | Query information about the build and print the result to stdout in YAML format.
queryBuildInfo :: M env m
=> [Text] -- ^ selectors
-> m ()
queryBuildInfo selectors0 =
rawBuildInfo
>>= select id selectors0
>>= liftIO . TIO.putStrLn . decodeUtf8 . Yaml.encode
where
select _ [] value = return value
select front (sel:sels) value =
case value of
Object o ->
case HM.lookup sel o of
Nothing -> err "Selector not found"
Just value' -> cont value'
Array v ->
case decimal sel of
Right (i, "")
| i >= 0 && i < V.length v -> cont $ v V.! i
| otherwise -> err "Index out of range"
_ -> err "Encountered array and needed numeric selector"
_ -> err $ "Cannot apply selector to " ++ show value
where
cont = select (front . (sel:)) sels
err msg = error $ msg ++ ": " ++ show (front [sel])
-- | Get the raw build information object
rawBuildInfo :: M env m => m Value
rawBuildInfo = do
(_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOpts
return $ object
[ "locals" .= Object (HM.fromList $ map localToPair locals)
]
where
localToPair lp =
(T.pack $ packageNameString $ packageName p, value)
where
p = lpPackage lp
value = object
[ "version" .= packageVersion p
, "path" .= toFilePath (lpDir lp)
]
stack-0.1.10.0/src/Stack/Build/Cache.hs 0000644 0000000 0000000 00000030043 12623647202 015460 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ConstraintKinds #-}
-- | Cache information about previous builds
module Stack.Build.Cache
( tryGetBuildCache
, tryGetConfigCache
, tryGetCabalMod
, getInstalledExes
, buildCacheTimes
, tryGetFlagCache
, deleteCaches
, markExeInstalled
, markExeNotInstalled
, writeFlagCache
, writeBuildCache
, writeConfigCache
, writeCabalMod
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
, writePrecompiledCache
, readPrecompiledCache
) where
import Control.Exception.Enclosed (handleIO)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.Binary as Binary (encode)
import Data.Binary.VersionTagged
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Base16 as B16
import Data.Map (Map)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Path
import Path.IO
import Stack.Types.Build
import Stack.Constants
import Stack.Types
-- | Directory containing files to mark an executable as installed
exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> InstallLocation -> m (Path Abs Dir)
exeInstalledDir Snap = ( $(mkRelDir "installed-packages")) `liftM` installationRootDeps
exeInstalledDir Local = ( $(mkRelDir "installed-packages")) `liftM` installationRootLocal
-- | Get all of the installed executables
getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> m [PackageIdentifier]
getInstalledExes loc = do
dir <- exeInstalledDir loc
(_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir
return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files
-- | Mark the given executable as installed
markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeInstalled loc ident = do
dir <- exeInstalledDir loc
createTree dir
ident' <- parseRelFile $ packageIdentifierString ident
let fp = toFilePath $ dir ident'
-- TODO consideration for the future: list all of the executables
-- installed, and invalidate this file in getInstalledExes if they no
-- longer exist
liftIO $ writeFile fp "Installed"
-- | Mark the given executable as not installed
markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeNotInstalled loc ident = do
dir <- exeInstalledDir loc
ident' <- parseRelFile $ packageIdentifierString ident
removeFileIfExists (dir ident')
-- | Stored on disk to know whether the flags have changed or any
-- files have changed.
data BuildCache = BuildCache
{ buildCacheTimes :: !(Map FilePath FileCacheInfo)
-- ^ Modification times of files.
}
deriving (Generic)
instance Binary BuildCache
instance HasStructuralInfo BuildCache
instance HasSemanticVersion BuildCache
instance NFData BuildCache
-- | Try to read the dirtiness cache for the given package directory.
tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile
-- | Try to read the dirtiness cache for the given package directory.
tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe ConfigCache)
tryGetConfigCache = tryGetCache configCacheFile
-- | Try to read the mod time of the cabal file from the last build
tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe ModTime)
tryGetCabalMod = tryGetCache configCabalMod
-- | Try to load a cache.
tryGetCache :: (MonadIO m, BinarySchema a)
=> (Path Abs Dir -> m (Path Abs File))
-> Path Abs Dir
-> m (Maybe a)
tryGetCache get' dir = do
fp <- get' dir
decodeFileOrFailDeep fp
-- | Write the dirtiness cache for this package's files.
writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
writeBuildCache dir times =
writeCache
dir
buildCacheFile
BuildCache
{ buildCacheTimes = times
}
-- | Write the dirtiness cache for this package's configuration.
writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir
-> ConfigCache
-> m ()
writeConfigCache dir = writeCache dir configCacheFile
-- | See 'tryGetCabalMod'
writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir
-> ModTime
-> m ()
writeCabalMod dir = writeCache dir configCabalMod
-- | Delete the caches for the project.
deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)
=> Path Abs Dir -> m ()
deleteCaches dir = do
{- FIXME confirm that this is acceptable to remove
bfp <- buildCacheFile dir
removeFileIfExists bfp
-}
cfp <- configCacheFile dir
removeFileIfExists cfp
-- | Write to a cache.
writeCache :: (BinarySchema a, MonadIO m)
=> Path Abs Dir
-> (Path Abs Dir -> m (Path Abs File))
-> a
-> m ()
writeCache dir get' content = do
fp <- get' dir
taggedEncodeFile fp content
flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
-> m (Path Abs File)
flagCacheFile installed = do
rel <- parseRelFile $
case installed of
Library _ gid -> ghcPkgIdString gid
Executable ident -> packageIdentifierString ident
dir <- flagCacheLocal
return $ dir rel
-- | Loads the flag cache for the given installed extra-deps
tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
-> m (Maybe ConfigCache)
tryGetFlagCache gid = do
fp <- flagCacheFile gid
decodeFileOrFailDeep fp
writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> Installed
-> ConfigCache
-> m ()
writeFlagCache gid cache = do
file <- flagCacheFile gid
liftIO $ do
createTree (parent file)
taggedEncodeFile file cache
-- | Mark a test suite as having succeeded
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setTestSuccess dir =
writeCache
dir
testSuccessFile
True
-- | Mark a test suite as not having succeeded
unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetTestSuccess dir =
writeCache
dir
testSuccessFile
False
-- | Check if the test suite already passed
checkTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkTestSuccess dir =
liftM
(fromMaybe False)
(tryGetCache testSuccessFile dir)
--------------------------------------
-- Precompiled Cache
--
-- Idea is simple: cache information about packages built in other snapshots,
-- and then for identical matches (same flags, config options, dependencies)
-- just copy over the executables and reregister the libraries.
--------------------------------------
-- | The file containing information on the given package/configuration
-- combination. The filename contains a hash of the non-directory configure
-- options for quick lookup if there's a match.
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId -- ^ dependencies
-> m (Path Abs File)
precompiledCacheFile pkgident copts installedPackageIDs = do
ec <- asks getEnvConfig
compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec
cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec
pkg <- parseRelDir $ packageIdentifierString pkgident
-- In Cabal versions 1.22 and later, the configure options contain the
-- installed package IDs, which is what we need for a unique hash.
-- Unfortunately, earlier Cabals don't have the information, so we must
-- supplement it with the installed package IDs directly. In 20/20
-- hindsight, we would simply always do that, but previous Stack releases
-- used only the options, and we don't want to invalidate old caches
-- unnecessarily.
--
-- See issue: https://github.com/commercialhaskell/stack/issues/1103
let cacheInput
| envConfigCabalVersion ec >= $(mkVersion "1.22") =
Binary.encode $ coNoDirs copts
| otherwise =
Binary.encode
( coNoDirs copts
, installedPackageIDs
)
-- We only pay attention to non-directory options. We don't want to avoid a
-- cache hit just because it was installed in a different directory.
copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy cacheInput
return $ getStackRoot ec
$(mkRelDir "precompiled")
compiler
cabal
pkg
copts'
-- | Write out information about a newly built package
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> BaseConfigOpts
-> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId -- ^ dependencies
-> Installed -- ^ library
-> Set Text -- ^ executables
-> m ()
writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
file <- precompiledCacheFile pkgident copts depIDs
createTree $ parent file
mlibpath <-
case mghcPkgId of
Executable _ -> return Nothing
Library _ ipid -> liftM Just $ do
ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
return $ toFilePath $ bcoSnapDB baseConfigOpts ipid'
exes' <- forM (Set.toList exes) $ \exe -> do
name <- parseRelFile $ T.unpack exe
return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name
liftIO $ taggedEncodeFile file PrecompiledCache
{ pcLibrary = mlibpath
, pcExes = exes'
}
-- | Check the cache for a precompiled package matching the given
-- configuration.
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> PackageIdentifier -- ^ target package
-> ConfigureOpts
-> Set GhcPkgId -- ^ dependencies
-> m (Maybe PrecompiledCache)
readPrecompiledCache pkgident copts depIDs = do
file <- precompiledCacheFile pkgident copts depIDs
decodeFileOrFailDeep file
stack-0.1.10.0/src/Stack/Build/ConstructPlan.hs 0000644 0000000 0000000 00000067051 12630352213 017256 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- | Construct a @Plan@ for how to build
module Stack.Build.ConstructPlan
( constructPlan
) where
import Control.Arrow ((&&&), second)
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger, logWarn)
import Control.Monad.RWS.Strict
import Control.Monad.Trans.Resource
import qualified Data.ByteString.Char8 as S8
import Data.Either
import Data.Function
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Distribution.Package (Dependency (..))
import Distribution.Version (anyVersion)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Prelude hiding (pi, writeFile)
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Types.Build
import Stack.BuildPlan
import Stack.Package
import Stack.PackageDump
import Stack.Types
data PackageInfo
= PIOnlyInstalled InstallLocation Installed
| PIOnlySource PackageSource
| PIBoth PackageSource Installed
combineSourceInstalled :: PackageSource
-> (InstallLocation, Installed)
-> PackageInfo
combineSourceInstalled ps (location, installed) =
assert (piiVersion ps == installedVersion installed) $
assert (piiLocation ps == location) $
case location of
-- Always trust something in the snapshot
Snap -> PIOnlyInstalled location installed
Local -> PIBoth ps installed
type CombinedMap = Map PackageName PackageInfo
combineMap :: SourceMap -> InstalledMap -> CombinedMap
combineMap = Map.mergeWithKey
(\_ s i -> Just $ combineSourceInstalled s i)
(fmap PIOnlySource)
(fmap (uncurry PIOnlyInstalled))
data AddDepRes
= ADRToInstall Task
| ADRFound InstallLocation Installed
deriving Show
data W = W
{ wFinals :: !(Map PackageName (Either ConstructPlanException Task))
, wInstall :: !(Map Text InstallLocation)
-- ^ executable to be installed, and location where the binary is placed
, wDirty :: !(Map PackageName Text)
-- ^ why a local package is considered dirty
, wDeps :: !(Set PackageName)
-- ^ Packages which count as dependencies
, wWarnings :: !([Text] -> [Text])
-- ^ Warnings
}
instance Monoid W where
mempty = W mempty mempty mempty mempty mempty
mappend (W a b c d e) (W w x y z z') = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) (mappend e z')
type M = RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
data Ctx = Ctx
{ mbp :: !MiniBuildPlan
, baseConfigOpts :: !BaseConfigOpts
, loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)
, combinedMap :: !CombinedMap
, toolToPackages :: !(Dependency -> Map PackageName VersionRange)
, ctxEnvConfig :: !EnvConfig
, callStack :: ![PackageName]
, extraToBuild :: !(Set PackageName)
, ctxVersions :: !(Map PackageName (Set Version))
, wanted :: !(Set PackageName)
, localNames :: !(Set PackageName)
}
instance HasStackRoot Ctx
instance HasPlatform Ctx
instance HasGHCVariant Ctx
instance HasConfig Ctx
instance HasBuildConfig Ctx where
getBuildConfig = getBuildConfig . getEnvConfig
instance HasEnvConfig Ctx where
getEnvConfig = ctxEnvConfig
constructPlan :: forall env m.
(MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env)
=> MiniBuildPlan
-> BaseConfigOpts
-> [LocalPackage]
-> Set PackageName -- ^ additional packages that must be built
-> [DumpPackage () ()] -- ^ locally registered
-> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package
-> SourceMap
-> InstalledMap
-> m Plan
constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do
let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs
bconfig <- asks getBuildConfig
let versions =
Map.fromListWith Set.union $
map (second Set.singleton . toTuple) $
Map.keys (bcPackageCaches bconfig)
econfig <- asks getEnvConfig
let onWanted = void . addDep False . packageName . lpPackage
let inner = do
mapM_ onWanted $ filter lpWanted locals
mapM_ (addDep False) $ Set.toList extraToBuild0
((), m, W efinals installExes dirtyReason deps warnings) <-
liftIO $ runRWST inner (ctx econfig versions) M.empty
mapM_ $logWarn (warnings [])
let toEither (_, Left e) = Left e
toEither (k, Right v) = Right (k, v)
(errlibs, adrs) = partitionEithers $ map toEither $ M.toList m
(errfinals, finals) = partitionEithers $ map toEither $ M.toList efinals
errs = errlibs ++ errfinals
if null errs
then do
let toTask (_, ADRFound _ _) = Nothing
toTask (name, ADRToInstall task) = Just (name, task)
tasks = M.fromList $ mapMaybe toTask adrs
takeSubset =
case boptsBuildSubset $ bcoBuildOpts baseConfigOpts0 of
BSAll -> id
BSOnlySnapshot -> stripLocals
BSOnlyDependencies -> stripNonDeps deps
return $ takeSubset Plan
{ planTasks = tasks
, planFinals = M.fromList finals
, planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap
, planInstallExes =
if boptsInstallExes $ bcoBuildOpts baseConfigOpts0
then installExes
else Map.empty
}
else throwM $ ConstructPlanExceptions errs (bcStackYaml $ getBuildConfig econfig)
where
ctx econfig versions = Ctx
{ mbp = mbp0
, baseConfigOpts = baseConfigOpts0
, loadPackage = loadPackage0
, combinedMap = combineMap sourceMap installedMap
, toolToPackages = \ (Dependency name _) ->
maybe Map.empty (Map.fromSet (const anyVersion)) $
Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap
, ctxEnvConfig = econfig
, callStack = []
, extraToBuild = extraToBuild0
, ctxVersions = versions
, wanted = wantedLocalPackages locals
, localNames = Set.fromList $ map (packageName . lpPackage) locals
}
-- TODO Currently, this will only consider and install tools from the
-- snapshot. It will not automatically install build tools from extra-deps
-- or local packages.
toolMap = getToolMap mbp0
-- | Determine which packages to unregister based on the given tasks and
-- already registered local packages
mkUnregisterLocal :: Map PackageName Task
-> Map PackageName Text
-> Map GhcPkgId PackageIdentifier
-> SourceMap
-> Map GhcPkgId (PackageIdentifier, Maybe Text)
mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
Map.unions $ map toUnregisterMap $ Map.toList locallyRegistered
where
toUnregisterMap (gid, ident) =
case M.lookup name tasks of
Nothing ->
case M.lookup name sourceMap of
Just (PSUpstream _ Snap _) -> Map.singleton gid
( ident
, Just "Switching to snapshot installed package"
)
_ -> Map.empty
Just _ -> Map.singleton gid
( ident
, Map.lookup name dirtyReason
)
where
name = packageIdentifierName ident
addFinal :: LocalPackage -> Package -> Bool -> M ()
addFinal lp package isAllInOne = do
depsRes <- addPackageDeps False package
res <- case depsRes of
Left e -> return $ Left e
Right (missing, present, _minLoc) -> do
ctx <- ask
return $ Right Task
{ taskProvides = PackageIdentifier
(packageName package)
(packageVersion package)
, taskConfigOpts = TaskConfigOpts missing $ \missing' ->
let allDeps = Map.union present missing'
in configureOpts
(getEnvConfig ctx)
(baseConfigOpts ctx)
allDeps
True -- wanted
True -- local
Local
package
, taskPresent = present
, taskType = TTLocal lp
, taskAllInOne = isAllInOne
}
tell mempty { wFinals = Map.singleton (packageName package) res }
addDep :: Bool -- ^ is this being used by a dependency?
-> PackageName
-> M (Either ConstructPlanException AddDepRes)
addDep treatAsDep' name = do
ctx <- ask
let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx
when treatAsDep $ markAsDep name
m <- get
case Map.lookup name m of
Just res -> return res
Nothing -> do
res <- if name `elem` callStack ctx
then return $ Left $ DependencyCycleDetected $ name : callStack ctx
else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $
case Map.lookup name $ combinedMap ctx of
-- TODO look up in the package index and see if there's a
-- recommendation available
Nothing -> return $ Left $ UnknownPackage name
Just (PIOnlyInstalled loc installed) -> do
-- slightly hacky, no flags since they likely won't affect executable names
tellExecutablesUpstream name (installedVersion installed) loc Map.empty
return $ Right $ ADRFound loc installed
Just (PIOnlySource ps) -> do
tellExecutables name ps
installPackage treatAsDep name ps Nothing
Just (PIBoth ps installed) -> do
tellExecutables name ps
installPackage treatAsDep name ps (Just installed)
modify $ Map.insert name res
return res
tellExecutables :: PackageName -> PackageSource -> M ()
tellExecutables _ (PSLocal lp)
| lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
| otherwise = return ()
tellExecutables name (PSUpstream version loc flags) =
tellExecutablesUpstream name version loc flags
tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M ()
tellExecutablesUpstream name version loc flags = do
ctx <- ask
when (name `Set.member` extraToBuild ctx) $ do
p <- liftIO $ loadPackage ctx name version flags
tellExecutablesPackage loc p
tellExecutablesPackage :: InstallLocation -> Package -> M ()
tellExecutablesPackage loc p = do
cm <- asks combinedMap
-- Determine which components are enabled so we know which ones to copy
let myComps =
case Map.lookup (packageName p) cm of
Nothing -> assert False Set.empty
Just (PIOnlyInstalled _ _) -> Set.empty
Just (PIOnlySource ps) -> goSource ps
Just (PIBoth ps _) -> goSource ps
goSource (PSLocal lp)
| lpWanted lp = exeComponents (lpComponents lp)
| otherwise = Set.empty
goSource (PSUpstream{}) = Set.empty
tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p }
where
filterComps myComps x
| Set.null myComps = x
| otherwise = Set.intersection x myComps
installPackage :: Bool -- ^ is this being used by a dependency?
-> PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage treatAsDep name ps minstalled = do
ctx <- ask
case ps of
PSUpstream version _ flags -> do
package <- liftIO $ loadPackage ctx name version flags
resolveDepsAndInstall False treatAsDep ps package minstalled
PSLocal lp ->
case lpTestBench lp of
Nothing -> resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled
Just tb -> do
-- Attempt to find a plan which performs an all-in-one
-- build. Ignore the writer action + reset the state if
-- it fails.
s <- get
res <- pass $ do
res <- addPackageDeps treatAsDep tb
let writerFunc w = case res of
Left _ -> mempty
_ -> w
return (res, writerFunc)
case res of
Right deps -> do
adr <- installPackageGivenDeps True ps tb minstalled deps
-- FIXME: this redundantly adds the deps (but
-- they'll all just get looked up in the map)
addFinal lp tb True
return $ Right adr
Left _ -> do
-- Reset the state to how it was before
-- attempting to find an all-in-one build
-- plan.
put s
-- Otherwise, fall back on building the
-- tests / benchmarks in a separate step.
res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled
when (isRight res') $ do
-- Insert it into the map so that it's
-- available for addFinal.
modify $ Map.insert name res'
addFinal lp tb False
return res'
resolveDepsAndInstall :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall isAllInOne treatAsDep ps package minstalled = do
res <- addPackageDeps treatAsDep package
case res of
Left err -> return $ Left err
Right deps -> liftM Right $ installPackageGivenDeps isAllInOne ps package minstalled deps
installPackageGivenDeps :: Bool
-> PackageSource
-> Package
-> Maybe Installed
-> ( Set PackageIdentifier
, Map PackageIdentifier GhcPkgId
, InstallLocation )
-> M AddDepRes
installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minLoc) = do
let name = packageName package
ctx <- ask
mRightVersionInstalled <- case (minstalled, Set.null missing) of
(Just installed, True) -> do
shouldInstall <- checkDirtiness ps installed package present (wanted ctx)
return $ if shouldInstall then Nothing else Just installed
(Just _, False) -> do
let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing)
tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t }
return Nothing
(Nothing, _) -> return Nothing
return $ case mRightVersionInstalled of
Just installed -> ADRFound (piiLocation ps) installed
Nothing -> ADRToInstall Task
{ taskProvides = PackageIdentifier
(packageName package)
(packageVersion package)
, taskConfigOpts = TaskConfigOpts missing $ \missing' ->
let allDeps = Map.union present missing'
destLoc = piiLocation ps <> minLoc
in configureOpts
(getEnvConfig ctx)
(baseConfigOpts ctx)
allDeps
(psWanted ps)
(psLocal ps)
-- An assertion to check for a recurrence of
-- https://github.com/commercialhaskell/stack/issues/345
(assert (destLoc == piiLocation ps) destLoc)
package
, taskPresent = present
, taskType =
case ps of
PSLocal lp -> TTLocal lp
PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc
, taskAllInOne = isAllInOne
}
addEllipsis :: Text -> Text
addEllipsis t
| T.length t < 100 = t
| otherwise = T.take 97 t <> "..."
addPackageDeps :: Bool -- ^ is this being used by a dependency?
-> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation))
addPackageDeps treatAsDep package = do
ctx <- ask
deps' <- packageDepsWithTools package
deps <- forM (Map.toList deps') $ \(depname, range) -> do
eres <- addDep treatAsDep depname
let mlatestApplicable =
(latestApplicableVersion range <=< Map.lookup depname) (ctxVersions ctx)
case eres of
Left e ->
let bd =
case e of
UnknownPackage name -> assert (name == depname) NotInBuildPlan
_ -> Couldn'tResolveItsDependencies
in return $ Left (depname, (range, mlatestApplicable, bd))
Right adr -> do
inRange <- if adrVersion adr `withinRange` range
then return True
else do
let warn reason =
tell mempty { wWarnings = (msg:) }
where
msg = T.concat
[ "WARNING: Ignoring out of range dependency"
, reason
, ": "
, T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr)
, ". "
, T.pack $ packageNameString $ packageName package
, " requires: "
, versionRangeText range
]
allowNewer <- asks $ configAllowNewer . getConfig
if allowNewer
then do
warn " (allow-newer enabled)"
return True
else do
x <- inSnapshot (packageName package) (packageVersion package)
y <- inSnapshot depname (adrVersion adr)
if x && y
then do
warn " (trusting snapshot over Hackage revisions)"
return True
else return False
if inRange
then case adr of
ADRToInstall task -> return $ Right
(Set.singleton $ taskProvides task, Map.empty, taskLocation task)
ADRFound loc (Executable _) -> return $ Right
(Set.empty, Map.empty, loc)
ADRFound loc (Library ident gid) -> return $ Right
(Set.empty, Map.singleton ident gid, loc)
else return $ Left (depname, (range, mlatestApplicable, DependencyMismatch $ adrVersion adr))
case partitionEithers deps of
([], pairs) -> return $ Right $ mconcat pairs
(errs, _) -> return $ Left $ DependencyPlanFailures
(PackageIdentifier
(packageName package)
(packageVersion package))
(Map.fromList errs)
where
adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task
adrVersion (ADRFound _ installed) = installedVersion installed
checkDirtiness :: PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Set PackageName
-> M Bool
checkDirtiness ps installed package present wanted = do
ctx <- ask
moldOpts <- tryGetFlagCache installed
let configOpts = configureOpts
(getEnvConfig ctx)
(baseConfigOpts ctx)
present
(psWanted ps)
(psLocal ps)
(piiLocation ps) -- should be Local always
package
buildOpts = bcoBuildOpts (baseConfigOpts ctx)
wantConfigCache = ConfigCache
{ configCacheOpts = configOpts
, configCacheDeps = Set.fromList $ Map.elems present
, configCacheComponents =
case ps of
PSLocal lp -> Set.map renderComponent $ lpComponents lp
PSUpstream{} -> Set.empty
, configCacheHaddock =
shouldHaddockPackage buildOpts wanted (packageName package) ||
-- Disabling haddocks when old config had haddocks doesn't make dirty.
maybe False configCacheHaddock moldOpts
}
let mreason =
case moldOpts of
Nothing -> Just "old configure information not found"
Just oldOpts
| Just reason <- describeConfigDiff config oldOpts wantConfigCache -> Just reason
| Just files <- psDirty ps -> Just $ "local file changes: " <>
addEllipsis (T.pack $ unwords $ Set.toList files)
| otherwise -> Nothing
config = getConfig ctx
case mreason of
Nothing -> return False
Just reason -> do
tell mempty { wDirty = Map.singleton (packageName package) reason }
return True
describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff config old new
| not (configCacheDeps new `Set.isSubsetOf` configCacheDeps old) = Just "dependencies changed"
| not $ Set.null newComponents =
Just $ "components added: " `T.append` T.intercalate ", "
(map (decodeUtf8With lenientDecode) (Set.toList newComponents))
| not (configCacheHaddock old) && configCacheHaddock new = Just "rebuilding with haddocks"
| oldOpts /= newOpts = Just $ T.pack $ concat
[ "flags changed from "
, show oldOpts
, " to "
, show newOpts
]
| otherwise = Nothing
where
-- options set by stack
isStackOpt t = any (`T.isPrefixOf` t)
[ "--dependency="
, "--constraint="
, "--package-db="
, "--libdir="
, "--bindir="
, "--datadir="
, "--libexecdir="
, "--sysconfdir"
, "--docdir="
, "--htmldir="
, "--haddockdir="
, "--enable-tests"
, "--enable-benchmarks"
] || elem t
[ "--user"
]
stripGhcOptions =
go
where
go [] = []
go ("--ghc-option":x:xs) = go' x xs
go ("--ghc-options":x:xs) = go' x xs
go ((T.stripPrefix "--ghc-option=" -> Just x):xs) = go' x xs
go ((T.stripPrefix "--ghc-options=" -> Just x):xs) = go' x xs
go (x:xs) = x : go xs
go' x xs = checkKeepers x $ go xs
checkKeepers x xs =
case filter isKeeper $ T.words x of
[] -> xs
keepers -> "--ghc-options" : T.unwords keepers : xs
-- GHC options which affect build results and therefore should always
-- force a rebuild
--
-- For the most part, we only care about options generated by Stack
-- itself
isKeeper = (== "-fhpc") -- more to be added later
userOpts = filter (not . isStackOpt)
. (if configRebuildGhcOptions config
then id
else stripGhcOptions)
. map T.pack
. (\(ConfigureOpts x y) -> x ++ y)
. configCacheOpts
(oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new)
removeMatching (x:xs) (y:ys)
| x == y = removeMatching xs ys
removeMatching xs ys = (xs, ys)
newComponents = configCacheComponents new `Set.difference` configCacheComponents old
psDirty :: PackageSource -> Maybe (Set FilePath)
psDirty (PSLocal lp) = lpDirtyFiles lp
psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package
psWanted :: PackageSource -> Bool
psWanted (PSLocal lp) = lpWanted lp
psWanted (PSUpstream {}) = False
psLocal :: PackageSource -> Bool
psLocal (PSLocal _) = True
psLocal (PSUpstream {}) = False
-- | Get all of the dependencies for a given package, including guessed build
-- tool dependencies.
packageDepsWithTools :: Package -> M (Map PackageName VersionRange)
packageDepsWithTools p = do
ctx <- ask
return $ Map.unionsWith intersectVersionRanges
$ packageDeps p
: map (toolToPackages ctx) (packageTools p)
-- | Strip out anything from the @Plan@ intended for the local database
stripLocals :: Plan -> Plan
stripLocals plan = plan
{ planTasks = Map.filter checkTask $ planTasks plan
, planFinals = Map.empty
, planUnregisterLocal = Map.empty
, planInstallExes = Map.filter (/= Local) $ planInstallExes plan
}
where
checkTask task =
case taskType task of
TTLocal _ -> False
TTUpstream _ Local -> False
TTUpstream _ Snap -> True
stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps deps plan = plan
{ planTasks = Map.filter checkTask $ planTasks plan
, planFinals = Map.empty
, planInstallExes = Map.empty -- TODO maybe don't disable this?
}
where
checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps
markAsDep :: PackageName -> M ()
markAsDep name = tell mempty { wDeps = Set.singleton name }
-- | Is the given package/version combo defined in the snapshot?
inSnapshot :: PackageName -> Version -> M Bool
inSnapshot name version = do
p <- asks mbp
ls <- asks localNames
return $ fromMaybe False $ do
guard $ not $ name `Set.member` ls
mpi <- Map.lookup name (mbpPackages p)
return $ mpiVersion mpi == version
stack-0.1.10.0/src/Stack/Build/Execute.hs 0000644 0000000 0000000 00000201724 12630352213 016056 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Perform a build
module Stack.Build.Execute
( printPlan
, preFetch
, executePlan
-- * Running Setup.hs
, ExecuteEnv
, withExecuteEnv
, withSingleContext
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent.Async (withAsync, wait)
import Control.Concurrent.Execute
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.STM
import Control.Exception.Enclosed (catchIO, tryIO)
import Control.Exception.Lifted
import Control.Monad (liftM, when, unless, void, join, guard, filterM, (<=<))
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (liftBaseWith)
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Foldable (forM_, any)
import Data.Function
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (any)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (forMaybeM)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Streaming.Process as Process
import Data.Streaming.Process hiding (callProcess, env)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Data.Traversable (forM)
import Data.Word8 (_colon)
import qualified Distribution.PackageDescription as C
import Distribution.System (OS (Windows),
Platform (Platform))
import Language.Haskell.TH as TH (location)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Prelude hiding (FilePath, writeFile, any)
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Constants
import Stack.Coverage
import Stack.Fetch as Fetch
import Stack.GhcPkg
import Stack.Package
import Stack.PackageDump
import Stack.Types
import Stack.Types.Internal
import Stack.Types.StackT
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import qualified System.FilePath as FP
import System.IO
import System.PosixCompat.Files (createLink)
import System.Process.Log (showProcessArgDebug)
import System.Process.Read
import System.Process.Run
#if !MIN_VERSION_process(1,2,1)
import System.Process.Internals (createProcess_)
#endif
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)
-- | Fetch the packages necessary for a build, for example in combination with a dry run.
preFetch :: M env m => Plan -> m ()
preFetch plan
| Set.null idents = $logDebug "Nothing to fetch"
| otherwise = do
$logDebug $ T.pack $
"Prefetching: " ++
intercalate ", " (map packageIdentifierString $ Set.toList idents)
menv <- getMinimalEnvOverride
fetchPackages menv idents
where
idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan
toIdent (name, task) =
case taskType task of
TTLocal _ -> Set.empty
TTUpstream package _ -> Set.singleton $ PackageIdentifier
name
(packageVersion package)
-- | Print a description of build plan for human consumption.
printPlan :: M env m
=> Plan
-> m ()
printPlan plan = do
case Map.elems $ planUnregisterLocal plan of
[] -> $logInfo "No packages would be unregistered."
xs -> do
$logInfo "Would unregister locally:"
forM_ xs $ \(ident, mreason) -> $logInfo $ T.concat
[ T.pack $ packageIdentifierString ident
, case mreason of
Nothing -> ""
Just reason -> T.concat
[ " ("
, reason
, ")"
]
]
$logInfo ""
case Map.elems $ planTasks plan of
[] -> $logInfo "Nothing to build."
xs -> do
$logInfo "Would build:"
mapM_ ($logInfo . displayTask) xs
let hasTests = not . Set.null . testComponents . taskComponents
hasBenches = not . Set.null . benchComponents . taskComponents
tests = Map.elems $ Map.filter hasTests $ planFinals plan
benches = Map.elems $ Map.filter hasBenches $ planFinals plan
unless (null tests) $ do
$logInfo ""
$logInfo "Would test:"
mapM_ ($logInfo . displayTask) tests
unless (null benches) $ do
$logInfo ""
$logInfo "Would benchmark:"
mapM_ ($logInfo . displayTask) benches
$logInfo ""
case Map.toList $ planInstallExes plan of
[] -> $logInfo "No executables to be installed."
xs -> do
$logInfo "Would install executables:"
forM_ xs $ \(name, loc) -> $logInfo $ T.concat
[ name
, " from "
, case loc of
Snap -> "snapshot"
Local -> "local"
, " database"
]
-- | For a dry run
displayTask :: Task -> Text
displayTask task = T.pack $ concat
[ packageIdentifierString $ taskProvides task
, ": database="
, case taskLocation task of
Snap -> "snapshot"
Local -> "local"
, ", source="
, case taskType task of
TTLocal lp -> concat
[ toFilePath $ lpDir lp
]
TTUpstream _ _ -> "package index"
, if Set.null missing
then ""
else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)
]
where
missing = tcoMissing $ taskConfigOpts task
data ExecuteEnv = ExecuteEnv
{ eeEnvOverride :: !EnvOverride
, eeConfigureLock :: !(MVar ())
, eeInstallLock :: !(MVar ())
, eeBuildOpts :: !BuildOpts
, eeBaseConfigOpts :: !BaseConfigOpts
, eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed))
, eeTempDir :: !(Path Abs Dir)
, eeSetupHs :: !(Path Abs File)
-- ^ Temporary Setup.hs for simple builds
, eeSetupExe :: !(Maybe (Path Abs File))
-- ^ Compiled version of eeSetupHs
, eeCabalPkgVer :: !Version
, eeTotalWanted :: !Int
, eeWanted :: !(Set PackageName)
, eeLocals :: ![LocalPackage]
, eeGlobalDB :: !(Path Abs Dir)
, eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ()))
, eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))
, eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))
}
-- | Get a compiled Setup exe
getSetupExe :: M env m
=> Path Abs File -- ^ Setup.hs input file
-> Path Abs Dir -- ^ temporary directory
-> m (Maybe (Path Abs File))
getSetupExe setupHs tmpdir = do
wc <- getWhichCompiler
econfig <- asks getEnvConfig
platformDir <- platformVariantRelDir
let config = getConfig econfig
baseNameS = concat
[ "setup-Simple-Cabal-"
, versionString $ envConfigCabalVersion econfig
, "-"
, compilerVersionString $ envConfigCompilerVersion econfig
]
exeNameS = baseNameS ++
case configPlatform config of
Platform _ Windows -> ".exe"
_ -> ""
outputNameS =
case wc of
Ghc -> exeNameS
Ghcjs -> baseNameS ++ ".jsexe"
jsExeNameS =
baseNameS ++ ".jsexe"
setupDir =
configStackRoot config
$(mkRelDir "setup-exe-cache")
platformDir
exePath <- fmap (setupDir ) $ parseRelFile exeNameS
jsExePath <- fmap (setupDir ) $ parseRelDir jsExeNameS
exists <- liftIO $ D.doesFileExist $ toFilePath exePath
if exists
then return $ Just exePath
else do
tmpExePath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ exeNameS
tmpOutputPath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ outputNameS
tmpJsExePath <- fmap (setupDir ) $ parseRelDir $ "tmp-" ++ jsExeNameS
liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir
menv <- getMinimalEnvOverride
let args =
[ "-clear-package-db"
, "-global-package-db"
, "-hide-all-packages"
, "-package"
, "base"
, "-package"
, "Cabal-" ++ versionString (envConfigCabalVersion econfig)
, toFilePath setupHs
, "-o"
, toFilePath tmpOutputPath
] ++
["-build-runner" | wc == Ghcjs]
runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing
when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath
renameFile tmpExePath exePath
return $ Just exePath
-- | Execute a callback that takes an 'ExecuteEnv'.
withExecuteEnv :: M env m
=> EnvOverride
-> BuildOpts
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage () ()] -- ^ global packages
-> [DumpPackage () ()] -- ^ snapshot packages
-> [DumpPackage () ()] -- ^ local packages
-> (ExecuteEnv -> m a)
-> m a
withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do
withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do
configLock <- newMVar ()
installLock <- newMVar ()
idMap <- liftIO $ newTVarIO Map.empty
let setupHs = tmpdir $(mkRelFile "Setup.hs")
liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
setupExe <- getSetupExe setupHs tmpdir
cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
globalDB <- getGlobalDB menv =<< getWhichCompiler
snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
inner ExecuteEnv
{ eeEnvOverride = menv
, eeBuildOpts = bopts
-- Uncertain as to why we cannot run configures in parallel. This appears
-- to be a Cabal library bug. Original issue:
-- https://github.com/fpco/stack/issues/84. Ideally we'd be able to remove
-- this.
, eeConfigureLock = configLock
, eeInstallLock = installLock
, eeBaseConfigOpts = baseConfigOpts
, eeGhcPkgIds = idMap
, eeTempDir = tmpdir
, eeSetupHs = setupHs
, eeSetupExe = setupExe
, eeCabalPkgVer = cabalPkgVer
, eeTotalWanted = length $ filter lpWanted locals
, eeWanted = wantedLocalPackages locals
, eeLocals = locals
, eeGlobalDB = globalDB
, eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages
, eeSnapshotDumpPkgs = snapshotPackagesTVar
, eeLocalDumpPkgs = localPackagesTVar
}
where
toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
-- | Perform the actual plan
executePlan :: M env m
=> EnvOverride
-> BuildOpts
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage () ()] -- ^ global packages
-> [DumpPackage () ()] -- ^ snapshot packages
-> [DumpPackage () ()] -- ^ local packages
-> InstalledMap
-> Plan
-> m ()
executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap plan = do
withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap plan)
unless (Map.null $ planInstallExes plan) $ do
snapBin <- ( bindirSuffix) `liftM` installationRootDeps
localBin <- ( bindirSuffix) `liftM` installationRootLocal
destDir <- asks $ configLocalBin . getConfig
createTree destDir
destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
isInPATH <- liftIO . fmap (any (FP.equalFilePath destDir')) . (mapM D.canonicalizePath <=< filterM D.doesDirectoryExist) $ (envSearchPath menv)
when (not isInPATH) $
$logWarn $ T.concat
[ "Installation path "
, T.pack destDir'
, " not found in PATH environment variable"
]
platform <- asks getPlatform
let ext =
case platform of
Platform _ Windows -> ".exe"
_ -> ""
currExe <- liftIO getExecutablePath -- needed for windows, see below
installed <- forMaybeM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do
let bindir =
case loc of
Snap -> snapBin
Local -> localBin
mfp <- resolveFileMaybe bindir $ T.unpack name ++ ext
case mfp of
Nothing -> do
$logWarn $ T.concat
[ "Couldn't find executable "
, name
, " in directory "
, T.pack $ toFilePath bindir
]
return Nothing
Just file -> do
let destFile = destDir' FP. T.unpack name ++ ext
$logInfo $ T.concat
[ "Copying from "
, T.pack $ toFilePath file
, " to "
, T.pack destFile
]
liftIO $ case platform of
Platform _ Windows | FP.equalFilePath destFile currExe ->
windowsRenameCopy (toFilePath file) destFile
_ -> D.copyFile (toFilePath file) destFile
return $ Just (destDir', [T.append name (T.pack ext)])
let destToInstalled = Map.fromListWith (++) installed
unless (Map.null destToInstalled) $ $logInfo ""
forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do
$logInfo $ T.concat
[ "Copied executables to "
, T.pack dest
, ":"]
forM_ executables $ \exe -> $logInfo $ T.append "- " exe
config <- asks getConfig
menv' <- liftIO $ configEnvOverride config EnvSettings
{ esIncludeLocals = True
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
}
forM_ (boptsExec bopts) $ \(cmd, args) -> do
$logProcessRun cmd args
callProcess (Cmd Nothing cmd menv' args)
-- | Windows can't write over the current executable. Instead, we rename the
-- current executable to something else and then do the copy.
windowsRenameCopy :: FilePath -> FilePath -> IO ()
windowsRenameCopy src dest = do
D.copyFile src new
D.renameFile dest old
D.renameFile new dest
where
new = dest ++ ".new"
old = dest ++ ".old"
-- | Perform the actual plan (internal)
executePlan' :: M env m
=> InstalledMap
-> Plan
-> ExecuteEnv
-> m ()
executePlan' installedMap0 plan ee@ExecuteEnv {..} = do
when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports
wc <- getWhichCompiler
cv <- asks $ envConfigCompilerVersion . getEnvConfig
case Map.toList $ planUnregisterLocal plan of
[] -> return ()
ids -> do
localDB <- packageDatabaseLocal
forM_ ids $ \(id', (ident, mreason)) -> do
$logInfo $ T.concat
[ T.pack $ packageIdentifierString ident
, ": unregistering"
, case mreason of
Nothing -> ""
Just reason -> T.concat
[ " ("
, reason
, ")"
]
]
unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident
liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->
foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)
-- Yes, we're explicitly discarding result values, which in general would
-- be bad. monad-unlift does this all properly at the type system level,
-- but I don't want to pull it in for this one use case, when we know that
-- stack always using transformer stacks that are safe for this use case.
runInBase <- liftBaseWith $ \run -> return (void . run)
let actions = concatMap (toActions installedMap' runInBase ee) $ Map.elems $ Map.mergeWithKey
(\_ b f -> Just (Just b, Just f))
(fmap (\b -> (Just b, Nothing)))
(fmap (\f -> (Nothing, Just f)))
(planTasks plan)
(planFinals plan)
threads <- asks $ configJobs . getConfig
concurrentTests <- asks $ configConcurrentTests . getConfig
let keepGoing =
case boptsKeepGoing eeBuildOpts of
Just kg -> kg
Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts
concurrentFinal =
-- TODO it probably makes more sense to use a lock for test suites
-- and just have the execution blocked. Turning off all concurrency
-- on finals based on the --test option doesn't fit in well.
if boptsTests eeBuildOpts
then concurrentTests
else True
terminal <- asks getTerminal
errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
let total = length actions
loop prev
| prev == total =
runInBase $ $logStickyDone ("Completed all " <> T.pack (show total) <> " actions.")
| otherwise = do
when terminal $ runInBase $
$logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))
done <- atomically $ do
done <- readTVar doneVar
check $ done /= prev
return done
loop done
if total > 1
then loop 0
else return ()
when (toCoverage $ boptsTestOpts eeBuildOpts) $ do
generateHpcUnifiedReport
generateHpcMarkupIndex
unless (null errs) $ throwM $ ExecutionFailure errs
when (boptsHaddock eeBuildOpts) $ do
snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)
localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)
generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals
generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals
generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs
where
installedMap' = Map.difference installedMap0
$ Map.fromList
$ map (\(ident, _) -> (packageIdentifierName ident, ()))
$ Map.elems
$ planUnregisterLocal plan
toActions :: M env m
=> InstalledMap
-> (m () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task) -- build and final
-> [Action]
toActions installedMap runInBase ee (mbuild, mfinal) =
abuild ++ afinal
where
abuild =
case mbuild of
Nothing -> []
Just task@Task {..} ->
[ Action
{ actionId = ActionId taskProvides ATBuild
, actionDeps =
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False
}
]
afinal =
case mfinal of
Nothing -> []
Just task@Task {..} ->
(if taskAllInOne then [] else
[Action
{ actionId = ActionId taskProvides ATBuildFinal
, actionDeps = addBuild ATBuild
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True
}]) ++
[ Action
{ actionId = ActionId taskProvides ATFinal
, actionDeps = addBuild (if taskAllInOne then ATBuild else ATBuildFinal) Set.empty
, actionDo = \ac -> runInBase $ do
let comps = taskComponents task
tests = testComponents comps
benches = benchComponents comps
unless (Set.null tests) $ do
singleTest runInBase topts (Set.toList tests) ac ee task installedMap
unless (Set.null benches) $ do
singleBench runInBase beopts (Set.toList benches) ac ee task installedMap
}
]
where
addBuild aty =
case mbuild of
Nothing -> id
Just _ -> Set.insert $ ActionId taskProvides aty
bopts = eeBuildOpts ee
topts = boptsTestOpts bopts
beopts = boptsBenchmarkOpts bopts
-- | Generate the ConfigCache
getConfigCache :: MonadIO m
=> ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool
-> m (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do
let extra =
-- We enable tests if the test suite dependencies are already
-- installed, so that we avoid unnecessary recompilation based on
-- cabal_macros.h changes when switching between 'stack build' and
-- 'stack test'. See:
-- https://github.com/commercialhaskell/stack/issues/805
case taskType of
TTLocal lp -> concat
[ ["--enable-tests" | enableTest || (depsPresent installedMap $ lpTestDeps lp)]
, ["--enable-benchmarks" | enableBench || (depsPresent installedMap $ lpBenchDeps lp)]
]
_ -> []
idMap <- liftIO $ readTVarIO eeGhcPkgIds
let getMissing ident =
case Map.lookup ident idMap of
Nothing -> error "singleBuild: invariant violated, missing package ID missing"
Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x)
Just (Executable _) -> Nothing
missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing
TaskConfigOpts missing mkOpts = taskConfigOpts
opts = mkOpts missing'
allDeps = Set.fromList $ Map.elems missing' ++ Map.elems taskPresent
cache = ConfigCache
{ configCacheOpts = opts
{ coNoDirs = coNoDirs opts ++ map T.unpack extra
}
, configCacheDeps = allDeps
, configCacheComponents =
case taskType of
TTLocal lp -> Set.map renderComponent $ lpComponents lp
TTUpstream _ _ -> Set.empty
, configCacheHaddock =
shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)
}
allDepsMap = Map.union missing' taskPresent
return (allDepsMap, cache)
-- | Ensure that the configuration for the package matches what is given
ensureConfig :: M env m
=> ConfigCache -- ^ newConfigCache
-> Path Abs Dir -- ^ package directory
-> ExecuteEnv
-> m () -- ^ announce
-> (Bool -> [String] -> m ()) -- ^ cabal
-> Path Abs File -- ^ .cabal file
-> m Bool
ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do
newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))
needConfig <-
if boptsReconfigure eeBuildOpts
then return True
else do
-- Determine the old and new configuration in the local directory, to
-- determine if we need to reconfigure.
mOldConfigCache <- tryGetConfigCache pkgDir
mOldCabalMod <- tryGetCabalMod pkgDir
return $ fmap configCacheOpts mOldConfigCache /= Just (configCacheOpts newConfigCache)
|| mOldCabalMod /= Just newCabalMod
let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache
when needConfig $ withMVar eeConfigureLock $ \_ -> do
deleteCaches pkgDir
announce
menv <- getMinimalEnvOverride
let programNames =
if eeCabalPkgVer < $(mkVersion "1.22")
then ["ghc", "ghc-pkg"]
else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"]
exes <- forM programNames $ \name -> do
mpath <- findExecutable menv name
return $ case mpath of
Nothing -> []
Just x -> return $ concat ["--with-", name, "=", toFilePath x]
cabal False $ "configure" : concat
[ concat exes
, dirs
, nodirs
]
writeConfigCache pkgDir newConfigCache
writeCabalMod pkgDir newCabalMod
return needConfig
announceTask :: MonadLogger m => Task -> Text -> m ()
announceTask task x = $logInfo $ T.concat
[ T.pack $ packageIdentifierString $ taskProvides task
, ": "
, x
]
withSingleContext :: M env m
=> (m () -> IO ())
-> ActionContext
-> ExecuteEnv
-> Task
-> Maybe (Map PackageIdentifier GhcPkgId)
-- ^ All dependencies' package ids to provide to Setup.hs. If
-- Nothing, just provide global and snapshot package
-- databases.
-> Maybe String
-> ( Package
-> Path Abs File
-> Path Abs Dir
-> (Bool -> [String] -> m ())
-> (Text -> m ())
-> Bool
-> Maybe (Path Abs File, Handle)
-> m a)
-> m a
withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =
withPackage $ \package cabalfp pkgDir ->
withLogFile package $ \mlogFile ->
withCabal package pkgDir mlogFile $ \cabal ->
inner0 package cabalfp pkgDir cabal announce console mlogFile
where
announce = announceTask task
wanted =
case taskType of
TTLocal lp -> lpWanted lp
TTUpstream _ _ -> False
console = wanted
&& all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)
&& eeTotalWanted == 1
withPackage inner =
case taskType of
TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)
TTUpstream package _ -> do
mdist <- liftM Just distRelativeDir
m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides
case Map.toList m of
[(ident, dir)]
| ident == taskProvides -> do
let name = packageIdentifierName taskProvides
cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"
let cabalfp = dir cabalfpRel
inner package cabalfp dir
_ -> error $ "withPackage: invariant violated: " ++ show m
withLogFile package inner
| console = inner Nothing
| otherwise = do
logPath <- buildLogPath package msuffix
createTree (parent logPath)
let fp = toFilePath logPath
bracket
(liftIO $ openBinaryFile fp WriteMode)
(liftIO . hClose)
$ \h -> inner (Just (logPath, h))
withCabal package pkgDir mlogFile inner = do
config <- asks getConfig
let envSettings = EnvSettings
{ esIncludeLocals = taskLocation task == Local
, esIncludeGhcPackagePath = False
, esStackExe = False
, esLocaleUtf8 = True
}
menv <- liftIO $ configEnvOverride config envSettings
-- When looking for ghc to build Setup.hs we want to ignore local binaries, see:
-- https://github.com/commercialhaskell/stack/issues/1052
menvWithoutLocals <- liftIO $ configEnvOverride config envSettings { esIncludeLocals = False }
getGhcPath <- runOnce $ liftIO $ join $ findExecutable menvWithoutLocals "ghc"
getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menvWithoutLocals "ghcjs"
distRelativeDir' <- distRelativeDir
esetupexehs <-
-- Avoid broken Setup.hs files causing problems for simple build
-- types, see:
-- https://github.com/commercialhaskell/stack/issues/370
case (packageSimpleType package, eeSetupExe) of
(True, Just setupExe) -> return $ Left setupExe
_ -> liftIO $ fmap Right $ getSetupHs pkgDir
inner $ \stripTHLoading args -> do
let cabalPackageArg =
"-package=" ++ packageIdentifierString
(PackageIdentifier cabalPackageName
eeCabalPkgVer)
packageArgs =
case mdeps of
-- This branch is taken when
-- 'explicit-setup-deps' is requested in your
-- stack.yaml file.
Just deps | explicitSetupDeps (packageName package) config ->
-- Stack always builds with the global Cabal for various
-- reproducibility issues.
let depsMinusCabal
= map ghcPkgIdString
$ Set.toList
$ addGlobalPackages deps (Map.elems eeGlobalDumpPkgs)
in
( "-clear-package-db"
: "-global-package-db"
: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)
) ++
( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts))
: ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts))
: "-hide-all-packages"
: cabalPackageArg
: map ("-package-id=" ++) depsMinusCabal
)
-- This branch is usually taken for builds, and
-- is always taken for `stack sdist`.
--
-- This approach is debatable. It adds access to the
-- snapshot package database for Cabal. There are two
-- possible objections:
--
-- 1. This doesn't isolate the build enough; arbitrary
-- other packages available could cause the build to
-- succeed or fail.
--
-- 2. This doesn't provide enough packages: we should also
-- include the local database when building local packages.
--
-- Currently, this branch is only taken via `stack
-- sdist` or when explicitly requested in the
-- stack.yaml file.
_ ->
cabalPackageArg
: "-clear-package-db"
: "-global-package-db"
: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)
++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]
setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
runExe exeName fullArgs = do
$logProcessRun (toFilePath exeName) fullArgs
-- Use createProcess_ to avoid the log file being closed afterwards
(Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp
let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this
ec <-
liftIO $
withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir LevelInfo mlogFile moutH) $ \outThreadID ->
withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute pkgDir LevelWarn mlogFile merrH) $ \errThreadID -> do
ec <- waitForProcess ph
wait errThreadID
wait outThreadID
return ec
case ec of
ExitSuccess -> return ()
_ -> do
bss <-
case mlogFile of
Nothing -> return []
Just (logFile, h) -> do
liftIO $ hClose h
runResourceT
$ CB.sourceFile (toFilePath logFile)
$$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir
=$ CL.consume
throwM $ CabalExitedUnsuccessfully
ec
taskProvides
exeName
fullArgs
(fmap fst mlogFile)
bss
where
cp0 = proc (toFilePath exeName) fullArgs
cp = cp0
{ cwd = Just $ toFilePath pkgDir
, Process.env = envHelper menv
-- Ideally we'd create a new pipe here and then close it
-- below to avoid the child process from taking from our
-- stdin. However, if we do this, the child process won't
-- be able to get the codepage on Windows that we want.
-- See:
-- https://github.com/commercialhaskell/stack/issues/738
-- , std_in = CreatePipe
, std_out =
case mlogFile of
Nothing -> CreatePipe
Just (_, h) -> UseHandle h
, std_err =
case mlogFile of
Nothing -> CreatePipe
Just (_, h) -> UseHandle h
}
wc <- getWhichCompiler
(exeName, fullArgs) <- case (esetupexehs, wc) of
(Left setupExe, _) -> return (setupExe, setupArgs)
(Right setuphs, compiler) -> do
distDir <- distDirFromDir pkgDir
let setupDir = distDir $(mkRelDir "setup")
outputFile = setupDir $(mkRelFile "setup")
createTree setupDir
compilerPath <-
case compiler of
Ghc -> getGhcPath
Ghcjs -> getGhcjsPath
runExe compilerPath $
[ "--make"
, "-odir", toFilePathNoTrailingSep setupDir
, "-hidir", toFilePathNoTrailingSep setupDir
, "-i", "-i."
] ++ packageArgs ++
[ toFilePath setuphs
, "-o", toFilePath outputFile
] ++
(case compiler of
Ghc -> []
Ghcjs -> ["-build-runner"])
return (outputFile, setupArgs)
runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs
maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir level mlogFile mh =
case mh of
Just h ->
case mlogFile of
Just{} -> return ()
Nothing -> printBuildOutput stripTHLoading makeAbsolute pkgDir level h
Nothing -> return ()
singleBuild :: M env m
=> (m () -> IO ())
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> Bool -- ^ Is this a final build?
-> m ()
singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do
(allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks
mprecompiled <- getPrecompiled cache
minstalled <-
case mprecompiled of
Just precompiled -> copyPreCompiled precompiled
Nothing -> realConfigAndBuild cache allDepsMap
case minstalled of
Nothing -> return ()
Just installed -> do
writeFlagCache installed cache
liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed
where
pname = packageIdentifierName taskProvides
shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname
doHaddock package = shouldHaddockPackage' &&
not isFinalBuild &&
-- Works around haddock failing on bytestring-builder since it has no modules
-- when bytestring is new enough.
packageHasExposedModules package
buildingFinals = isFinalBuild || taskAllInOne
enableTests = buildingFinals && any isCTest (taskComponents task)
enableBenchmarks = buildingFinals && any isCBench (taskComponents task)
annSuffix = if result == "" then "" else " (" <> result <> ")"
where
result = T.intercalate " + " $ concat $
[ ["lib" | taskAllInOne && hasLib]
, ["exe" | taskAllInOne && hasExe]
, ["test" | enableTests]
, ["bench" | enableBenchmarks]
]
(hasLib, hasExe) = case taskType of
TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp)))
-- This isn't true, but we don't want to have this info for
-- upstream deps.
TTUpstream{} -> (False, False)
getPrecompiled cache =
case taskLocation task of
Snap | not shouldHaddockPackage' -> do
mpc <- readPrecompiledCache taskProvides
(configCacheOpts cache)
(configCacheDeps cache)
case mpc of
Nothing -> return Nothing
Just pc | maybe False
(bcoSnapInstallRoot eeBaseConfigOpts `isParentOf`)
(parseAbsFile =<< (pcLibrary pc)) ->
-- If old precompiled cache files are left around but snapshots are deleted,
-- it is possible for the precompiled file to refer to the very library
-- we're building, and if flags are changed it may try to copy the library
-- to itself. This check prevents that from happening.
return Nothing
Just pc | otherwise -> do
let allM _ [] = return True
allM f (x:xs) = do
b <- f x
if b then allM f xs else return False
b <- liftIO $ allM D.doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc
return $ if b then Just pc else Nothing
_ -> return Nothing
copyPreCompiled (PrecompiledCache mlib exes) = do
announceTask task "copying precompiled package"
forM_ mlib $ \libpath -> do
menv <- getMinimalEnvOverride
withMVar eeInstallLock $ \() -> do
-- We want to ignore the global and user databases.
-- Unfortunately, ghc-pkg doesn't take such arguments on the
-- command line. Instead, we'll set GHC_PACKAGE_PATH. See:
-- https://github.com/commercialhaskell/stack/issues/1146
menv' <- modifyEnvOverride menv
$ Map.insert
"GHC_PACKAGE_PATH"
(T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts)
-- In case a build of the library with different flags already exists, unregister it
-- before copying.
catch
(readProcessNull Nothing menv' "ghc-pkg"
[ "unregister"
, "--force"
, packageIdentifierString taskProvides
])
(\(ReadProcessException _ _ _ _) -> return ())
readProcessNull Nothing menv' "ghc-pkg"
[ "register"
, "--force"
, libpath
]
liftIO $ forM_ exes $ \exe -> do
D.createDirectoryIfMissing True bindir
let dst = bindir FP. FP.takeFileName exe
createLink exe dst `catchIO` \_ -> D.copyFile exe dst
case (mlib, exes) of
(Nothing, _:_) -> markExeInstalled (taskLocation task) taskProvides
_ -> return ()
-- Find the package in the database
wc <- getWhichCompiler
let pkgDbs = [bcoSnapDB eeBaseConfigOpts]
case mlib of
Nothing -> return $ Just $ Executable taskProvides
Just _ -> do
mpkgid <- loadInstalledPkg eeEnvOverride wc pkgDbs eeSnapshotDumpPkgs pname
return $ Just $
case mpkgid of
Nothing -> assert False $ Executable taskProvides
Just pkgid -> Library taskProvides pkgid
where
bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix
realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing
$ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
_neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp
if boptsOnlyConfigure eeBuildOpts
then return Nothing
else liftM Just $ realBuild cache package pkgDir cabal announce
realBuild cache package pkgDir cabal announce = do
wc <- getWhichCompiler
markExeNotInstalled (taskLocation task) taskProvides
case taskType of
TTLocal lp -> do
when enableTests $ unsetTestSuccess pkgDir
writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> return ()
() <- announce ("build" <> annSuffix)
config <- asks getConfig
extraOpts <- extraBuildOptions eeBuildOpts
preBuildTime <- modTime <$> liftIO getCurrentTime
cabal (configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $
case (taskType, taskAllInOne, isFinalBuild) of
(_, True, True) -> fail "Invariant violated: cannot have an all-in-one build that also has a final build step."
(TTLocal lp, False, False) -> primaryComponentOptions lp
(TTLocal lp, False, True) -> finalComponentOptions lp
(TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp
(TTUpstream{}, _, _) -> []
checkForUnlistedFiles taskType preBuildTime pkgDir
when (doHaddock package) $ do
announce "haddock"
sourceFlag <- do
hyped <- tryProcessStdout Nothing eeEnvOverride "haddock" ["--hyperlinked-source"]
case hyped of
-- Fancy crosslinked source
Right _ -> do
return ["--haddock-option=--hyperlinked-source"]
-- Older hscolour colouring
Left _ -> do
hscolourExists <- doesExecutableExist eeEnvOverride "HsColour"
unless hscolourExists $ $logWarn
("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>
"found on PATH (use 'stack install hscolour' to install).")
return ["--hyperlink-source" | hscolourExists]
cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]
,sourceFlag])
unless isFinalBuild $ withMVar eeInstallLock $ \() -> do
announce "copy/register"
cabal False ["copy"]
when (packageHasLibrary package) $ cabal False ["register"]
let (installedPkgDb, installedDumpPkgsTVar) =
case taskLocation task of
Snap ->
( bcoSnapDB eeBaseConfigOpts
, eeSnapshotDumpPkgs )
Local ->
( bcoLocalDB eeBaseConfigOpts
, eeLocalDumpPkgs )
let ident = PackageIdentifier (packageName package) (packageVersion package)
mpkgid <- if packageHasLibrary package
then do
mpkgid <- loadInstalledPkg eeEnvOverride wc [installedPkgDb] installedDumpPkgsTVar (packageName package)
case mpkgid of
Nothing -> throwM $ Couldn'tFindPkgId $ packageName package
Just pkgid -> return $ Library ident pkgid
else do
markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?
return $ Executable ident
case taskLocation task of
Snap -> writePrecompiledCache eeBaseConfigOpts taskProvides
(configCacheOpts cache)
(configCacheDeps cache)
mpkgid (packageExes package)
Local -> return ()
return mpkgid
loadInstalledPkg menv wc pkgDbs tvar name = do
dps <- ghcPkgDescribe name menv wc pkgDbs $ conduitDumpPackage =$ CL.consume
case dps of
[] -> return Nothing
[dp] -> do
liftIO $ atomically $ modifyTVar' tvar (Map.insert (dpGhcPkgId dp) dp)
return $ Just (dpGhcPkgId dp)
_ -> error "singleBuild: invariant violated: multiple results when describing installed package"
-- | Check if any unlisted files have been found, and add them to the build cache.
checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m ()
checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do
(addBuildCache,warnings) <-
addUnlistedToBuildCache
preBuildTime
(lpPackage lp)
(lpCabalFile lp)
(lpNewBuildCache lp)
mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings
unless (null addBuildCache) $
writeBuildCache pkgDir $
Map.unions (lpNewBuildCache lp : addBuildCache)
checkForUnlistedFiles (TTUpstream _ _) _ _ = return ()
-- | Determine if all of the dependencies given are installed
depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool
depsPresent installedMap deps = all
(\(name, range) ->
case Map.lookup name installedMap of
Just (_, installed) -> installedVersion installed `withinRange` range
Nothing -> False)
(Map.toList deps)
singleTest :: M env m
=> (m () -> IO ())
-> TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> m ()
singleTest runInBase topts testsToRun ac ee task installedMap = do
-- FIXME: Since this doesn't use cabal, we should be able to avoid using a
-- fullblown 'withSingleContext'.
(allDepsMap, _cache) <- getConfigCache ee task installedMap True False
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do
config <- asks getConfig
let needHpc = toCoverage topts
toRun <-
if toDisableRun topts
then do
announce "Test running disabled by --no-run-tests flag."
return False
else if toRerunTests topts
then return True
else do
success <- checkTestSuccess pkgDir
if success
then do
unless (null testsToRun) $ announce "skipping already passed test"
return False
else return True
when toRun $ do
buildDir <- distDirFromDir pkgDir
hpcDir <- hpcDirFromDir pkgDir
when needHpc (createTree hpcDir)
errs <- liftM Map.unions $ forM (Map.toList (packageTests package)) $ \(testName, suiteInterface) -> do
let stestName = T.unpack testName
(testName', isTestTypeLib) <-
case suiteInterface of
C.TestSuiteLibV09{} -> return (stestName ++ "Stub", True)
C.TestSuiteExeV10{} -> return (stestName, False)
interface -> throwM (TestSuiteTypeUnsupported interface)
exeName <- testExeName testName'
tixPath <- liftM (pkgDir ) $ parseRelFile $ exeName ++ ".tix"
exePath <- liftM (buildDir ) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName
exists <- fileExists exePath
menv <- liftIO $ configEnvOverride config EnvSettings
{ esIncludeLocals = taskLocation task == Local
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
}
if exists
then do
-- We clear out the .tix files before doing a run.
when needHpc $ do
tixexists <- fileExists tixPath
when tixexists $
$logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath))
removeFileIfExists tixPath
let args = toAdditionalArgs topts
argsDisplay = case args of
[] -> ""
_ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
announce $ "test (suite: " <> testName <> argsDisplay <> ")"
let cp = (proc (toFilePath exePath) args)
{ cwd = Just $ toFilePath pkgDir
, Process.env = envHelper menv
, std_in = CreatePipe
, std_out =
case mlogFile of
Nothing -> Inherit
Just (_, h) -> UseHandle h
, std_err =
case mlogFile of
Nothing -> Inherit
Just (_, h) -> UseHandle h
}
-- Use createProcess_ to avoid the log file being closed afterwards
(Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp
when isTestTypeLib $ do
logPath <- buildLogPath package (Just stestName)
createTree (parent logPath)
liftIO $ hPutStr inH $ show (logPath, testName)
liftIO $ hClose inH
ec <- liftIO $ waitForProcess ph
-- Move the .tix file out of the package
-- directory into the hpc work dir, for
-- tidiness.
when needHpc $
updateTixFile (packageName package) tixPath
return $ case ec of
ExitSuccess -> Map.empty
_ -> Map.singleton testName $ Just ec
else do
$logError $ T.concat
[ "Test suite "
, testName
, " executable not found for "
, packageNameText $ packageName package
]
return $ Map.singleton testName Nothing
when needHpc $ do
let testsToRun' = map f testsToRun
f tName =
case Map.lookup tName (packageTests package) of
Just C.TestSuiteLibV09{} -> tName <> "Stub"
_ -> tName
generateHpcReport pkgDir package testsToRun'
bs <- liftIO $
case mlogFile of
Nothing -> return ""
Just (logFile, h) -> do
hClose h
S.readFile $ toFilePath logFile
unless (Map.null errs) $ throwM $ TestSuiteFailure
(taskProvides task)
errs
(fmap fst mlogFile)
bs
singleBench :: M env m
=> (m () -> IO ())
-> BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> m ()
singleBench runInBase beopts benchesToRun ac ee task installedMap = do
-- FIXME: Since this doesn't use cabal, we should be able to avoid using a
-- fullblown 'withSingleContext'.
(allDepsMap, _cache) <- getConfigCache ee task installedMap False True
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do
let args = map T.unpack benchesToRun <> maybe []
((:[]) . ("--benchmark-options=" <>))
(beoAdditionalArgs beopts)
toRun <-
if beoDisableRun beopts
then do
announce "Benchmark running disabled by --no-run-benchmarks flag."
return False
else do
return True
when toRun $ do
announce "benchmarks"
cabal False ("bench" : args)
-- | Grab all output from the given @Handle@ and log it, stripping
-- Template Haskell "Loading package" lines and making paths absolute.
-- thread.
printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
=> Bool -- ^ exclude TH loading?
-> Bool -- ^ convert paths to absolute?
-> Path Abs Dir -- ^ package's root directory
-> LogLevel
-> Handle
-> m ()
printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $
CB.sourceHandle outH
$$ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir
=$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level)
-- | Strip Template Haskell "Loading package" lines and making paths absolute.
mungeBuildOutput :: MonadIO m
=> Bool -- ^ exclude TH loading?
-> Bool -- ^ convert paths to absolute?
-> Path Abs Dir -- ^ package's root directory
-> ConduitM ByteString ByteString m ()
mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $
CB.lines
=$ CL.map stripCarriageReturn
=$ CL.filter (not . isTHLoading)
=$ CL.mapM toAbsolutePath
where
-- | Is this line a Template Haskell "Loading package" line
-- ByteString
isTHLoading :: S8.ByteString -> Bool
isTHLoading _ | not excludeTHLoading = False
isTHLoading bs =
"Loading package " `S8.isPrefixOf` bs &&
("done." `S8.isSuffixOf` bs || "done.\r" `S8.isSuffixOf` bs)
-- | Convert GHC error lines with file paths to have absolute file paths
toAbsolutePath bs | not makeAbsolute = return bs
toAbsolutePath bs = do
let (x, y) = S.break (== _colon) bs
mabs <-
if isValidSuffix y
then do
efp <- liftIO $ tryIO $ resolveFile pkgDir (S8.unpack x)
case efp of
Left _ -> return Nothing
Right fp -> return $ Just $ S8.pack (toFilePath fp)
else return Nothing
case mabs of
Nothing -> return bs
Just fp -> return $ fp `S.append` y
-- | Match the line:column format at the end of lines
isValidSuffix bs0 = maybe False (const True) $ do
guard $ not $ S.null bs0
guard $ S.head bs0 == _colon
(_, bs1) <- S8.readInt $ S.drop 1 bs0
guard $ not $ S.null bs1
guard $ S.head bs1 == _colon
(_, bs2) <- S8.readInt $ S.drop 1 bs1
guard $ (bs2 == ":" || bs2 == ": Warning:")
-- | Strip @\r@ characters from the byte vector. Used because Windows.
stripCarriageReturn :: ByteString -> ByteString
stripCarriageReturn = S8.filter (not . (=='\r'))
-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,
-- throw an exception.
getSetupHs :: Path Abs Dir -- ^ project directory
-> IO (Path Abs File)
getSetupHs dir = do
exists1 <- fileExists fp1
if exists1
then return fp1
else do
exists2 <- fileExists fp2
if exists2
then return fp2
else throwM $ NoSetupHsFound dir
where
fp1 = dir $(mkRelFile "Setup.hs")
fp2 = dir $(mkRelFile "Setup.lhs")
-- Do not pass `-hpcdir` as GHC option if the coverage is not enabled.
-- This helps running stack-compiled programs with dynamic interpreters like `hint`.
-- Cfr: https://github.com/commercialhaskell/stack/issues/997
extraBuildOptions :: M env m => BuildOpts -> m [String]
extraBuildOptions bopts = do
let ddumpOpts = " -ddump-hi -ddump-to-file"
case toCoverage (boptsTestOpts bopts) of
True -> do
hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir
return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ ddumpOpts]
False -> return ["--ghc-options", ddumpOpts]
-- Library and executable build components.
primaryComponentOptions :: LocalPackage -> [String]
primaryComponentOptions lp = concat
[ ["lib:" ++ packageNameString (packageName (lpPackage lp))
-- TODO: get this information from target parsing instead,
-- which will allow users to turn off library building if
-- desired
| packageHasLibrary (lpPackage lp)]
, map (T.unpack . T.append "exe:") $ Set.toList $ exesToBuild lp
]
exesToBuild :: LocalPackage -> Set Text
exesToBuild lp = packageExes (lpPackage lp)
-- NOTE: Ideally we'd do something like the following code, allowing
-- the user to control which executables get built. However, due to
-- https://github.com/haskell/cabal/issues/2780 we must build all
-- exes...
--
-- if lpWanted lp
-- then exeComponents (lpComponents lp)
-- -- Build all executables in the event that no
-- -- specific list is provided (as happens with
-- -- extra-deps).
-- else packageExes (lpPackage lp)
-- Test-suite and benchmark build components.
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions lp =
map (T.unpack . decodeUtf8 . renderComponent) $
Set.toList $
Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp)
taskComponents :: Task -> Set NamedComponent
taskComponents task =
case taskType task of
TTLocal lp -> lpComponents lp
TTUpstream{} -> Set.empty
-- | Take the given list of package dependencies and the contents of the global
-- package database, and construct a set of installed package IDs that:
--
-- * Excludes the Cabal library (it's added later)
--
-- * Includes all packages depended on by this package
--
-- * Includes all global packages, unless: (1) it's hidden, (2) it's shadowed
-- by a depended-on package, or (3) one of its dependencies is not met.
--
-- See:
--
-- * https://github.com/commercialhaskell/stack/issues/941
--
-- * https://github.com/commercialhaskell/stack/issues/944
--
-- * https://github.com/commercialhaskell/stack/issues/949
addGlobalPackages :: Map PackageIdentifier GhcPkgId -- ^ dependencies of the package
-> [DumpPackage () ()] -- ^ global packages
-> Set GhcPkgId
addGlobalPackages deps globals0 =
res
where
-- Initial set of packages: the installed IDs of all dependencies
res0 = Map.elems $ Map.filterWithKey (\ident _ -> not $ isCabal ident) deps
-- First check on globals: it's not shadowed by a dep, it's not Cabal, and
-- it's exposed
goodGlobal1 dp = not (isDep dp)
&& not (isCabal $ dpPackageIdent dp)
&& dpIsExposed dp
globals1 = filter goodGlobal1 globals0
-- Create a Map of unique package names in the global database
globals2 = Map.fromListWith chooseBest
$ map (packageIdentifierName . dpPackageIdent &&& id) globals1
-- Final result: add in globals that have their dependencies met
res = loop id (Map.elems globals2) $ Set.fromList res0
----------------------------------
-- Some auxiliary helper functions
----------------------------------
-- Is the given package identifier for any version of Cabal
isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal")
-- Is the given package name provided by the package dependencies?
isDep dp = packageIdentifierName (dpPackageIdent dp) `Set.member` depNames
depNames = Set.map packageIdentifierName $ Map.keysSet deps
-- Choose the best of two competing global packages (the newest version)
chooseBest dp1 dp2
| getVer dp1 < getVer dp2 = dp2
| otherwise = dp1
where
getVer = packageIdentifierVersion . dpPackageIdent
-- Are all dependencies of the given package met by the given Set of
-- installed packages
depsMet dp gids = all (`Set.member` gids) (dpDepends dp)
-- Find all globals that have all of their dependencies met
loop front (dp:dps) gids
-- This package has its deps met. Add it to the list of dependencies
-- and then traverse the list from the beginning (this package may have
-- been a dependency of an earlier one).
| depsMet dp gids = loop id (front dps) (Set.insert (dpGhcPkgId dp) gids)
-- Deps are not met, keep going
| otherwise = loop (front . (dp:)) dps gids
-- None of the packages we checked can be added, therefore drop them all
-- and return our results
loop _ [] gids = gids
stack-0.1.10.0/src/Stack/Build/Haddock.hs 0000644 0000000 0000000 00000025574 12623647202 016027 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Generate haddocks
module Stack.Build.Haddock
( generateLocalHaddockIndex
, generateDepsHaddockIndex
, generateSnapHaddockIndex
, shouldHaddockPackage
, shouldHaddockDeps
) where
import Control.Exception (tryJust, onException)
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Resource
import qualified Data.Foldable as F
import Data.Function
import qualified Data.HashSet as HS
import Data.List
import Data.List.Extra (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (mapMaybeM)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (UTCTime)
import Path
import Path.Extra
import Path.IO
import Prelude
import Stack.Types.Build
import Stack.PackageDump
import Stack.Types
import System.Directory (getModificationTime)
import qualified System.FilePath as FP
import System.IO.Error (isDoesNotExistError)
import System.Process.Read
-- | Determine whether we should haddock for a package.
shouldHaddockPackage :: BuildOpts
-> Set PackageName -- ^ Packages that we want to generate haddocks for
-- in any case (whether or not we are going to generate
-- haddocks for dependencies)
-> PackageName
-> Bool
shouldHaddockPackage bopts wanted name =
if Set.member name wanted
then boptsHaddock bopts
else shouldHaddockDeps bopts
-- | Determine whether to build haddocks for dependencies.
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts)
-- | Generate Haddock index and contents for local packages.
generateLocalHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () ()) -- ^ Local package dump
-> [LocalPackage]
-> m ()
generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do
let dumpPackages =
mapMaybe
(\LocalPackage{lpPackage = Package{..}} ->
F.find
(\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion)
localDumpPkgs)
locals
generateHaddockIndex
"local packages"
envOverride
wc
dumpPackages
"."
(localDocDir bco)
-- | Generate Haddock index and contents for local packages and their dependencies.
generateDepsHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () ()) -- ^ Global dump information
-> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot dump information
-> Map GhcPkgId (DumpPackage () ()) -- ^ Local dump information
-> [LocalPackage]
-> m ()
generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do
let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals
depDocDir = localDocDir bco $(mkRelDir "all")
generateHaddockIndex
"local packages and dependencies"
envOverride
wc
deps
".."
depDocDir
where
getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage{lpPackage = Package{..}} =
let pkgId = PackageIdentifier packageName packageVersion
mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs
in fmap dpGhcPkgId mdpPkg
findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends = (`go` HS.empty) . HS.fromList
where
go todo checked =
case HS.toList todo of
[] -> HS.toList checked
(ghcPkgId:_) ->
let deps =
case lookupDumpPackage ghcPkgId allDumpPkgs of
Nothing -> HS.empty
Just pkgDP -> HS.fromList (dpDepends pkgDP)
deps' = deps `HS.difference` checked
todo' = HS.delete ghcPkgId (deps' `HS.union` todo)
checked' = HS.insert ghcPkgId checked
in go todo' checked'
allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs]
-- | Generate Haddock index and contents for all snapshot packages.
generateSnapHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () ()) -- ^ Global package dump
-> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot package dump
-> m ()
generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs =
generateHaddockIndex
"snapshot packages"
envOverride
wc
(Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs)
"."
(snapDocDir bco)
-- | Generate Haddock index and contents for specified packages.
generateHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> Text
-> EnvOverride
-> WhichCompiler
-> [DumpPackage () ()]
-> FilePath
-> Path Abs Dir
-> m ()
generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do
createTree destDir
interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages
unless (null interfaceOpts) $ do
let destIndexFile = toFilePath (haddockIndexFile destDir)
eindexModTime <- liftIO (tryGetModificationTime destIndexFile)
let needUpdate =
case eindexModTime of
Left _ -> True
Right indexModTime ->
or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts]
when needUpdate $ do
$logInfo
(T.concat ["Updating Haddock index for ", descr, " in\n",
T.pack destIndexFile])
liftIO (mapM_ copyPkgDocs interfaceOpts)
readProcessNull
(Just destDir)
envOverride
(haddockExeName wc)
(["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs])
where
toInterfaceOpt :: DumpPackage a b -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt DumpPackage {..} = do
case dpHaddockInterfaces of
[] -> return Nothing
srcInterfaceFP:_ -> do
srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP
let (PackageIdentifier name _) = dpPackageIdent
destInterfaceRelFP =
docRelFP FP.
packageIdentifierString dpPackageIdent FP.
(packageNameString name FP.<.> "haddock")
destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP)
esrcInterfaceModTime <- tryGetModificationTime (toFilePath srcInterfaceAbsFile)
return $
case esrcInterfaceModTime of
Left _ -> Nothing
Right srcInterfaceModTime ->
Just
( [ "-i"
, concat
[ docRelFP FP. packageIdentifierString dpPackageIdent
, ","
, destInterfaceRelFP ]]
, srcInterfaceModTime
, srcInterfaceAbsFile
, destInterfaceAbsFile )
tryGetModificationTime :: FilePath -> IO (Either () UTCTime)
tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime
copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do
-- Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@
-- links work and it's easy to upload docs to a web server or otherwise view them in a
-- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks
-- aren't reliably supported on Windows, and (2) the filesystem containing dependencies'
-- docs may not be available where viewing the docs (e.g. if building in a Docker
-- container).
edestInterfaceModTime <- tryGetModificationTime (toFilePath destInterfaceAbsFile)
case edestInterfaceModTime of
Left _ -> doCopy
Right destInterfaceModTime
| destInterfaceModTime < srcInterfaceModTime -> doCopy
| otherwise -> return ()
where
doCopy = do
removeTreeIfExists destHtmlAbsDir
createTree destHtmlAbsDir
onException
(copyDirectoryRecursive (parent srcInterfaceAbsFile) destHtmlAbsDir)
(removeTreeIfExists destHtmlAbsDir)
destHtmlAbsDir = parent destInterfaceAbsFile
-- | Find first DumpPackage matching the GhcPkgId
lookupDumpPackage :: GhcPkgId
-> [Map GhcPkgId (DumpPackage () ())]
-> Maybe (DumpPackage () ())
lookupDumpPackage ghcPkgId dumpPkgs =
listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs
-- | Path of haddock index file.
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile destDir = destDir $(mkRelFile "index.html")
-- | Path of local packages documentation directory.
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir bco = bcoLocalInstallRoot bco docDirSuffix
-- | Path of snapshot packages documentation directory.
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir bco = bcoSnapInstallRoot bco docDirSuffix
stack-0.1.10.0/src/Stack/Build/Installed.hs 0000644 0000000 0000000 00000027232 12623647202 016402 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- Determine which packages are already installed
module Stack.Build.Installed
( InstalledMap
, Installed (..)
, GetInstalledOpts (..)
, getInstalled
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Function
import qualified Data.HashSet as HashSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (mapMaybeM)
import Data.Monoid
import qualified Data.Text as T
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
import Stack.Types.Build
import Stack.Types.Version
import Stack.Constants
import Stack.GhcPkg
import Stack.PackageDump
import Stack.Types
import Stack.Types.Internal
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
-- | Options for 'getInstalled'.
data GetInstalledOpts = GetInstalledOpts
{ getInstalledProfiling :: !Bool
-- ^ Require profiling libraries?
, getInstalledHaddock :: !Bool
-- ^ Require haddocks?
}
-- | Returns the new InstalledMap and all of the locally registered packages.
getInstalled :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Map PackageName pii -- ^ does not contain any installed information
-> m ( InstalledMap
, [DumpPackage () ()] -- globally installed
, [DumpPackage () ()] -- snapshot installed
, [DumpPackage () ()] -- locally installed
)
getInstalled menv opts sourceMap = do
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
extraDBPaths <- packageDatabaseExtra
bconfig <- asks getBuildConfig
mcache <-
if getInstalledProfiling opts || getInstalledHaddock opts
then liftM Just $ loadInstalledCache $ configInstalledCache bconfig
else return Nothing
let loadDatabase' = loadDatabase menv opts mcache sourceMap
(installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing []
(installedLibs1, _extraInstalled) <-
(foldM (\lhs' pkgdb ->
loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs')
) (installedLibs0, globalDumpPkgs) extraDBPaths)
(installedLibs2, snapshotDumpPkgs) <-
loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1
(installedLibs3, localDumpPkgs) <-
loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2
let installedLibs = M.fromList $ map lhPair installedLibs3
case mcache of
Nothing -> return ()
Just pcache -> saveInstalledCache (configInstalledCache bconfig) pcache
-- Add in the executables that are installed, making sure to only trust a
-- listed installation under the right circumstances (see below)
let exesToSM loc = Map.unions . map (exeToSM loc)
exeToSM loc (PackageIdentifier name version) =
case Map.lookup name sourceMap of
-- Doesn't conflict with anything, so that's OK
Nothing -> m
Just pii
-- Not the version we want, ignore it
| version /= piiVersion pii || loc /= piiLocation pii -> Map.empty
| otherwise -> m
where
m = Map.singleton name (loc, Executable $ PackageIdentifier name version)
exesSnap <- getInstalledExes Snap
exesLocal <- getInstalledExes Local
let installedMap = Map.unions
[ exesToSM Local exesLocal
, exesToSM Snap exesSnap
, installedLibs
]
return ( installedMap
, globalDumpPkgs
, snapshotDumpPkgs
, localDumpPkgs
)
-- | Outputs both the modified InstalledMap and the Set of all installed packages in this database
--
-- The goal is to ascertain that the dependencies for a package are present,
-- that it has profiling if necessary, and that it matches the version and
-- location needed by the SourceMap
loadDatabase :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Maybe InstalledCache -- ^ if Just, profiling or haddock is required
-> Map PackageName pii -- ^ to determine which installed things we should include
-> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global
-> [LoadHelper] -- ^ from parent databases
-> m ([LoadHelper], [DumpPackage () ()])
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
wc <- getWhichCompiler
(lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb))
$ conduitDumpPackage =$ sink
let ghcjsHack = wc == Ghcjs && isNothing mdb
lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1'
let lhs = pruneDeps
id
lhId
lhDeps
const
(lhs0 ++ lhs1)
return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
where
conduitProfilingCache =
case mcache of
Just cache | getInstalledProfiling opts -> addProfiling cache
-- Just an optimization to avoid calculating the profiling
-- values when they aren't necessary
_ -> CL.map (\dp -> dp { dpProfiling = False })
conduitHaddockCache =
case mcache of
Just cache | getInstalledHaddock opts -> addHaddock cache
-- Just an optimization to avoid calculating the haddock
-- values when they aren't necessary
_ -> CL.map (\dp -> dp { dpHaddock = False })
mloc = fmap fst mdb
sinkDP = conduitProfilingCache
=$ conduitHaddockCache
=$ CL.map (\dp -> (isAllowed opts mcache sourceMap mloc dp, toLoadHelper mloc dp))
=$ CL.consume
sink = getZipSink $ (,)
<$> ZipSink sinkDP
<*> ZipSink CL.consume
processLoadResult :: MonadLogger m
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Bool
-> (Allowed, LoadHelper)
-> m (Maybe LoadHelper)
processLoadResult _ _ (Allowed, lh) = return (Just lh)
processLoadResult _ True (WrongVersion actual wanted, lh)
-- Allow some packages in the ghcjs global DB to have the wrong
-- versions. Treat them as wired-ins by setting deps to [].
| fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do
$logWarn $ T.concat
[ "Ignoring that the GHCJS boot package \""
, packageNameText (fst (lhPair lh))
, "\" has a different version, "
, versionText actual
, ", than the resolver's wanted version, "
, versionText wanted
]
return (Just lh)
processLoadResult mdb _ (reason, lh) = do
$logDebug $ T.concat $
[ "Ignoring package "
, packageNameText (fst (lhPair lh))
] ++
(maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb) ++
[ " due to "
, case reason of
Allowed -> " the impossible?!?!"
NeedsProfiling -> " it needing profiling."
NeedsHaddock -> " it needing haddocks."
UnknownPkg -> " it being unknown to the resolver / extra-deps."
WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc))
WrongVersion actual wanted -> T.concat
[ " wanting version "
, versionText wanted
, " instead of "
, versionText actual
]
]
return Nothing
data Allowed
= Allowed
| NeedsProfiling
| NeedsHaddock
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) InstallLocation
| WrongVersion Version Version
deriving (Eq, Show)
-- | Check if a can be included in the set of installed packages or not, based
-- on the package selections made by the user. This does not perform any
-- dirtiness or flag change checks.
isAllowed :: PackageInstallInfo pii
=> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe InstalledPackageLocation
-> DumpPackage Bool Bool
-> Allowed
isAllowed opts mcache sourceMap mloc dp
-- Check that it can do profiling if necessary
| getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = NeedsProfiling
-- Check that it has haddocks if necessary
| getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = NeedsHaddock
| otherwise =
case Map.lookup name sourceMap of
Nothing ->
case mloc of
-- The sourceMap has nothing to say about this global
-- package, so we can use it
Nothing -> Allowed
Just ExtraGlobal -> Allowed
-- For non-global packages, don't include unknown packages.
-- See:
-- https://github.com/commercialhaskell/stack/issues/292
Just _ -> UnknownPkg
Just pii
| not (checkLocation (piiLocation pii)) -> WrongLocation mloc (piiLocation pii)
| version /= piiVersion pii -> WrongVersion version (piiVersion pii)
| otherwise -> Allowed
where
PackageIdentifier name version = dpPackageIdent dp
-- Ensure that the installed location matches where the sourceMap says it
-- should be installed
checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap
checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs
data LoadHelper = LoadHelper
{ lhId :: !GhcPkgId
, lhDeps :: ![GhcPkgId]
, lhPair :: !(PackageName, (InstallLocation, Installed))
}
deriving Show
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool -> LoadHelper
toLoadHelper mloc dp = LoadHelper
{ lhId = gid
, lhDeps =
-- We always want to consider the wired in packages as having all
-- of their dependencies installed, since we have no ability to
-- reinstall them. This is especially important for using different
-- minor versions of GHC, where the dependencies of wired-in
-- packages may change slightly and therefore not match the
-- snapshot.
if name `HashSet.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (toPackageLocation mloc, Library ident gid))
}
where
gid = dpGhcPkgId dp
ident@(PackageIdentifier name _) = dpPackageIdent dp
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Nothing = Snap
toPackageLocation (Just ExtraGlobal) = Snap
toPackageLocation (Just (InstalledTo loc)) = loc
stack-0.1.10.0/src/Stack/Build/Source.hs 0000644 0000000 0000000 00000056742 12630352213 015724 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- Load information on package sources
module Stack.Build.Source
( loadSourceMap
, SourceMap
, PackageSource (..)
, localFlags
, getLocalPackageViews
, loadLocalPackage
, parseTargetsFromBuildOpts
, addUnlistedToBuildCache
, getPackageConfig
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception (assert, catch)
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import "cryptohash" Crypto.Hash (Digest, SHA256)
import Crypto.Hash.Conduit (sinkHash)
import qualified Data.ByteString as S
import Data.Byteable (toBytes)
import Data.Conduit (($$), ZipSink (..))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Function
import qualified Data.HashSet as HashSet
import Data.List
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Distribution.Package (pkgName, pkgVersion)
import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Prelude
import Stack.Build.Cache
import Stack.Build.Target
import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,
parseCustomMiniBuildPlan)
import Stack.Constants (wiredInPackages)
import Stack.Package
import Stack.Types
import System.Directory
import System.IO (withBinaryFile, IOMode (ReadMode))
import System.IO.Error (isDoesNotExistError)
loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOpts
-> m ( Map PackageName SimpleTarget
, MiniBuildPlan
, [LocalPackage]
, Set PackageName -- non-local targets
, SourceMap
)
loadSourceMap needTargets bopts = do
bconfig <- asks getBuildConfig
rawLocals <- getLocalPackageViews
(mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts
let latestVersion =
Map.fromListWith max $
map toTuple $
Map.keys (bcPackageCaches bconfig)
-- Extend extra-deps to encompass targets requested on the command line
-- that are not in the snapshot.
extraDeps0 <- extendExtraDeps
(bcExtraDeps bconfig)
cliExtraDeps
(Map.keysSet $ Map.filter (== STUnknown) targets)
latestVersion
locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals
checkFlagsUsed bopts locals extraDeps0 (mbpPackages mbp0)
checkComponentsBuildable locals
let
-- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately;
-- here we combine them into nonLocalTargets. This is one of the
-- return values of this function.
nonLocalTargets :: Set PackageName
nonLocalTargets =
Map.keysSet $ Map.filter (not . isLocal) targets
where
isLocal (STLocalComps _) = True
isLocal STLocalAll = True
isLocal STUnknown = False
isLocal STNonLocal = False
shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0
(mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed
-- Add the extra deps from the stack.yaml file to the deps grabbed from
-- the snapshot
extraDeps2 = Map.union
(Map.map (\v -> (v, Map.empty)) extraDeps0)
(Map.map (mpiVersion &&& mpiFlags) extraDeps1)
-- Overwrite any flag settings with those from the config file
extraDeps3 = Map.mapWithKey
(\n (v, f) -> PSUpstream v Local $
case ( Map.lookup (Just n) $ boptsFlags bopts
, Map.lookup Nothing $ boptsFlags bopts
, Map.lookup n $ bcFlags bconfig
) of
-- Didn't have any flag overrides, fall back to the flags
-- defined in the snapshot.
(Nothing, Nothing, Nothing) -> f
-- Either command line flag for this package, general
-- command line flag, or flag in stack.yaml is defined.
-- Take all of those and ignore the snapshot flags.
(x, y, z) -> Map.unions
[ fromMaybe Map.empty x
, fromMaybe Map.empty y
, fromMaybe Map.empty z
])
extraDeps2
let sourceMap = Map.unions
[ Map.fromList $ flip map locals $ \lp ->
let p = lpPackage lp
in (packageName p, PSLocal lp)
, extraDeps3
, flip fmap (mbpPackages mbp) $ \mpi ->
(PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi))
] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
return (targets, mbp, locals, nonLocalTargets, sourceMap)
-- | Use the build options and environment to parse targets.
parseTargetsFromBuildOpts
:: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOpts
-> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)
parseTargetsFromBuildOpts needTargets bopts = do
bconfig <- asks getBuildConfig
mbp0 <-
case bcResolver bconfig of
ResolverSnapshot snapName -> do
$logDebug $ "Checking resolver: " <> renderSnapName snapName
loadMiniBuildPlan snapName
ResolverCompiler _ -> do
-- We ignore the resolver version, as it might be
-- GhcMajorVersion, and we want the exact version
-- we're using.
version <- asks (envConfigCompilerVersion . getEnvConfig)
return MiniBuildPlan
{ mbpCompilerVersion = version
, mbpPackages = Map.empty
}
ResolverCustom _ url -> do
stackYamlFP <- asks $ bcStackYaml . getBuildConfig
parseCustomMiniBuildPlan stackYamlFP url
rawLocals <- getLocalPackageViews
workingDir <- getWorkingDir
let snapshot = mpiVersion <$> mbpPackages mbp0
flagExtraDeps <- convertSnapshotToExtra
snapshot
(bcExtraDeps bconfig)
rawLocals
(catMaybes $ Map.keys $ boptsFlags bopts)
(cliExtraDeps, targets) <-
parseTargets
needTargets
(bcImplicitGlobal bconfig)
snapshot
(flagExtraDeps <> bcExtraDeps bconfig)
(fst <$> rawLocals)
workingDir
(boptsTargets bopts)
return (mbp0, cliExtraDeps <> flagExtraDeps, targets)
-- | For every package in the snapshot which is referenced by a flag, give the
-- user a warning and then add it to extra-deps.
convertSnapshotToExtra
:: MonadLogger m
=> Map PackageName Version -- ^ snapshot
-> Map PackageName Version -- ^ extra-deps
-> Map PackageName a -- ^ locals
-> [PackageName] -- ^ packages referenced by a flag
-> m (Map PackageName Version)
convertSnapshotToExtra snapshot extra0 locals flags0 =
go Map.empty flags0
where
go !extra [] = return extra
go extra (flag:flags)
| Just _ <- Map.lookup flag extra0 = go extra flags
| flag `Map.member` locals = go extra flags
| otherwise = case Map.lookup flag snapshot of
Nothing -> go extra flags
Just version -> do
$logWarn $ T.concat
[ "- Implicitly adding "
, T.pack $ packageNameString flag
, " to extra-deps based on command line flag"
]
go (Map.insert flag version extra) flags
-- | Parse out the local package views for the current project
getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> m (Map PackageName (LocalPackageView, GenericPackageDescription))
getLocalPackageViews = do
econfig <- asks getEnvConfig
locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do
cabalfp <- getCabalFileName dir
(warnings,gpkg) <- readPackageUnresolved cabalfp
mapM_ (printCabalFileWarning cabalfp) warnings
let cabalID = package $ packageDescription gpkg
name = fromCabalPackageName $ pkgName cabalID
checkCabalFileName name cabalfp
let lpv = LocalPackageView
{ lpvVersion = fromCabalVersion $ pkgVersion cabalID
, lpvRoot = dir
, lpvCabalFP = cabalfp
, lpvExtraDep = not validWanted
, lpvComponents = getNamedComponents gpkg
}
return (name, (lpv, gpkg))
checkDuplicateNames locals
return $ Map.fromList locals
where
getNamedComponents gpkg = Set.fromList $ concat
[ maybe [] (const [CLib]) (C.condLibrary gpkg)
, go CExe C.condExecutables
, go CTest C.condTestSuites
, go CBench C.condBenchmarks
]
where
go wrapper f = map (wrapper . T.pack . fst) $ f gpkg
-- | Check if there are any duplicate package names and, if so, throw an
-- exception.
checkDuplicateNames :: MonadThrow m => [(PackageName, (LocalPackageView, gpd))] -> m ()
checkDuplicateNames locals =
case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map toPair locals of
[] -> return ()
x -> throwM $ DuplicateLocalPackageNames x
where
toPair (pn, (lpv, _)) = (pn, [lpvRoot lpv])
hasMultiples (_, _:_:_) = True
hasMultiples _ = False
splitComponents :: [NamedComponent]
-> (Set Text, Set Text, Set Text)
splitComponents =
go id id id
where
go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c [])
go a b c (CLib:xs) = go a b c xs
go a b c (CExe x:xs) = go (a . (x:)) b c xs
go a b c (CTest x:xs) = go a (b . (x:)) c xs
go a b c (CBench x:xs) = go a b (c . (x:)) xs
-- | Upgrade the initial local package info to a full-blown @LocalPackage@
-- based on the selected components
loadLocalPackage
:: forall m env.
(MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m)
=> BuildOpts
-> Map PackageName SimpleTarget
-> (PackageName, (LocalPackageView, GenericPackageDescription))
-> m LocalPackage
loadLocalPackage bopts targets (name, (lpv, gpkg)) = do
config <- getPackageConfig bopts name
let pkg = resolvePackage config gpkg
mtarget = Map.lookup name targets
(exes, tests, benches) =
case mtarget of
Just (STLocalComps comps) -> splitComponents $ Set.toList comps
Just STLocalAll ->
( packageExes pkg
, if boptsTests bopts
then Map.keysSet (packageTests pkg)
else Set.empty
, if boptsBenchmarks bopts
then packageBenchmarks pkg
else Set.empty
)
Just STNonLocal -> assert False mempty
Just STUnknown -> assert False mempty
Nothing -> mempty
toComponents e t b = Set.unions
[ Set.map CExe e
, Set.map CTest t
, Set.map CBench b
]
btconfig = config
{ packageConfigEnableTests = not $ Set.null tests
, packageConfigEnableBenchmarks = not $ Set.null benches
}
testconfig = config
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = False
}
benchconfig = config
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = True
}
btpkg
| Set.null tests && Set.null benches = Nothing
| otherwise = Just (resolvePackage btconfig gpkg)
testpkg = resolvePackage testconfig gpkg
benchpkg = resolvePackage benchconfig gpkg
mbuildCache <- tryGetBuildCache $ lpvRoot lpv
(files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv)
-- Filter out the cabal_macros file to avoid spurious recompilations
let filteredFiles = Set.filter ((/= $(mkRelFile "cabal_macros.h")) . filename) files
(dirtyFiles, newBuildCache) <- checkBuildCache
(fromMaybe Map.empty mbuildCache)
(map toFilePath $ Set.toList filteredFiles)
return LocalPackage
{ lpPackage = pkg
, lpTestDeps = packageDeps testpkg
, lpBenchDeps = packageDeps benchpkg
, lpTestBench = btpkg
, lpFiles = files
, lpDirtyFiles =
if not (Set.null dirtyFiles) || boptsForceDirty bopts
then let tryStripPrefix y =
fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y)
in Just $ Set.map tryStripPrefix dirtyFiles
else Nothing
, lpNewBuildCache = newBuildCache
, lpCabalFile = lpvCabalFP lpv
, lpDir = lpvRoot lpv
, lpWanted = isJust mtarget
, lpComponents = toComponents exes tests benches
-- TODO: refactor this so that it's easier to be sure that these
-- components are indeed unbuildable.
--
-- The reasoning here is that if the STLocalComps specification
-- made it through component parsing, but the components aren't
-- present, then they must not be buildable.
, lpUnbuildable = toComponents
(exes `Set.difference` packageExes pkg)
(tests `Set.difference` Map.keysSet (packageTests pkg))
(benches `Set.difference` packageBenchmarks pkg)
}
-- | Ensure that the flags specified in the stack.yaml file and on the command
-- line are used.
checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
=> BuildOpts
-> [LocalPackage]
-> Map PackageName extraDeps -- ^ extra deps
-> Map PackageName snapshot -- ^ snapshot, for error messages
-> m ()
checkFlagsUsed bopts lps extraDeps snapshot = do
bconfig <- asks getBuildConfig
-- Check if flags specified in stack.yaml and the command line are
-- used, see https://github.com/commercialhaskell/stack/issues/617
let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts]
++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig)
localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps
checkFlagUsed ((name, userFlags), source) =
case Map.lookup name localNameMap of
-- Package is not available locally
Nothing ->
case Map.lookup name extraDeps of
-- Also not in extra-deps, it's an error
Nothing ->
case Map.lookup name snapshot of
Nothing -> Just $ UFNoPackage source name
Just _ -> Just $ UFSnapshot name
-- We don't check for flag presence for extra deps
Just _ -> Nothing
-- Package exists locally, let's check if the flags are defined
Just pkg ->
let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg)
in if Set.null unused
-- All flags are defined, nothing to do
then Nothing
-- Error about the undefined flags
else Just $ UFFlagsNotDefined source pkg unused
unusedFlags = mapMaybe checkFlagUsed flags
unless (null unusedFlags)
$ throwM
$ InvalidFlagSpecification
$ Set.fromList unusedFlags
-- | All flags for a local package
localFlags :: (Map (Maybe PackageName) (Map FlagName Bool))
-> BuildConfig
-> PackageName
-> Map FlagName Bool
localFlags boptsflags bconfig name = Map.unions
[ Map.findWithDefault Map.empty (Just name) boptsflags
, Map.findWithDefault Map.empty Nothing boptsflags
, Map.findWithDefault Map.empty name (bcFlags bconfig)
]
-- | Add in necessary packages to extra dependencies
--
-- Originally part of https://github.com/commercialhaskell/stack/issues/272,
-- this was then superseded by
-- https://github.com/commercialhaskell/stack/issues/651
extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
=> Map PackageName Version -- ^ original extra deps
-> Map PackageName Version -- ^ package identifiers from the command line
-> Set PackageName -- ^ all packages added on the command line
-> Map PackageName Version -- ^ latest versions in indices
-> m (Map PackageName Version) -- ^ new extradeps
extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion
| null errs = return $ Map.unions $ extraDeps1 : unknowns'
| otherwise = do
bconfig <- asks getBuildConfig
throwM $ UnknownTargets
(Set.fromList errs)
Map.empty -- TODO check the cliExtraDeps for presence in index
(bcStackYaml bconfig)
where
extraDeps1 = Map.union extraDeps0 cliExtraDeps
(errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns
addUnknown pn =
case Map.lookup pn extraDeps1 of
Just _ -> Right Map.empty
Nothing ->
case Map.lookup pn latestVersion of
Just v -> Right $ Map.singleton pn v
Nothing -> Left pn
-- | Compare the current filesystem state to the cached information, and
-- determine (1) if the files are dirty, and (2) the new cache values.
checkBuildCache :: MonadIO m
=> Map FilePath FileCacheInfo -- ^ old cache
-> [FilePath] -- ^ files in package
-> m (Set FilePath, Map FilePath FileCacheInfo)
checkBuildCache oldCache files = liftIO $ do
(dirtyFiles, m) <- mconcat <$> mapM go files
return (dirtyFiles, m)
where
go fp = do
mmodTime <- getModTimeMaybe fp
case mmodTime of
Nothing -> return (Set.empty, Map.empty)
Just modTime' -> do
(isDirty, newFci) <-
case Map.lookup fp oldCache of
Just fci
| fciModTime fci == modTime' -> return (False, fci)
| otherwise -> do
newFci <- calcFci modTime' fp
let isDirty =
fciSize fci /= fciSize newFci ||
fciHash fci /= fciHash newFci
return (isDirty, newFci)
Nothing -> do
newFci <- calcFci modTime' fp
return (True, newFci)
return (if isDirty then Set.singleton fp else Set.empty, Map.singleton fp newFci)
-- | Returns entries to add to the build cache for any newly found unlisted modules
addUnlistedToBuildCache
:: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)
=> ModTime
-> Package
-> Path Abs File
-> Map FilePath a
-> m ([Map FilePath FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do
(files,warnings) <- getPackageFilesSimple pkg cabalFP
let newFiles =
Set.toList $
Set.map toFilePath files `Set.difference` Map.keysSet buildCache
addBuildCache <- mapM addFileToCache newFiles
return (addBuildCache, warnings)
where
addFileToCache fp = do
mmodTime <- getModTimeMaybe fp
case mmodTime of
Nothing -> return Map.empty
Just modTime' ->
if modTime' < preBuildTime
then do
newFci <- calcFci modTime' fp
return (Map.singleton fp newFci)
else return Map.empty
-- | Gets list of Paths for files in a package
getPackageFilesSimple
:: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)
=> Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning])
getPackageFilesSimple pkg cabalFP = do
(_,compFiles,cabalFiles,warnings) <-
getPackageFiles (packageFiles pkg) cabalFP
return
( Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> cabalFiles
, warnings)
-- | Get file modification time, if it exists.
getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)
getModTimeMaybe fp =
liftIO
(catch
(liftM
(Just . modTime)
(getModificationTime fp))
(\e ->
if isDoesNotExistError e
then return Nothing
else throwM e))
-- | Create FileCacheInfo for a file.
calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo
calcFci modTime' fp = liftIO $
withBinaryFile fp ReadMode $ \h -> do
(size, digest) <- CB.sourceHandle h $$ getZipSink
((,)
<$> ZipSink (CL.fold
(\x y -> x + fromIntegral (S.length y))
0)
<*> ZipSink sinkHash)
return FileCacheInfo
{ fciModTime = modTime'
, fciSize = size
, fciHash = toBytes (digest :: Digest SHA256)
}
checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable lps =
unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable
where
unbuildable =
[ (packageName (lpPackage lp), c)
| lp <- lps
, c <- Set.toList (lpUnbuildable lp)
]
-- | Get 'PackageConfig' for package given its name.
getPackageConfig :: (MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
=> BuildOpts
-> PackageName
-> m PackageConfig
getPackageConfig bopts name = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
return PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = localFlags (boptsFlags bopts) bconfig name
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform $ getConfig bconfig
}
stack-0.1.10.0/src/Stack/Build/Target.hs 0000644 0000000 0000000 00000031477 12623647202 015717 0 ustar 00 0000000 0000000 {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- | Parsing command line targets
module Stack.Build.Target
( -- * Types
ComponentName
, UnresolvedComponent (..)
, RawTarget (..)
, LocalPackageView (..)
, SimpleTarget (..)
, NeedTargets (..)
-- * Parsers
, parseRawTarget
, parseTargets
) where
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class
import Data.Either (partitionEithers)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Path
import Path.IO
import Prelude -- Fix redundant import warnings
import Stack.Types
-- | The name of a component, which applies to executables, test suites, and benchmarks
type ComponentName = Text
newtype RawInput = RawInput { unRawInput :: Text }
-- | Either a fully resolved component, or a component name that could be
-- either an executable, test, or benchmark
data UnresolvedComponent
= ResolvedComponent !NamedComponent
| UnresolvedComponent !ComponentName
deriving (Show, Eq, Ord)
-- | Raw command line input, without checking against any databases or list of
-- locals. Does not deal with directories
data RawTarget (a :: RawTargetType) where
RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a
RTComponent :: !ComponentName -> RawTarget a
RTPackage :: !PackageName -> RawTarget a
RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents
deriving instance Show (RawTarget a)
deriving instance Eq (RawTarget a)
deriving instance Ord (RawTarget a)
data RawTargetType = HasIdents | NoIdents
-- | If this function returns @Nothing@, the input should be treated as a
-- directory.
parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents)
parseRawTarget t =
(RTPackageIdentifier <$> parsePackageIdentifierFromString s)
<|> (RTPackage <$> parsePackageNameFromString s)
<|> (RTComponent <$> T.stripPrefix ":" t)
<|> parsePackageComponent
where
s = T.unpack t
parsePackageComponent =
case T.splitOn ":" t of
[pname, "lib"]
| Just pname' <- parsePackageNameFromString (T.unpack pname) ->
Just $ RTPackageComponent pname' $ ResolvedComponent CLib
[pname, cname]
| Just pname' <- parsePackageNameFromString (T.unpack pname) ->
Just $ RTPackageComponent pname' $ UnresolvedComponent cname
[pname, typ, cname]
| Just pname' <- parsePackageNameFromString (T.unpack pname)
, Just wrapper <- parseCompType typ ->
Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname
_ -> Nothing
parseCompType t' =
case t' of
"exe" -> Just CExe
"test" -> Just CTest
"bench" -> Just CBench
_ -> Nothing
-- | A view of a local package needed for resolving components
data LocalPackageView = LocalPackageView
{ lpvVersion :: !Version
, lpvRoot :: !(Path Abs Dir)
, lpvCabalFP :: !(Path Abs File)
, lpvComponents :: !(Set NamedComponent)
, lpvExtraDep :: !Bool
}
-- | Same as @parseRawTarget@, but also takes directories into account.
parseRawTargetDirs :: (MonadIO m, MonadThrow m)
=> Path Abs Dir -- ^ current directory
-> Map PackageName LocalPackageView
-> Text
-> m (Either Text [(RawInput, RawTarget 'HasIdents)])
parseRawTargetDirs root locals t =
case parseRawTarget t of
Just rt -> return $ Right [(ri, rt)]
Nothing -> do
mdir <- resolveDirMaybe root $ T.unpack t
case mdir of
Nothing -> return $ Left $ "Directory not found: " `T.append` t
Just dir ->
case mapMaybe (childOf dir) $ Map.toList locals of
[] -> return $ Left $
"No local directories found as children of " `T.append`
t
names -> return $ Right $ map ((ri, ) . RTPackage) names
where
ri = RawInput t
childOf dir (name, lpv) =
if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv)
then Just name
else Nothing
data SimpleTarget
= STUnknown
| STNonLocal
| STLocalComps !(Set NamedComponent)
| STLocalAll
deriving (Show, Eq, Ord)
resolveIdents :: Map PackageName Version -- ^ snapshot
-> Map PackageName Version -- ^ extra deps
-> Map PackageName LocalPackageView
-> (RawInput, RawTarget 'HasIdents)
-> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version)
resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty)
resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty)
resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty)
resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) =
case mfound of
Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat
[ "Specified target version "
, versionString version
, " for package "
, packageNameString name
, " does not match "
, foundPlace
, " version "
, versionString foundVersion
]
_ -> Right
( (ri, RTPackage name)
, case mfound of
-- Add to extra deps since we didn't have it already
Nothing -> Map.singleton name version
-- Already had it, don't add to extra deps
Just _ -> Map.empty
)
where
mfound = mlocal <|> mextra <|> msnap
mlocal = (("local", ) . lpvVersion) <$> Map.lookup name locals
mextra = ("extra-deps", ) <$> Map.lookup name extras
msnap = ("snapshot", ) <$> Map.lookup name snap
resolveRawTarget :: Map PackageName Version -- ^ snapshot
-> Map PackageName Version -- ^ extra deps
-> Map PackageName LocalPackageView
-> (RawInput, RawTarget 'NoIdents)
-> Either Text (PackageName, (RawInput, SimpleTarget))
resolveRawTarget snap extras locals (ri, rt) =
go rt
where
go (RTPackageComponent name ucomp) =
case Map.lookup name locals of
Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name
Just lpv ->
case ucomp of
ResolvedComponent comp
| comp `Set.member` lpvComponents lpv ->
Right (name, (ri, STLocalComps $ Set.singleton comp))
| otherwise -> Left $ T.pack $ concat
[ "Component "
, show comp
, " does not exist in package "
, packageNameString name
]
UnresolvedComponent comp ->
case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of
[] -> Left $ T.concat
[ "Component "
, comp
, " does not exist in package "
, T.pack $ packageNameString name
]
[x] -> Right (name, (ri, STLocalComps $ Set.singleton x))
matches -> Left $ T.concat
[ "Ambiguous component name "
, comp
, " for package "
, T.pack $ packageNameString name
, ": "
, T.pack $ show matches
]
go (RTComponent cname) =
let allPairs = concatMap
(\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)
(Map.toList locals)
in case filter (isCompNamed cname . snd) allPairs of
[] -> Left $ "Could not find a component named " `T.append` cname
[(name, comp)] ->
Right (name, (ri, STLocalComps $ Set.singleton comp))
matches -> Left $ T.concat
[ "Ambiugous component name "
, cname
, ", matches: "
, T.pack $ show matches
]
go (RTPackage name) =
case Map.lookup name locals of
Just _lpv -> Right (name, (ri, STLocalAll))
Nothing ->
case Map.lookup name extras of
Just _ -> Right (name, (ri, STNonLocal))
Nothing ->
case Map.lookup name snap of
Just _ -> Right (name, (ri, STNonLocal))
Nothing -> Right (name, (ri, STUnknown))
isCompNamed :: Text -> NamedComponent -> Bool
isCompNamed _ CLib = False
isCompNamed t1 (CExe t2) = t1 == t2
isCompNamed t1 (CTest t2) = t1 == t2
isCompNamed t1 (CBench t2) = t1 == t2
simplifyTargets :: [(PackageName, (RawInput, SimpleTarget))]
-> ([Text], Map PackageName SimpleTarget)
simplifyTargets =
mconcat . map go . Map.toList . Map.fromListWith (++) . fmap (second return)
where
go :: (PackageName, [(RawInput, SimpleTarget)])
-> ([Text], Map PackageName SimpleTarget)
go (_, []) = error "Stack.Build.Target.simplifyTargets: the impossible happened"
go (name, [(_, st)]) = ([], Map.singleton name st)
go (name, pairs) =
case partitionEithers $ map (getLocalComp . snd) pairs of
([], comps) -> ([], Map.singleton name $ STLocalComps $ Set.unions comps)
_ ->
let err = T.pack $ concat
[ "Overlapping targets provided for package "
, packageNameString name
, ": "
, show $ map (unRawInput . fst) pairs
]
in ([err], Map.empty)
getLocalComp (STLocalComps comps) = Right comps
getLocalComp _ = Left ()
-- | Need targets, e.g. `stack build` or allow none?
data NeedTargets
= NeedTargets
| AllowNoTargets
parseTargets :: (MonadThrow m, MonadIO m)
=> NeedTargets -- ^ need at least one target
-> Bool -- ^ using implicit global project?
-> Map PackageName Version -- ^ snapshot
-> Map PackageName Version -- ^ extra deps
-> Map PackageName LocalPackageView
-> Path Abs Dir -- ^ current directory
-> [Text] -- ^ command line targets
-> m (Map PackageName Version, Map PackageName SimpleTarget)
parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do
let textTargets =
if null textTargets'
then map (T.pack . packageNameString) $ Map.keys $ Map.filter (not . lpvExtraDep) locals
else textTargets'
erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets
let (errs1, rawTargets) = partitionEithers erawTargets
(errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $
map (resolveIdents snap extras locals) $ concat rawTargets
(errs3, targetTypes) = partitionEithers $
map (resolveRawTarget snap extras locals) rawTargets'
(errs4, targets) = simplifyTargets targetTypes
errs = concat [errs1, errs2, errs3, errs4]
if null errs
then if Map.null targets
then case needTargets of
AllowNoTargets ->
return (Map.empty, Map.empty)
NeedTargets ->
throwM $ TargetParseException
$ if implicitGlobal
then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
else ["The specified targets matched no packages"]
else return (Map.unions newExtras, targets)
else throwM $ TargetParseException errs
stack-0.1.10.0/src/Stack/Sig.hs 0000644 0000000 0000000 00000003203 12630352213 014127 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : Stack.Sig
Description : GPG Signatures for Stack
Copyright : (c) FPComplete.com, 2015
License : BSD3
Maintainer : Tim Dysinger
Stability : experimental
Portability : POSIX
-}
module Stack.Sig
( module Sig
, sigCmdName
, sigSignCmdName
, sigSignHackageCmdName
, sigSignHackageOpts
, sigSignSdistCmdName
, sigSignSdistOpts
)
where
import Options.Applicative
import Stack.Sig.GPG as Sig
import Stack.Sig.Sign as Sig
-- | The command name for dealing with signatures.
sigCmdName :: String
sigCmdName = "sig"
-- | The command name for signing packages.
sigSignCmdName :: String
sigSignCmdName = "sign"
-- | The command name for signing an sdist package file.
sigSignSdistCmdName :: String
sigSignSdistCmdName = "sdist"
-- | The command name for signing all your packages from hackage.org.
sigSignHackageCmdName :: String
sigSignHackageCmdName = "hackage"
-- | The URL of the running signature service to use (sig-service)
url :: Parser String
url = strOption
(long "url" <>
short 'u' <>
metavar "URL" <>
showDefault <>
value "https://sig.commercialhaskell.org")
-- | Signature sign (sdist) options
sigSignSdistOpts :: Parser (String, String)
sigSignSdistOpts = helper <*>
((,) <$> url <*>
argument str (metavar "PATH"))
-- | Signature sign (hackage) options
sigSignHackageOpts :: Parser (String, String)
sigSignHackageOpts = helper <*>
((,) <$> url <*>
argument str (metavar "USER"))
stack-0.1.10.0/src/Stack/Sig/GPG.hs 0000644 0000000 0000000 00000006746 12630352213 014563 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module : Stack.Sig.GPG
Description : GPG Functions
Copyright : (c) FPComplete.com, 2015
License : BSD3
Maintainer : Tim Dysinger
Stability : experimental
Portability : POSIX
-}
module Stack.Sig.GPG (fullFingerprint, signPackage, verifyFile)
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString.Char8 as C
import Data.Char (isSpace)
import Data.List (find)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Path
import Stack.Types
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
-- | Extract the full long @fingerprint@ given a short (or long)
-- @fingerprint@
fullFingerprint
:: (Monad m, MonadIO m, MonadThrow m)
=> Fingerprint -> m Fingerprint
fullFingerprint (Fingerprint fp) = do
(code,out,err) <-
liftIO
(readProcessWithExitCode "gpg" ["--fingerprint", T.unpack fp] [])
if code /= ExitSuccess
then throwM (GPGFingerprintException (out ++ "\n" ++ err))
else maybe
(throwM
(GPGFingerprintException
("unable to extract full fingerprint from output:\n " <>
out)))
return
(let hasFingerprint =
(==) ["Key", "fingerprint", "="] . take 3
fingerprint =
T.filter (not . isSpace) . T.pack . unwords . drop 3
in Fingerprint . fingerprint <$>
find hasFingerprint (map words (lines out)))
-- | Sign a file path with GPG, returning the @Signature@.
signPackage
:: (Monad m, MonadIO m, MonadThrow m)
=> Path Abs File -> m Signature
signPackage path = do
(code,out,err) <-
liftIO
(readProcessWithExitCode
"gpg"
[ "--output"
, "-"
, "--use-agent"
, "--detach-sig"
, "--armor"
, toFilePath path]
[])
if code /= ExitSuccess
then throwM (GPGSignException (out ++ "\n" ++ err))
else return (Signature (C.pack out))
-- | Verify the @Signature@ of a file path returning the
-- @Fingerprint@.
verifyFile
:: (Monad m, MonadIO m, MonadThrow m)
=> Signature -> Path Abs File -> m Fingerprint
verifyFile (Signature signature) path = do
let process =
readProcessWithExitCode
"gpg"
["--verify", "-", toFilePath path]
(C.unpack signature)
(code,out,err) <- liftIO process
if code /= ExitSuccess
then throwM (GPGVerifyException (out ++ "\n" ++ err))
else maybe
(throwM
(GPGFingerprintException
("unable to extract short fingerprint from output\n: " <>
out)))
return
(let hasFingerprint =
(==) ["gpg:", "Signature", "made"] . take 3
fingerprint = T.pack . last
in Fingerprint . fingerprint <$>
find hasFingerprint (map words (lines err)))
stack-0.1.10.0/src/Stack/Sig/Sign.hs 0000644 0000000 0000000 00000013057 12630352213 015037 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : Stack.Sig.Sign
Description : Signing Packages
Copyright : (c) FPComplete.com, 2015
License : BSD3
Maintainer : Tim Dysinger
Stability : experimental
Portability : POSIX
-}
module Stack.Sig.Sign (sign, signTarBytes) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy as L
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.UUID (toString)
import Data.UUID.V4 (nextRandom)
import Network.HTTP.Conduit
(Response(..), RequestBody(..), Request(..), httpLbs, newManager,
tlsManagerSettings)
import Network.HTTP.Download
import Network.HTTP.Types (status200, methodPut)
import Path
import Path.IO
import Stack.Package
import qualified Stack.Sig.GPG as GPG
import Stack.Types
import qualified System.FilePath as FP
-- | Sign a haskell package with the given url of the signature
-- service and a path to a tarball.
sign
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
=> Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
sign Nothing _ _ = throwM SigNoProjectRootException
sign (Just projectRoot) url filePath = do
withStackWorkTempDir
projectRoot
(\tempDir ->
do bytes <-
liftIO
(fmap
GZip.decompress
(BS.readFile (toFilePath filePath)))
maybePath <- extractCabalFile tempDir (Tar.read bytes)
case maybePath of
Nothing -> throwM SigInvalidSDistTarBall
Just cabalPath -> do
pkg <- cabalFilePackageId (tempDir cabalPath)
signPackage url pkg filePath)
where
extractCabalFile tempDir (Tar.Next entry entries) = do
case Tar.entryContent entry of
(Tar.NormalFile lbs _) ->
case FP.splitFileName (Tar.entryPath entry) of
(folder,file)
| length (FP.splitDirectories folder) == 1 &&
FP.takeExtension file == ".cabal" -> do
cabalFile <- parseRelFile file
liftIO
(BS.writeFile
(toFilePath (tempDir cabalFile))
lbs)
return (Just cabalFile)
(_,_) -> extractCabalFile tempDir entries
_ -> extractCabalFile tempDir entries
extractCabalFile _ _ = return Nothing
-- | Sign a haskell package with the given url to the signature
-- service, a package tarball path (package tarball name) and a lazy
-- bytestring of bytes that represent the tarball bytestream. The
-- function will write the bytes to the path in a temp dir and sign
-- the tarball with GPG.
signTarBytes
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
=> Maybe (Path Abs Dir) -> String -> Path Rel File -> L.ByteString -> m ()
signTarBytes Nothing _ _ _ = throwM SigNoProjectRootException
signTarBytes (Just projectRoot) url tarPath bs =
withStackWorkTempDir
projectRoot
(\tempDir ->
do let tempTarBall = tempDir tarPath
liftIO (L.writeFile (toFilePath tempTarBall) bs)
sign (Just projectRoot) url tempTarBall)
-- | Sign a haskell package given the url to the signature service, a
-- @PackageIdentifier@ and a file path to the package on disk.
signPackage
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
=> String -> PackageIdentifier -> Path Abs File -> m ()
signPackage url pkg filePath = do
$logInfo ("GPG signing " <> T.pack (toFilePath filePath))
sig@(Signature signature) <- GPG.signPackage filePath
let (PackageIdentifier n v) = pkg
name = show n
version = show v
verify <- GPG.verifyFile sig filePath
fingerprint <- GPG.fullFingerprint verify
req <-
parseUrl
(url <> "/upload/signature/" <> name <> "/" <> version <> "/" <>
T.unpack (fingerprintSample fingerprint))
let put =
req
{ method = methodPut
, requestBody = RequestBodyBS signature
}
mgr <- liftIO (newManager tlsManagerSettings)
res <- liftIO (httpLbs put mgr)
when
(responseStatus res /= status200)
(throwM (GPGSignException "unable to sign & upload package"))
withStackWorkTempDir
:: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)
=> Path Abs Dir -> (Path Abs Dir -> m ()) -> m ()
withStackWorkTempDir projectRoot f = do
uuid <- liftIO nextRandom
uuidPath <- parseRelDir (toString uuid)
workDir <- getWorkDir
let tempDir = projectRoot workDir $(mkRelDir "tmp") uuidPath
bracket
(createTree tempDir)
(const (removeTree tempDir))
(const (f tempDir))
stack-0.1.10.0/src/Stack/Upgrade.hs 0000644 0000000 0000000 00000011150 12630352213 014774 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Upgrade (upgrade) where
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control
import Data.Foldable (forM_)
import qualified Data.Map as Map
import Data.Maybe (isNothing)
import Data.Monoid ((<>))
import qualified Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as T
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import qualified Paths_stack as Paths
import Stack.Build
import Stack.Types.Build
import Stack.Config
import Stack.Fetch
import Stack.PackageIndex
import Stack.Setup
import Stack.Types
import Stack.Types.Internal
import Stack.Types.StackT
import System.Process (readProcess)
import System.Process.Run
upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> Maybe String -- ^ git repository to use
-> Maybe AbstractResolver
-> Maybe String -- ^ git hash at time of building, if known
-> m ()
upgrade gitRepo mresolver builtHash =
withCanonicalizedSystemTempDirectory "stack-upgrade" $ \tmp -> do
menv <- getMinimalEnvOverride
mdir <- case gitRepo of
Just repo -> do
remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] []
let latestCommit = head . words $ remote
when (isNothing builtHash) $
$logWarn $ "Information about the commit this version of stack was "
<> "built from is not available due to how it was built. "
<> "Will continue by assuming an upgrade is needed "
<> "because we have no information to the contrary."
if builtHash == Just latestCommit
then do
$logInfo "Already up-to-date, no upgrade required"
return Nothing
else do
$logInfo "Cloning stack"
let args = [ "clone", repo , "stack", "--depth", "1"]
runCmd (Cmd (Just tmp) "git" menv args) Nothing
return $ Just $ tmp $(mkRelDir "stack")
Nothing -> do
updateAllIndices menv
caches <- getPackageCaches menv
let latest = Map.fromListWith max
$ map toTuple
$ Map.keys
-- Mistaken upload to Hackage, just ignore it
$ Map.delete (PackageIdentifier
$(mkPackageName "stack")
$(mkVersion "9.9.9"))
caches
case Map.lookup $(mkPackageName "stack") latest of
Nothing -> error "No stack found in package indices"
Just version | version <= fromCabalVersion Paths.version -> do
$logInfo "Already at latest version, no upgrade required"
return Nothing
Just version -> do
let ident = PackageIdentifier $(mkPackageName "stack") version
paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident
case Map.lookup ident paths of
Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"
Just path -> return $ Just path
config <- asks getConfig
forM_ mdir $ \dir -> do
bconfig <- runInnerStackLoggingT $ do
lc <- loadConfig
(configConfigMonoid config <> Data.Monoid.mempty
{ configMonoidInstallGHC = Just True
})
(Just $ dir $(mkRelFile "stack.yaml"))
mresolver
lcLoadBuildConfig lc Nothing
envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $
"Try rerunning with --install-ghc to install the correct GHC into " <>
T.pack (toFilePath (configLocalPrograms config))
runInnerStackT envConfig1 $
build (const $ return ()) Nothing defaultBuildOpts
{ boptsTargets = ["stack"]
, boptsInstallExes = True
}
stack-0.1.10.0/src/Stack/Upload.hs 0000644 0000000 0000000 00000026051 12630352213 014637 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Provide ability to upload tarballs to Hackage.
module Stack.Upload
( -- * Upload
nopUploader
, mkUploader
, Uploader
, upload
, uploadBytes
, UploadSettings
, defaultUploadSettings
, setUploadUrl
, setGetManager
, setCredsSource
, setSaveCreds
-- * Credentials
, HackageCreds
, loadCreds
, saveCreds
, FromFile
-- ** Credentials source
, HackageCredsSource
, fromAnywhere
, fromPrompt
, fromFile
, fromMemory
) where
import Control.Applicative
import Control.Exception (bracket)
import qualified Control.Exception as E
import Control.Monad (when, unless)
import Data.Aeson (FromJSON (..),
ToJSON (..),
eitherDecode', encode,
object, withObject,
(.:), (.=))
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.IO as TIO
import Data.Typeable (Typeable)
import Network.HTTP.Client (BodyReader, Manager,
Response,
RequestBody(RequestBodyLBS),
applyBasicAuth, brRead,
checkStatus, newManager,
parseUrl,
requestHeaders,
responseBody,
responseStatus,
withResponse)
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (statusCode)
import Path (toFilePath)
import Prelude -- Fix redundant import warnings
import Stack.Types
import System.Directory (createDirectoryIfMissing,
removeFile)
import System.FilePath ((), takeFileName)
import System.IO (hFlush, hGetEcho, hSetEcho,
stdin, stdout)
-- | Username and password to log into Hackage.
--
-- Since 0.1.0.0
data HackageCreds = HackageCreds
{ hcUsername :: !Text
, hcPassword :: !Text
}
deriving Show
instance ToJSON HackageCreds where
toJSON (HackageCreds u p) = object
[ "username" .= u
, "password" .= p
]
instance FromJSON HackageCreds where
parseJSON = withObject "HackageCreds" $ \o -> HackageCreds
<$> o .: "username"
<*> o .: "password"
-- | A source for getting Hackage credentials.
--
-- Since 0.1.0.0
newtype HackageCredsSource = HackageCredsSource
{ getCreds :: IO (HackageCreds, FromFile)
}
-- | Whether the Hackage credentials were loaded from a file.
--
-- This information is useful since, typically, you only want to save the
-- credentials to a file if it wasn't already loaded from there.
--
-- Since 0.1.0.0
type FromFile = Bool
-- | Load Hackage credentials from the given source.
--
-- Since 0.1.0.0
loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile)
loadCreds = getCreds
-- | Save the given credentials to the credentials file.
--
-- Since 0.1.0.0
saveCreds :: Config -> HackageCreds -> IO ()
saveCreds config creds = do
fp <- credsFile config
L.writeFile fp $ encode creds
-- | Load the Hackage credentials from the prompt, asking the user to type them
-- in.
--
-- Since 0.1.0.0
fromPrompt :: HackageCredsSource
fromPrompt = HackageCredsSource $ do
putStr "Hackage username: "
hFlush stdout
username <- TIO.getLine
password <- promptPassword
return (HackageCreds
{ hcUsername = username
, hcPassword = password
}, False)
credsFile :: Config -> IO FilePath
credsFile config = do
let dir = toFilePath (configStackRoot config) "upload"
createDirectoryIfMissing True dir
return $ dir "credentials.json"
-- | Load the Hackage credentials from the JSON config file.
--
-- Since 0.1.0.0
fromFile :: Config -> HackageCredsSource
fromFile config = HackageCredsSource $ do
fp <- credsFile config
lbs <- L.readFile fp
case eitherDecode' lbs of
Left e -> E.throwIO $ Couldn'tParseJSON fp e
Right creds -> return (creds, True)
-- | Load the Hackage credentials from the given arguments.
--
-- Since 0.1.0.0
fromMemory :: Text -> Text -> HackageCredsSource
fromMemory u p = HackageCredsSource $ return (HackageCreds
{ hcUsername = u
, hcPassword = p
}, False)
data HackageCredsExceptions = Couldn'tParseJSON FilePath String
deriving (Show, Typeable)
instance E.Exception HackageCredsExceptions
-- | Try to load the credentials from the config file. If that fails, ask the
-- user to enter them.
--
-- Since 0.1.0.0
fromAnywhere :: Config -> HackageCredsSource
fromAnywhere config = HackageCredsSource $
getCreds (fromFile config) `E.catches`
[ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt
, E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt
]
-- | Lifted from cabal-install, Distribution.Client.Upload
promptPassword :: IO Text
promptPassword = do
putStr "Hackage password: "
hFlush stdout
-- save/restore the terminal echoing status
passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
hSetEcho stdin False -- no echoing for entering the password
fmap T.pack getLine
putStrLn ""
return passwd
nopUploader :: Config -> UploadSettings -> IO Uploader
nopUploader _ _ = return (Uploader nop)
where nop :: String -> L.ByteString -> IO ()
nop _ _ = return ()
-- | Turn the given settings into an @Uploader@.
--
-- Since 0.1.0.0
mkUploader :: Config -> UploadSettings -> IO Uploader
mkUploader config us = do
manager <- usGetManager us
(creds, fromFile') <- loadCreds $ usCredsSource us config
when (not fromFile' && usSaveCreds us) $ saveCreds config creds
req0 <- parseUrl $ usUploadUrl us
let req1 = req0
{ requestHeaders = [("Accept", "text/plain")]
, checkStatus = \_ _ _ -> Nothing
}
return Uploader
{ upload_ = \tarName bytes -> do
let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
req2 <- formDataBody formData req1
let req3 = applyBasicAuth
(encodeUtf8 $ hcUsername creds)
(encodeUtf8 $ hcPassword creds)
req2
putStr $ "Uploading " ++ tarName ++ "... "
hFlush stdout
withResponse req3 manager $ \res ->
case statusCode $ responseStatus res of
200 -> putStrLn "done!"
401 -> do
putStrLn "authentication failure"
cfp <- credsFile config
handleIO (const $ return ()) (removeFile cfp)
error "Authentication failure uploading to server"
403 -> do
putStrLn "forbidden upload"
putStrLn "Usually means: you've already uploaded this package/version combination"
putStrLn "Ignoring error and continuing, full message from Hackage below:\n"
printBody res
503 -> do
putStrLn "service unavailable"
putStrLn "This error some times gets sent even though the upload succeeded"
putStrLn "Check on Hackage to see if your pacakge is present"
printBody res
code -> do
putStrLn $ "unhandled status code: " ++ show code
printBody res
error $ "Upload failed on " ++ tarName
}
printBody :: Response BodyReader -> IO ()
printBody res =
loop
where
loop = do
bs <- brRead $ responseBody res
unless (S.null bs) $ do
S.hPut stdout bs
loop
-- | The computed value from a @UploadSettings@.
--
-- Typically, you want to use this with 'upload'.
--
-- Since 0.1.0.0
data Uploader = Uploader
{ upload_ :: !(String -> L.ByteString -> IO ())
}
-- | Upload a single tarball with the given @Uploader@.
--
-- Since 0.1.0.0
upload :: Uploader -> FilePath -> IO ()
upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp
-- | Upload a single tarball with the given @Uploader@. Instead of
-- sending a file like 'upload', this sends a lazy bytestring.
--
-- Since 0.1.2.1
uploadBytes :: Uploader -> String -> L.ByteString -> IO ()
uploadBytes = upload_
-- | Settings for creating an @Uploader@.
--
-- Since 0.1.0.0
data UploadSettings = UploadSettings
{ usUploadUrl :: !String
, usGetManager :: !(IO Manager)
, usCredsSource :: !(Config -> HackageCredsSource)
, usSaveCreds :: !Bool
}
-- | Default value for @UploadSettings@.
--
-- Use setter functions to change defaults.
--
-- Since 0.1.0.0
defaultUploadSettings :: UploadSettings
defaultUploadSettings = UploadSettings
{ usUploadUrl = "https://hackage.haskell.org/packages/"
, usGetManager = newManager tlsManagerSettings
, usCredsSource = fromAnywhere
, usSaveCreds = True
}
-- | Change the upload URL.
--
-- Default: "https://hackage.haskell.org/packages/"
--
-- Since 0.1.0.0
setUploadUrl :: String -> UploadSettings -> UploadSettings
setUploadUrl x us = us { usUploadUrl = x }
-- | How to get an HTTP connection manager.
--
-- Default: @newManager tlsManagerSettings@
--
-- Since 0.1.0.0
setGetManager :: IO Manager -> UploadSettings -> UploadSettings
setGetManager x us = us { usGetManager = x }
-- | How to get the Hackage credentials.
--
-- Default: @fromAnywhere@
--
-- Since 0.1.0.0
setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings
setCredsSource x us = us { usCredsSource = x }
-- | Save new credentials to the config file.
--
-- Default: @True@
--
-- Since 0.1.0.0
setSaveCreds :: Bool -> UploadSettings -> UploadSettings
setSaveCreds x us = us { usSaveCreds = x }
handleIO :: (E.IOException -> IO a) -> IO a -> IO a
handleIO = E.handle
stack-0.1.10.0/src/System/Process/Read.hs 0000644 0000000 0000000 00000034266 12630352213 016132 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Reading from external processes.
module System.Process.Read
(readProcessStdout
,tryProcessStdout
,sinkProcessStdout
,sinkProcessStderrStdout
,readProcess
,EnvOverride(..)
,unEnvOverride
,mkEnvOverride
,modifyEnvOverride
,envHelper
,doesExecutableExist
,findExecutable
,getEnvOverride
,envSearchPath
,preProcess
,readProcessNull
,readInNull
,logProcessRun
,ReadProcessException (..)
,augmentPath
,augmentPathMap
)
where
import Control.Applicative
import Control.Arrow ((***), first)
import Control.Concurrent.Async (Concurrently (..))
import Control.Exception hiding (try, catch)
import Control.Monad (join, liftM)
import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Conduit.Process hiding (callProcess)
import Data.Foldable (forM_)
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Lazy as LT
import Data.Typeable (Typeable)
import Distribution.System (OS (Windows), Platform (Platform))
import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile)
import Path.IO (createTree, parseRelAsAbsFile)
import Prelude -- Fix AMP warning
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Environment (getEnvironment)
import System.Exit
import qualified System.FilePath as FP
import System.Process.Log
-- | Override the environment received by a child process.
data EnvOverride = EnvOverride
{ eoTextMap :: Map Text Text -- ^ Environment variables as map
, eoStringList :: [(String, String)] -- ^ Environment variables as association list
, eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@)
, eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File)))
, eoExeExtension :: String -- ^ @""@ or @".exe"@, depending on the platform
, eoPlatform :: Platform
}
-- | Get the environment variables from an 'EnvOverride'.
unEnvOverride :: EnvOverride -> Map Text Text
unEnvOverride = eoTextMap
-- | Get the list of directories searched (@PATH@).
envSearchPath :: EnvOverride -> [FilePath]
envSearchPath = eoPath
-- | Modify the environment variables of an 'EnvOverride'.
modifyEnvOverride :: MonadIO m
=> EnvOverride
-> (Map Text Text -> Map Text Text)
-> m EnvOverride
modifyEnvOverride eo f = mkEnvOverride
(eoPlatform eo)
(f $ eoTextMap eo)
-- | Create a new 'EnvOverride'.
mkEnvOverride :: MonadIO m
=> Platform
-> Map Text Text
-> m EnvOverride
mkEnvOverride platform tm' = do
ref <- liftIO $ newIORef Map.empty
return EnvOverride
{ eoTextMap = tm
, eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm
, eoPath = maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)
, eoExeCache = ref
, eoExeExtension = if isWindows then ".exe" else ""
, eoPlatform = platform
}
where
-- Fix case insensitivity of the PATH environment variable on Windows.
tm
| isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'
| otherwise = tm'
-- Don't use CPP so that the Windows code path is at least type checked
-- regularly
isWindows =
case platform of
Platform _ Windows -> True
_ -> False
-- | Helper conversion function.
envHelper :: EnvOverride -> Maybe [(String, String)]
envHelper = Just . eoStringList
-- | Read from the process, ignoring any output.
readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> Maybe (Path Abs Dir) -- ^ Optional working directory
-> EnvOverride
-> String -- ^ Command
-> [String] -- ^ Command line arguments
-> m ()
readProcessNull wd menv name args =
sinkProcessStdout wd menv name args CL.sinkNull
-- | Run the given command in the given directory. If it exits with anything
-- but success, prints an error and then calls 'exitWith' to exit the program.
readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> Path Abs Dir -- ^ Directory to run in
-> FilePath -- ^ Command to run
-> EnvOverride
-> [String] -- ^ Command line arguments
-> Maybe Text -- ^ Optional additional error message
-> m ()
readInNull wd cmd menv args errMsg = do
result <- try (readProcessNull (Just wd) menv cmd args)
case result of
Left (ProcessExitedUnsuccessfully _ ec) -> do
$logError $
T.pack $
concat
[ "Exit code "
, show ec
, " while running "
, show (cmd : args)
, " in "
, toFilePath wd]
forM_ errMsg $logError
liftIO (exitWith ec)
Right () -> return ()
-- | Try to produce a strict 'S.ByteString' from the stdout of a
-- process.
tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> Maybe (Path Abs Dir) -- ^ Optional directory to run in
-> EnvOverride
-> String -- ^ Command
-> [String] -- ^ Command line arguments
-> m (Either ReadProcessException S.ByteString)
tryProcessStdout wd menv name args =
try (readProcessStdout wd menv name args)
-- | Produce a strict 'S.ByteString' from the stdout of a process.
--
-- Throws a 'ReadProcessException' exception if the process fails.
readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> Maybe (Path Abs Dir) -- ^ Optional directory to run in
-> EnvOverride
-> String -- ^ Command
-> [String] -- ^ Command line arguments
-> m S.ByteString
readProcessStdout wd menv name args =
sinkProcessStdout wd menv name args CL.consume >>=
liftIO . evaluate . S.concat
-- | An exception while trying to read from process.
data ReadProcessException
= ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString
| NoPathFound
| ExecutableNotFound String [FilePath]
| ExecutableNotFoundAt FilePath
deriving Typeable
instance Show ReadProcessException where
show (ReadProcessException cp ec out err) = concat
[ "Running "
, showSpec $ cmdspec cp
, " exited with "
, show ec
, "\n"
, toStr out
, "\n"
, toStr err
]
where
toStr = LT.unpack . LT.decodeUtf8With lenientDecode
showSpec (ShellCommand str) = str
showSpec (RawCommand cmd args) =
unwords $ cmd : map (T.unpack . showProcessArgDebug) args
show NoPathFound = "PATH not found in EnvOverride"
show (ExecutableNotFound name path) = concat
[ "Executable named "
, name
, " not found on path: "
, show path
]
show (ExecutableNotFoundAt name) =
"Did not find executable at specified path: " ++ name
instance Exception ReadProcessException
-- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer.
-- If the process fails, spits out stdout and stderr as error log
-- level. Should not be used for long-running processes or ones with
-- lots of output; for that use 'sinkProcessStdoutLogStderr'.
sinkProcessStdout
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> Maybe (Path Abs Dir) -- ^ Optional directory to run in
-> EnvOverride
-> String -- ^ Command
-> [String] -- ^ Command line arguments
-> Sink S.ByteString IO a -- ^ Sink for stdout
-> m a
sinkProcessStdout wd menv name args sinkStdout = do
stderrBuffer <- liftIO (newIORef mempty)
stdoutBuffer <- liftIO (newIORef mempty)
(_,sinkRet) <-
catch
(sinkProcessStderrStdout
wd
menv
name
args
(CL.mapM_ (\bytes -> liftIO (modifyIORef' stderrBuffer (<> byteString bytes))))
(CL.iterM (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))) $=
sinkStdout))
(\(ProcessExitedUnsuccessfully cp ec) ->
do stderrBuilder <- liftIO (readIORef stderrBuffer)
stdoutBuilder <- liftIO (readIORef stdoutBuffer)
throwM $ ReadProcessException
cp
ec
(toLazyByteString stdoutBuilder)
(toLazyByteString stderrBuilder))
return sinkRet
-- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.
sinkProcessStderrStdout :: (MonadIO m, MonadLogger m)
=> Maybe (Path Abs Dir) -- ^ Optional directory to run in
-> EnvOverride
-> String -- ^ Command
-> [String] -- ^ Command line arguments
-> Sink S.ByteString IO e -- ^ Sink for stderr
-> Sink S.ByteString IO o -- ^ Sink for stdout
-> m (e,o)
sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do
$logProcessRun name args
name' <- preProcess wd menv name
liftIO (withCheckedProcess
(proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
(\ClosedStream out err ->
runConcurrently $
(,) <$>
Concurrently (asBSSource err $$ sinkStderr) <*>
Concurrently (asBSSource out $$ sinkStdout)))
where asBSSource :: Source m S.ByteString -> Source m S.ByteString
asBSSource = id
-- | Perform pre-call-process tasks. Ensure the working directory exists and find the
-- executable path.
preProcess :: (MonadIO m)
=> Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary
-> EnvOverride
-> String -- ^ Command name
-> m FilePath
preProcess wd menv name = do
name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name
maybe (return ()) createTree wd
return name'
-- | Check if the given executable exists on the given PATH.
doesExecutableExist :: MonadIO m => EnvOverride -> String -> m Bool
doesExecutableExist menv name = liftM isJust $ findExecutable menv name
-- | Turn a relative path into an absolute path.
--
-- Note: this function duplicates the functionality of makeAbsolute
-- in recent versions of "System.Directory", and can be removed once
-- we no longer need to support older versions of GHC.
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute = fmap FP.normalise . absolutize
where absolutize path
| FP.isRelative path = fmap (FP. path) getCurrentDirectory
| otherwise = return path
-- | Find the complete path for the executable.
--
-- Throws a 'ReadProcessException' if unsuccessful.
findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File))
findExecutable _ name | any FP.isPathSeparator name = do
exists <- liftIO $ doesFileExist name
if exists
then do
path <- liftIO $ parseRelAsAbsFile name
return $ return path
else return $ throwM $ ExecutableNotFoundAt name
findExecutable eo name = liftIO $ do
m <- readIORef $ eoExeCache eo
epath <- case Map.lookup name m of
Just epath -> return epath
Nothing -> do
let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo)
loop (dir:dirs) = do
let fp0 = dir FP. name
fps0
| null (eoExeExtension eo) = [fp0]
-- Support `stack exec foo.exe` on Windows
| otherwise = [fp0 ++ eoExeExtension eo, fp0]
testFPs [] = loop dirs
testFPs (fp:fps) = do
exists <- doesFileExist fp
if exists
then do
fp' <- makeAbsolute fp >>= parseAbsFile
return $ return fp'
else testFPs fps
testFPs fps0
epath <- loop $ eoPath eo
!() <- atomicModifyIORef (eoExeCache eo) $ \m' ->
(Map.insert name epath m', ())
return epath
return $ either throwM return epath
-- | Load up an 'EnvOverride' from the standard environment.
getEnvOverride :: MonadIO m => Platform -> m EnvOverride
getEnvOverride platform =
liftIO $
getEnvironment >>=
mkEnvOverride platform
. Map.fromList . map (T.pack *** T.pack)
-- | Augment the PATH environment variable with the given extra paths.
augmentPath :: [FilePath] -> Maybe Text -> Text
augmentPath dirs mpath =
T.intercalate (T.singleton FP.searchPathSeparator)
$ map (T.pack . FP.dropTrailingPathSeparator) dirs
++ maybe [] return mpath
-- | Apply 'augmentPath' on the PATH value in the given Map.
augmentPathMap :: [FilePath] -> Map Text Text -> Map Text Text
augmentPathMap paths origEnv =
Map.insert "PATH" path origEnv
where
mpath = Map.lookup "PATH" origEnv
path = augmentPath paths mpath
stack-0.1.10.0/src/System/Process/Log.hs 0000644 0000000 0000000 00000002032 12623647202 015771 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
-- | Separate module because TH.
module System.Process.Log
(logProcessRun
,showProcessArgDebug)
where
import Control.Monad.Logger
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
-- | Log running a process with its arguments, for debugging (-v).
logProcessRun :: Q Exp
logProcessRun =
[|let f :: MonadLogger m => String -> [String] -> m ()
f name args =
$logDebug
("Run process: " <> T.pack name <> " " <>
T.intercalate
" "
(map showProcessArgDebug args))
in f|]
-- | Show a process arg including speechmarks when necessary. Just for
-- debugging purposes, not functionally important.
showProcessArgDebug :: String -> Text
showProcessArgDebug x
| any special x = T.pack (show x)
| otherwise = T.pack x
where special '"' = True
special ' ' = True
special _ = False
stack-0.1.10.0/src/System/Process/Run.hs 0000644 0000000 0000000 00000007512 12630352213 016015 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
-- | Run sub-processes.
module System.Process.Run
(runCmd
,runCmd'
,callProcess
,callProcess'
,ProcessExitedUnsuccessfully
,Cmd(..)
)
where
import Control.Exception.Lifted
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError)
import Data.Conduit.Process hiding (callProcess)
import Data.Foldable (forM_)
import Data.Text (Text)
import qualified Data.Text as T
import Path (toFilePath)
import Prelude -- Fix AMP warning
import System.Exit (exitWith, ExitCode (..))
import qualified System.Process
import System.Process.Read
import Path (Dir, Abs, Path)
-- | Cmd holds common infos needed to running a process in most cases
data Cmd = Cmd
{ cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in
, cmdCommandToRun :: FilePath -- ^ command to run
, cmdEnvOverride::EnvOverride
, cmdCommandLineArguments :: [String] -- ^ command line arguments
}
-- | Run the given command in the given directory, inheriting stdout and stderr.
--
-- If it exits with anything but success, prints an error
-- and then calls 'exitWith' to exit the program.
runCmd :: forall (m :: * -> *).
(MonadLogger m,MonadIO m,MonadBaseControl IO m)
=> Cmd
-> Maybe Text -- ^ optional additional error message
-> m ()
runCmd = runCmd' id
runCmd' :: forall (m :: * -> *).
(MonadLogger m,MonadIO m,MonadBaseControl IO m)
=> (CreateProcess -> CreateProcess)
-> Cmd
-> Maybe Text -- ^ optional additional error message
-> m ()
runCmd' modCP cmd@(Cmd{..}) mbErrMsg = do
result <- try (callProcess' modCP cmd)
case result of
Left (ProcessExitedUnsuccessfully _ ec) -> do
$logError $
T.pack $
concat $
[ "Exit code "
, show ec
, " while running "
, show (cmdCommandToRun : cmdCommandLineArguments)
] ++ (case cmdDirectoryToRunIn of
Nothing -> []
Just mbDir -> [" in ", toFilePath mbDir]
)
forM_ mbErrMsg $logError
liftIO (exitWith ec)
Right () -> return ()
-- | Like 'System.Process.callProcess', but takes an optional working directory and
-- environment override, and throws 'ProcessExitedUnsuccessfully' if the
-- process exits unsuccessfully.
--
-- Inherits stdout and stderr.
callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m ()
callProcess = callProcess' id
-- | Like 'System.Process.callProcess', but takes an optional working directory and
-- environment override, and throws 'ProcessExitedUnsuccessfully' if the
-- process exits unsuccessfully.
--
-- Inherits stdout and stderr.
callProcess' :: (MonadIO m, MonadLogger m)
=> (CreateProcess -> CreateProcess) -> Cmd -> m ()
callProcess' modCP (Cmd wd cmd0 menv args) = do
cmd <- preProcess wd menv cmd0
let c = modCP $ (proc cmd args) { delegate_ctlc = True
, cwd = fmap toFilePath wd
, env = envHelper menv }
action (_, _, _, p) = do
exit_code <- waitForProcess p
case exit_code of
ExitSuccess -> return ()
ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
$logProcessRun cmd args
liftIO (System.Process.createProcess c >>= action)
stack-0.1.10.0/src/Network/HTTP/Download/Verified.hs 0000644 0000000 0000000 00000025705 12630352213 020067 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
module Network.HTTP.Download.Verified
( verifiedDownload
, DownloadRequest(..)
, drRetryPolicyDefault
, HashCheck(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
) where
import qualified Data.List as List
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64 as B64
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
import Control.Applicative
import "cryptohash" Crypto.Hash
import Crypto.Hash.Conduit (sinkHash)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (readInteger)
import Data.Conduit
import Data.Conduit.Binary (sourceHandle, sinkHandle)
import Data.Foldable (traverse_,for_)
import Data.Monoid
import Data.String
import Data.Typeable (Typeable)
import GHC.IO.Exception (IOException(..),IOErrorType(..))
import Network.HTTP.Client.Conduit
import Network.HTTP.Types.Header (hContentLength, hContentMD5)
import Path
import Prelude -- Fix AMP warning
import System.FilePath((<.>))
import System.Directory
import System.IO
-- | A request together with some checks to perform.
data DownloadRequest = DownloadRequest
{ drRequest :: Request
, drHashChecks :: [HashCheck]
, drLengthCheck :: Maybe LengthCheck
, drRetryPolicy :: RetryPolicy
}
-- | Default to retrying thrice with a short constant delay.
drRetryPolicyDefault :: RetryPolicy
drRetryPolicyDefault = limitRetries 3 <> constantDelay onehundredMilliseconds
where onehundredMilliseconds = 100000
data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck
{ hashCheckAlgorithm :: a
, hashCheckHexDigest :: CheckHexDigest
}
deriving instance Show HashCheck
data CheckHexDigest
= CheckHexDigestString String
| CheckHexDigestByteString ByteString
| CheckHexDigestHeader ByteString
deriving Show
instance IsString CheckHexDigest where
fromString = CheckHexDigestString
type LengthCheck = Int
-- | An exception regarding verification of a download.
data VerifiedDownloadException
= WrongContentLength
Request
Int -- expected
ByteString -- actual (as listed in the header)
| WrongStreamLength
Request
Int -- expected
Int -- actual
| WrongDigest
Request
String -- algorithm
CheckHexDigest -- expected
String -- actual (shown)
deriving (Typeable)
instance Show VerifiedDownloadException where
show (WrongContentLength req expected actual) =
"Download expectation failure: ContentLength header\n"
++ "Expected: " ++ show expected ++ "\n"
++ "Actual: " ++ displayByteString actual ++ "\n"
++ "For: " ++ show (getUri req)
show (WrongStreamLength req expected actual) =
"Download expectation failure: download size\n"
++ "Expected: " ++ show expected ++ "\n"
++ "Actual: " ++ show actual ++ "\n"
++ "For: " ++ show (getUri req)
show (WrongDigest req algo expected actual) =
"Download expectation failure: content hash (" ++ algo ++ ")\n"
++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"
++ "Actual: " ++ actual ++ "\n"
++ "For: " ++ show (getUri req)
instance Exception VerifiedDownloadException
-- This exception is always caught and never thrown outside of this module.
data VerifyFileException
= WrongFileSize
Int -- expected
Integer -- actual (as listed by hFileSize)
deriving (Show, Typeable)
instance Exception VerifyFileException
-- Show a ByteString that is known to be UTF8 encoded.
displayByteString :: ByteString -> String
displayByteString =
Text.unpack . Text.strip . Text.decodeUtf8
-- Show a CheckHexDigest in human-readable format.
displayCheckHexDigest :: CheckHexDigest -> String
displayCheckHexDigest (CheckHexDigestString s) = s ++ " (String)"
displayCheckHexDigest (CheckHexDigestByteString s) = displayByteString s ++ " (ByteString)"
displayCheckHexDigest (CheckHexDigestHeader h) =
displayByteString (B64.decodeLenient h) ++ " (Header. unencoded: "
++ displayByteString h ++ ")"
-- | Make sure that the hash digest for a finite stream of bytes
-- is as expected.
--
-- Throws WrongDigest (VerifiedDownloadException)
sinkCheckHash :: MonadThrow m
=> Request
-> HashCheck
-> Consumer ByteString m ()
sinkCheckHash req HashCheck{..} = do
digest <- sinkHashUsing hashCheckAlgorithm
let actualDigestString = show digest
let actualDigestHexByteString = digestToHexByteString digest
let passedCheck = case hashCheckHexDigest of
CheckHexDigestString s -> s == actualDigestString
CheckHexDigestByteString b -> b == actualDigestHexByteString
CheckHexDigestHeader b -> B64.decodeLenient b == actualDigestHexByteString
-- A hack to allow hackage tarballs to download.
-- They should really base64-encode their md5 header as per rfc2616#sec14.15.
-- https://github.com/commercialhaskell/stack/issues/240
|| b == actualDigestHexByteString
unless passedCheck $
throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString
assertLengthSink :: MonadThrow m
=> Request
-> LengthCheck
-> ZipSink ByteString m ()
assertLengthSink req expectedStreamLength = ZipSink $ do
Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length)
when (actualStreamLength /= expectedStreamLength) $
throwM $ WrongStreamLength req expectedStreamLength actualStreamLength
-- | A more explicitly type-guided sinkHash.
sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a)
sinkHashUsing _ = sinkHash
-- | Turns a list of hash checks into a ZipSink that checks all of them.
hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
-- | Copied and extended version of Network.HTTP.Download.download.
--
-- Has the following additional features:
-- * Verifies that response content-length header (if present)
-- matches expected length
-- * Limits the download to (close to) the expected # of bytes
-- * Verifies that the expected # bytes were downloaded (not too few)
-- * Verifies md5 if response includes content-md5 header
-- * Verifies the expected hashes
--
-- Throws VerifiedDownloadException.
-- Throws IOExceptions related to file system operations.
-- Throws HttpException.
verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> DownloadRequest
-> Path Abs File -- ^ destination
-> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress
-> m Bool -- ^ Whether a download was performed
verifiedDownload DownloadRequest{..} destpath progressSink = do
let req = drRequest
env <- ask
liftIO $ whenM' getShouldDownload $ do
createDirectoryIfMissing True dir
withBinaryFile fptmp WriteMode $ \h ->
#if MIN_VERSION_retry(0,7,0)
recovering drRetryPolicy handlers $ const $
#else
recovering drRetryPolicy handlers $
#endif
flip runReaderT env $
withResponse req (go h)
renameFile fptmp fp
where
handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO]
alwaysRetryHttp :: Monad m => HttpException -> m Bool
alwaysRetryHttp _ = return True
retrySomeIO :: Monad m => IOException -> m Bool
retrySomeIO e = return $ case ioe_type e of
-- hGetBuf: resource vanished (Connection reset by peer)
ResourceVanished -> True
-- conservatively exclude all others
_ -> False
whenM' mp m = do
p <- mp
if p then m >> return True else return False
fp = toFilePath destpath
fptmp = fp <.> "tmp"
dir = toFilePath $ parent destpath
getShouldDownload = do
fileExists <- doesFileExist fp
if fileExists
-- only download if file does not match expectations
then not <$> fileMatchesExpectations
-- or if it doesn't exist yet
else return True
-- precondition: file exists
-- TODO: add logging
fileMatchesExpectations =
(checkExpectations >> return True)
`catch` \(_ :: VerifyFileException) -> return False
`catch` \(_ :: VerifiedDownloadException) -> return False
checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do
for_ drLengthCheck $ checkFileSizeExpectations h
sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks)
-- doesn't move the handle
checkFileSizeExpectations h expectedFileSize = do
fileSizeInteger <- hFileSize h
when (fileSizeInteger > toInteger (maxBound :: Int)) $
throwM $ WrongFileSize expectedFileSize fileSizeInteger
let fileSize = fromInteger fileSizeInteger
when (fileSize /= expectedFileSize) $
throwM $ WrongFileSize expectedFileSize fileSizeInteger
checkContentLengthHeader headers expectedContentLength =
case List.lookup hContentLength headers of
Just lengthBS -> do
let lengthStr = displayByteString lengthBS
when (lengthStr /= show expectedContentLength) $
throwM $ WrongContentLength drRequest expectedContentLength lengthBS
_ -> return ()
go h res = do
let headers = responseHeaders res
mcontentLength = do
hLength <- List.lookup hContentLength headers
(i,_) <- readInteger hLength
return i
for_ drLengthCheck $ checkContentLengthHeader headers
let hashChecks = (case List.lookup hContentMD5 headers of
Just md5BS ->
[ HashCheck
{ hashCheckAlgorithm = MD5
, hashCheckHexDigest = CheckHexDigestHeader md5BS
}
]
Nothing -> []
) ++ drHashChecks
responseBody res
$= maybe (awaitForever yield) CB.isolate drLengthCheck
$$ getZipSink
( hashChecksToZipSink drRequest hashChecks
*> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck
*> ZipSink (sinkHandle h)
*> ZipSink (progressSink mcontentLength))
stack-0.1.10.0/src/Data/Attoparsec/Args.hs 0000644 0000000 0000000 00000007037 12623647202 016232 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- | Parsing argument-like things.
module Data.Attoparsec.Args
( EscapingMode(..)
, argsParser
, parseArgs
, withInterpreterArgs
) where
import Control.Applicative
import Data.Attoparsec.Text (())
import qualified Data.Attoparsec.Text as P
import Data.Attoparsec.Types (Parser)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import System.Directory (doesFileExist)
import System.Environment (getArgs, withArgs)
import System.IO (IOMode (ReadMode), withBinaryFile)
-- | Mode for parsing escape characters.
data EscapingMode
= Escaping
| NoEscaping
deriving (Show,Eq,Enum)
-- | Parse arguments using 'argsParser'.
parseArgs :: EscapingMode -> Text -> Either String [String]
parseArgs mode = P.parseOnly (argsParser mode)
-- | A basic argument parser. It supports space-separated text, and
-- string quotation with identity escaping: \x -> x.
argsParser :: EscapingMode -> Parser Text [String]
argsParser mode = many (P.skipSpace *> (quoted <|> unquoted)) <*
P.skipSpace <* (P.endOfInput "unterminated string")
where
unquoted = P.many1 naked
quoted = P.char '"' *> string <* P.char '"'
string = many (case mode of
Escaping -> escaped <|> nonquote
NoEscaping -> nonquote)
escaped = P.char '\\' *> P.anyChar
nonquote = P.satisfy (not . (=='"'))
naked = P.satisfy (not . flip elem ("\" " :: String))
-- | Use 'withArgs' on result of 'getInterpreterArgs'.
withInterpreterArgs :: String -> ([String] -> Bool -> IO a) -> IO a
withInterpreterArgs progName inner = do
(args, isInterpreter) <- getInterpreterArgs progName
withArgs args $ inner args isInterpreter
-- | Check if command-line looks like it's being used as a script interpreter,
-- and if so look for a @-- progName ...@ comment that contains additional
-- arguments.
getInterpreterArgs :: String -> IO ([String], Bool)
getInterpreterArgs progName = do
args0 <- getArgs
case args0 of
(x:_) -> do
isFile <- doesFileExist x
if isFile
then do
margs <-
withBinaryFile x ReadMode $ \h ->
CB.sourceHandle h
$= CB.lines
$= CL.map killCR
$$ sinkInterpreterArgs progName
return $ case margs of
Nothing -> (args0, True)
Just args -> (args ++ "--" : args0, True)
else return (args0, False)
_ -> return (args0, False)
where
killCR bs
| S.null bs || S.last bs /= 13 = bs
| otherwise = S.init bs
sinkInterpreterArgs :: Monad m => String -> Sink ByteString m (Maybe [String])
sinkInterpreterArgs progName =
await >>= maybe (return Nothing) checkShebang
where
checkShebang bs
| "#!" `S.isPrefixOf` bs = fmap (maybe Nothing parseArgs') await
| otherwise = return (parseArgs' bs)
parseArgs' bs =
case decodeUtf8' bs of
Left _ -> Nothing
Right t ->
case P.parseOnly (argsParser Escaping) t of
Right ("--":progName':rest) | progName' == progName -> Just rest
_ -> Nothing
stack-0.1.10.0/src/Data/Maybe/Extra.hs 0000644 0000000 0000000 00000001347 12623647202 015347 0 ustar 00 0000000 0000000 -- | Extra Maybe utilities.
module Data.Maybe.Extra where
import Control.Applicative
import Control.Monad
import Data.Traversable hiding (mapM)
import Data.Maybe
import Prelude -- Silence redundant import warnings
-- | Applicative 'mapMaybe'.
mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeA f = fmap catMaybes . traverse f
-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@
forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b]
forMaybeA = flip mapMaybeA
-- | Monadic 'mapMaybe'.
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f = liftM catMaybes . mapM f
-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@
forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM = flip mapMaybeM
stack-0.1.10.0/src/Path/IO.hs 0000644 0000000 0000000 00000024513 12623647202 013561 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
-- | IO actions that might be put in a package at some point.
module Path.IO
(getWorkingDir
,parseRelAsAbsDir
,parseRelAsAbsFile
,listDirectory
,resolveDir
,resolveFile
,resolveDirMaybe
,resolveFileMaybe
,ResolveException(..)
,removeFile
,removeFileIfExists
,removeTree
,removeTreeIfExists
,renameFile
,renameFileIfExists
,renameDir
,renameDirIfExists
,moveFile
,moveFileIfExists
,moveDir
,moveDirIfExists
,fileExists
,dirExists
,copyFile
,copyFileIfExists
,copyDirectoryRecursive
,createTree
,withCanonicalizedSystemTempDirectory
,withCanonicalizedTempDirectory)
where
import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Either
import Data.Maybe.Extra
import Data.Typeable
import Path
import qualified System.Directory as D
import qualified System.FilePath as FP
import System.IO.Error
import System.IO.Temp
data ResolveException
= ResolveDirFailed (Path Abs Dir) FilePath FilePath
| ResolveFileFailed (Path Abs Dir) FilePath FilePath
deriving Typeable
instance Exception ResolveException
instance Show ResolveException where
show (ResolveDirFailed _ _ z) = "Could not resolve directory " ++ z
show (ResolveFileFailed _ _ z) = "Could not resolve file " ++ z
-- | Get the current working directory.
getWorkingDir :: (MonadIO m) => m (Path Abs Dir)
getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)
-- | Parse a directory path. If it's relative, then the absolute version
-- is yielded, based off the working directory.
--
-- NOTE that this only works if the directory exists, but does not
-- ensure that it's a directory.
parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)
parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)
-- | Parse a file path. If it's relative, then the absolute version is
-- yielded, based off the working directory.
--
-- NOTE that this only works if the file exists, but does not ensure
-- that it's a file.
parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)
parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp)
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it.
resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)
resolveDir x y =
do result <- resolveDirMaybe x y
case result of
Nothing ->
throwM $ ResolveDirFailed x y fp
where fp = toFilePath x FP. y
Just fp -> return fp
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it.
resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs File)
resolveFile x y =
do result <- resolveFileMaybe x y
case result of
Nothing ->
throwM $
ResolveFileFailed x y fp
where fp = toFilePath x FP. y
Just fp -> return fp
-- Internal helper to define resolveDirMaybe and resolveFileMaybe in one
resolveCheckParse :: (MonadIO m)
=> (FilePath -> IO Bool) -- check if file/dir does exist
-> (FilePath -> m a) -- parse into absolute file/dir
-> Path Abs Dir
-> FilePath
-> m (Maybe a)
resolveCheckParse check parse x y = do
let fp = toFilePath x FP. y
exists <- liftIO $ check fp
if exists
then do
canonic <- liftIO $ D.canonicalizePath fp
liftM Just (parse canonic)
else return Nothing
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it. If the path doesn't exist (and therefore cannot
-- be canonicalized, 'Nothing' is returned).
resolveDirMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))
resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it. If the path doesn't exist (and therefore cannot
-- be canonicalized, 'Nothing' is returned).
resolveFileMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile
-- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted.
listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])
listDirectory dir =
do entriesFP <- liftIO (D.getDirectoryContents dirFP)
entries <-
forMaybeM (map (dirFP ++) entriesFP)
(\entryFP ->
do isDir <- liftIO (D.doesDirectoryExist entryFP)
if isDir
then case parseAbsDir entryFP of
Nothing -> return Nothing
Just entryDir ->
if dir `isParentOf` entryDir
then return (Just (Left entryDir))
else return Nothing
else case parseAbsFile entryFP of
Nothing -> return Nothing
Just entryFile -> return (Just (Right entryFile)))
return (lefts entries,rights entries)
where dirFP = toFilePath dir
-- | Remove a file. Bails out if it doesn't exist.
removeFile :: MonadIO m => Path b File -> m ()
removeFile = liftIO . D.removeFile . toFilePath
-- | Remove a file. Optimistically assumes it exists. If it doesn't,
-- doesn't complain.
removeFileIfExists :: MonadIO m => Path b File -> m ()
removeFileIfExists = ignoreDoesNotExist . removeFile
-- | Rename a file. Bails out if it doesn't exist.
renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to))
-- | Rename a file. Optimistically assumes it exists. If it doesn't,
-- doesn't complain.
renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)
renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))
-- | Rename a directory. Optimistically assumes it exists. If it
-- doesn't, doesn't complain.
renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
renameDirIfExists from to = ignoreDoesNotExist (renameDir from to)
-- | Make a directory tree, creating parents if needed.
createTree :: MonadIO m => Path b Dir -> m ()
createTree = liftIO . D.createDirectoryIfMissing True . toFilePath
-- | Move a file. Bails out if it doesn't exist.
moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
moveFile from to = renameFile from (to filename from)
-- | Move a file. Optimistically assumes it exists. If it doesn't,
-- doesn't complain.
moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
moveFileIfExists from to = ignoreDoesNotExist (moveFile from to)
-- | Move a dir. Bails out if it doesn't exist.
moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
moveDir from to = renameDir from (to dirname from)
-- | Move a dir. Optimistically assumes it exists. If it doesn't,
-- doesn't complain.
moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)
-- | Remove a tree. Bails out if it doesn't exist.
removeTree :: MonadIO m => Path b Dir -> m ()
removeTree = liftIO . D.removeDirectoryRecursive . toFilePath
-- | Remove tree, don't complain about non-existent directories.
removeTreeIfExists :: MonadIO m => Path b Dir -> m ()
removeTreeIfExists = ignoreDoesNotExist . removeTree
-- | Does the file exist?
fileExists :: MonadIO m => Path b File -> m Bool
fileExists = liftIO . D.doesFileExist . toFilePath
-- | Does the directory exist?
dirExists :: MonadIO m => Path b Dir -> m Bool
dirExists = liftIO . D.doesDirectoryExist . toFilePath
-- | Copies a file to another path. Bails out if it doesn't exist.
copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))
-- | Copies a file to another path. Optimistically assumes it exists. If
-- it doesn't, doesn't complain.
copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)
-- | Copy a directory recursively. This just uses 'copyFile', so it is not smart about symbolic
-- links or other special files.
copyDirectoryRecursive :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -- ^ Source directory
-> Path Abs Dir -- ^ Destination directory
-> m ()
copyDirectoryRecursive srcDir destDir =
do liftIO (D.createDirectoryIfMissing False (toFilePath destDir))
(srcSubDirs,srcFiles) <- listDirectory srcDir
forM_ srcFiles
(\srcFile ->
case stripDir srcDir srcFile of
Nothing -> return ()
Just relFile -> copyFile srcFile (destDir relFile))
forM_ srcSubDirs
(\srcSubDir ->
case stripDir srcDir srcSubDir of
Nothing -> return ()
Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir relSubDir))
-- Utility function for a common pattern of ignoring does-not-exist errors.
ignoreDoesNotExist :: MonadIO m => IO () -> m ()
ignoreDoesNotExist f =
liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)
withCanonicalizedSystemTempDirectory :: (MonadMask m, MonadIO m)
=> String -- ^ Directory name template.
-> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory
-> m a
withCanonicalizedSystemTempDirectory template action =
withSystemTempDirectory template (parseRelAsAbsDir >=> action)
withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m)
=> FilePath -- ^ Temp directory to create the directory in
-> String -- ^ Directory name template.
-> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory
-> m a
withCanonicalizedTempDirectory targetDir template action =
withTempDirectory targetDir template (parseRelAsAbsDir >=> action)
stack-0.1.10.0/src/Path/Extra.hs 0000644 0000000 0000000 00000004314 12623647202 014332 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
-- | Extra Path utilities.
module Path.Extra
(toFilePathNoTrailingSep
,dropRoot
,parseCollapsedAbsDir
,parseCollapsedAbsFile
) where
import Control.Monad.Catch
import Path
import Path.Internal (Path(..))
import qualified System.FilePath as FP
-- | Convert to FilePath but don't add a trailing slash.
toFilePathNoTrailingSep :: Path loc Dir -> FilePath
toFilePathNoTrailingSep = FP.dropTrailingPathSeparator . toFilePath
-- | Collapse intermediate "." and ".." directories from path, then parse
-- it with 'parseAbsDir'.
-- (probably should be moved to the Path module)
parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir)
parseCollapsedAbsDir = parseAbsDir . collapseFilePath
-- | Collapse intermediate "." and ".." directories from path, then parse
-- it with 'parseAbsFile'.
-- (probably should be moved to the Path module)
parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File)
parseCollapsedAbsFile = parseAbsFile . collapseFilePath
-- | Collapse intermediate "." and ".." directories from a path.
--
-- > collapseFilePath "./foo" == "foo"
-- > collapseFilePath "/bar/../baz" == "/baz"
-- > collapseFilePath "/../baz" == "/../baz"
-- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar"
-- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar"
-- > collapseFilePath "parent/foo/.." == "parent"
-- > collapseFilePath "/parent/foo/../../bar" == "/bar"
--
-- (borrowed from @Text.Pandoc.Shared@)
collapseFilePath :: FilePath -> FilePath
collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories
where
go rs "." = rs
go r@(p:rs) ".." = case p of
".." -> "..":r
(checkPathSeperator -> Just True) -> "..":r
_ -> rs
go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]]
go rs x = x:rs
isSingleton [] = Nothing
isSingleton [x] = Just x
isSingleton _ = Nothing
checkPathSeperator = fmap FP.isPathSeparator . isSingleton
-- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on
-- Windows).
dropRoot :: Path Abs t -> Path Rel t
dropRoot (Path l) = Path (FP.dropDrive l)
stack-0.1.10.0/src/Network/HTTP/Download.hs 0000644 0000000 0000000 00000014512 12623647202 016333 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Download
( verifiedDownload
, DownloadRequest(..)
, drRetryPolicyDefault
, HashCheck(..)
, DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
, download
, redownload
, downloadJSON
, parseUrl
, liftHTTP
, ask
, getHttpManager
, MonadReader
, HasHttpManager
) where
import Control.Exception (Exception)
import Control.Exception.Enclosed (handleIO)
import Control.Monad (void)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, ask,
runReaderT)
import Data.Aeson.Extended (FromJSON, parseJSON)
import Data.Aeson.Parser (json')
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Conduit (($$))
import Data.Conduit.Attoparsec (sinkParser)
import Data.Conduit.Binary (sinkHandle, sourceHandle)
import qualified Data.Conduit.Binary as CB
import Data.Foldable (forM_)
import Data.Typeable (Typeable)
import Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,
Response, checkStatus,
getHttpManager, parseUrl,
requestHeaders, responseBody,
responseHeaders, responseStatus,
withResponse)
import Network.HTTP.Download.Verified
import Network.HTTP.Types (status200, status304)
import Path (Abs, File, Path, toFilePath)
import System.Directory (createDirectoryIfMissing,
removeFile,
renameFile)
import System.FilePath (takeDirectory, (<.>))
import System.IO (IOMode (ReadMode),
IOMode (WriteMode),
withBinaryFile)
-- | Download the given URL to the given location. If the file already exists,
-- no download is performed. Otherwise, creates the parent directory, downloads
-- to a temporary file, and on file download completion moves to the
-- appropriate destination.
--
-- Throws an exception if things go wrong
download :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> Request
-> Path Abs File -- ^ destination
-> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
download req destpath = do
let downloadReq = DownloadRequest
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
, drRetryPolicy = drRetryPolicyDefault
}
let progressHook _ = return ()
verifiedDownload downloadReq destpath progressHook
-- | Same as 'download', but will download a file a second time if it is already present.
--
-- Returns 'True' if the file was downloaded, 'False' otherwise
redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> Request
-> Path Abs File -- ^ destination
-> m Bool
redownload req0 dest = do
let destFilePath = toFilePath dest
etagFilePath = destFilePath <.> "etag"
metag <- liftIO $ handleIO (const $ return Nothing) $ fmap Just $
withBinaryFile etagFilePath ReadMode $ \h ->
sourceHandle h $$ CB.take 512
let req1 =
case metag of
Nothing -> req0
Just etag -> req0
{ requestHeaders =
requestHeaders req0 ++
[("If-None-Match", L.toStrict etag)]
}
req2 = req1 { checkStatus = \_ _ _ -> Nothing }
env <- ask
liftIO $ flip runReaderT env $ withResponse req2 $ \res -> case () of
()
| responseStatus res == status200 -> liftIO $ do
createDirectoryIfMissing True $ takeDirectory destFilePath
-- Order here is important: first delete the etag, then write the
-- file, then write the etag. That way, if any step fails, it will
-- force the download to happen again.
handleIO (const $ return ()) $ removeFile etagFilePath
let destFilePathTmp = destFilePath <.> "tmp"
withBinaryFile destFilePathTmp WriteMode $ \h ->
responseBody res $$ sinkHandle h
renameFile destFilePathTmp destFilePath
forM_ (lookup "ETag" (responseHeaders res)) $ \e -> do
let tmp = etagFilePath <.> "tmp"
S.writeFile tmp e
renameFile tmp etagFilePath
return True
| responseStatus res == status304 -> return False
| otherwise -> throwM $ RedownloadFailed req2 dest $ void res
-- | Download a JSON value and parse it using a 'FromJSON' instance.
downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadThrow m)
=> Request
-> m a
downloadJSON req = do
val <- liftHTTP $ withResponse req $ \res ->
responseBody res $$ sinkParser json'
case parseEither parseJSON val of
Left e -> throwM $ DownloadJSONException req e
Right x -> return x
data DownloadException
= DownloadJSONException Request String
| RedownloadFailed Request (Path Abs File) (Response ())
deriving (Show, Typeable)
instance Exception DownloadException
-- | A convenience method for asking for the environment and then running an
-- action with its 'Manager'. Useful for avoiding a 'MonadBaseControl'
-- constraint.
liftHTTP :: (MonadIO m, MonadReader env m, HasHttpManager env)
=> ReaderT Manager IO a
-> m a
liftHTTP inner = do
env <- ask
liftIO $ runReaderT inner $ getHttpManager env
stack-0.1.10.0/src/Control/Concurrent/Execute.hs 0000644 0000000 0000000 00000011636 12623647202 017524 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
-- Concurrent execution with dependencies. Types currently hard-coded for needs
-- of stack, but could be generalized easily.
module Control.Concurrent.Execute
( ActionType (..)
, ActionId (..)
, ActionContext (..)
, Action (..)
, runActions
) where
import Control.Applicative
import Control.Concurrent.Async (Concurrently (..), async)
import Control.Concurrent.STM
import Control.Exception
import Control.Monad (join, unless)
import Data.Foldable (sequenceA_)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Prelude -- Fix AMP warning
import Stack.Types
data ActionType
= ATBuild
| ATBuildFinal
| ATFinal
deriving (Show, Eq, Ord)
data ActionId = ActionId !PackageIdentifier !ActionType
deriving (Show, Eq, Ord)
data Action = Action
{ actionId :: !ActionId
, actionDeps :: !(Set ActionId)
, actionDo :: !(ActionContext -> IO ())
}
data ActionContext = ActionContext
{ acRemaining :: !(Set ActionId)
-- ^ Does not include the current action
}
deriving Show
data ExecuteState = ExecuteState
{ esActions :: TVar [Action]
, esExceptions :: TVar [SomeException]
, esInAction :: TVar (Set ActionId)
, esCompleted :: TVar Int
, esFinalLock :: Maybe (TMVar ())
, esKeepGoing :: Bool
}
data ExecuteException
= InconsistentDependencies
deriving Typeable
instance Exception ExecuteException
instance Show ExecuteException where
show InconsistentDependencies =
"Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team."
runActions :: Int -- ^ threads
-> Bool -- ^ keep going after one task has failed
-> Bool -- ^ run final actions concurrently?
-> [Action]
-> (TVar Int -> IO ()) -- ^ progress updated
-> IO [SomeException]
runActions threads keepGoing concurrentFinal actions0 withProgress = do
es <- ExecuteState
<$> newTVarIO actions0
<*> newTVarIO []
<*> newTVarIO Set.empty
<*> newTVarIO 0
<*> (if concurrentFinal
then pure Nothing
else Just <$> atomically (newTMVar ()))
<*> pure keepGoing
_ <- async $ withProgress $ esCompleted es
if threads <= 1
then runActions' es
else runConcurrently $ sequenceA_ $ replicate threads $ Concurrently $ runActions' es
readTVarIO $ esExceptions es
runActions' :: ExecuteState -> IO ()
runActions' ExecuteState {..} =
loop
where
breakOnErrs inner = do
errs <- readTVar esExceptions
if null errs || esKeepGoing
then inner
else return $ return ()
withActions inner = do
as <- readTVar esActions
if null as
then return $ return ()
else inner as
loop = join $ atomically $ breakOnErrs $ withActions $ \as ->
case break (Set.null . actionDeps) as of
(_, []) -> do
inAction <- readTVar esInAction
if Set.null inAction
then do
unless esKeepGoing $
modifyTVar esExceptions (toException InconsistentDependencies:)
return $ return ()
else retry
(xs, action:ys) -> do
unlock <-
case (actionId action, esFinalLock) of
(ActionId _ ATFinal, Just lock) -> do
takeTMVar lock
return $ putTMVar lock ()
_ -> return $ return ()
let as' = xs ++ ys
inAction <- readTVar esInAction
let remaining = Set.union
(Set.fromList $ map actionId as')
inAction
writeTVar esActions as'
modifyTVar esInAction (Set.insert $ actionId action)
return $ mask $ \restore -> do
eres <- try $ restore $ actionDo action ActionContext
{ acRemaining = remaining
}
atomically $ do
unlock
modifyTVar esInAction (Set.delete $ actionId action)
modifyTVar esCompleted (+1)
case eres of
Left err -> modifyTVar esExceptions (err:)
Right () ->
let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }
in modifyTVar esActions $ map dropDep
restore loop
stack-0.1.10.0/src/Path/Find.hs 0000644 0000000 0000000 00000005455 12623647202 014136 0 ustar 00 0000000 0000000 {-# LANGUAGE DataKinds #-}
-- | Finding files.
module Path.Find
(findFileUp
,findDirUp
,findFiles)
where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import System.IO.Error (isPermissionError)
import Data.List
import Path
import Path.IO
-- | Find the location of a file matching the given predicate.
findFileUp :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -- ^ Start here.
-> (Path Abs File -> Bool) -- ^ Predicate to match the file.
-> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.
-> m (Maybe (Path Abs File)) -- ^ Absolute file path.
findFileUp = findPathUp snd
-- | Find the location of a directory matching the given predicate.
findDirUp :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -- ^ Start here.
-> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory.
-> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.
-> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path.
findDirUp = findPathUp fst
-- | Find the location of a path matching the given predicate.
findPathUp :: (MonadIO m,MonadThrow m)
=> (([Path Abs Dir],[Path Abs File]) -> [Path Abs t])
-- ^ Choose path type from pair.
-> Path Abs Dir -- ^ Start here.
-> (Path Abs t -> Bool) -- ^ Predicate to match the path.
-> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.
-> m (Maybe (Path Abs t)) -- ^ Absolute path.
findPathUp pathType dir p upperBound =
do entries <- listDirectory dir
case find p (pathType entries) of
Just path -> return (Just path)
Nothing | Just dir == upperBound -> return Nothing
| parent dir == dir -> return Nothing
| otherwise -> findPathUp pathType (parent dir) p upperBound
-- | Find files matching predicate below a root directory.
findFiles :: Path Abs Dir -- ^ Root directory to begin with.
-> (Path Abs File -> Bool) -- ^ Predicate to match files.
-> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse.
-> IO [Path Abs File] -- ^ List of matching files.
findFiles dir p traversep =
do (dirs,files) <- catchJust (\ e -> if isPermissionError e
then Just ()
else Nothing)
(listDirectory dir)
(\ _ -> return ([], []))
subResults <-
forM dirs
(\entry ->
if traversep entry
then findFiles entry p traversep
else return [])
return (concat (filter p files : subResults))
stack-0.1.10.0/src/System/Process/PagerEditor.hs 0000644 0000000 0000000 00000011670 12623647202 017465 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}
-- | Run external pagers (@$PAGER@, @less@, @more@) and editors (@$VISUAL@,
-- @$EDITOR@, @nano@, @pico@, @vi@).
module System.Process.PagerEditor
(-- * Pager
pageWriter
,pageByteString
,pageBuilder
,pageFile
,pageString
,PagerException(..)
-- * Editor
,editFile
,editReaderWriter
,editByteString
,editString
,EditorException(..))
where
import Control.Exception (try,IOException,throwIO,Exception)
import Data.ByteString.Lazy (ByteString,hPut,readFile)
import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder)
import Data.Typeable (Typeable)
import System.Directory (findExecutable)
import System.Environment (lookupEnv)
import System.Exit (ExitCode(..))
import System.FilePath (())
import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe)
,CreateProcess(std_in, close_fds, delegate_ctlc))
import System.IO (hClose,Handle,hPutStr,readFile,withFile,IOMode(WriteMode),stdout)
import System.IO.Temp (withSystemTempDirectory)
-- | Run pager, providing a function that writes to the pager's input.
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter writer =
do mpager <- lookupEnv "PAGER" `orElse`
findExecutable "less" `orElse`
findExecutable "more"
case mpager of
Just pager ->
do (Just h,_,_,procHandle) <- createProcess (shell pager)
{std_in = CreatePipe
,close_fds = True
,delegate_ctlc = True}
(_::Either IOException ()) <- try (do writer h
hClose h)
exit <- waitForProcess procHandle
case exit of
ExitSuccess -> return ()
ExitFailure n -> throwIO (PagerExitFailure pager n)
return ()
Nothing -> writer stdout
-- | Run pager to display a lazy ByteString.
pageByteString :: ByteString -> IO ()
pageByteString = pageWriter . flip hPut
-- | Run pager to display a ByteString-Builder.
pageBuilder :: Builder -> IO ()
pageBuilder = pageWriter . flip hPutBuilder
-- | Run pager to display contents of a file.
pageFile :: FilePath -> IO ()
pageFile p = pageByteString =<< Data.ByteString.Lazy.readFile p
-- | Run pager to display a string.
pageString :: String -> IO ()
pageString = pageBuilder . stringUtf8
-- | Run editor to edit a file.
editFile :: FilePath -> IO ()
editFile path =
do meditor <- lookupEnv "VISUAL" `orElse`
lookupEnv "EDITOR" `orElse`
findExecutable "nano" `orElse`
findExecutable "pico" `orElse`
findExecutable "vi"
case meditor of
Just editor ->
do (_,_,_,procHandle) <- createProcess (proc "sh" ["-c", editor ++ " \"$1\"", "sh", path])
{close_fds = True,delegate_ctlc = True}
exitCode <- waitForProcess procHandle
case exitCode of
ExitSuccess -> return ()
ExitFailure n -> throwIO (EditorExitFailure editor n)
Nothing -> throwIO EditorNotFound
-- | Run editor, providing functions to write and read the file contents.
editReaderWriter :: forall a. String -> (Handle -> IO ()) -> (FilePath -> IO a) -> IO a
editReaderWriter filename writer reader =
withSystemTempDirectory ""
(\p -> do let p' = p filename
withFile p' WriteMode writer
editFile p'
reader p')
-- | Run editor on a ByteString.
editByteString :: String -> ByteString -> IO ByteString
editByteString f s = editReaderWriter f (`hPut` s) Data.ByteString.Lazy.readFile
-- | Run editor on a String.
editString :: String -> String -> IO String
editString f s = editReaderWriter f (`hPutStr` s) System.IO.readFile
-- | Short-circuit first Just.
orElse :: (Monad m) => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElse a b = do m <- a
case m of
Just _ -> return m
Nothing -> b
-- | Exception running pager.
data PagerException = PagerNotFound
| PagerExitFailure FilePath Int
deriving Typeable
instance Show PagerException where
show PagerNotFound = "No pager found (tried $PAGER, `less`, and `more`.)"
show (PagerExitFailure p n) = "Pager (`" ++ p ++ "') exited with non-zero status: " ++ show n
instance Exception PagerException
-- | Exception running editor.
data EditorException = EditorNotFound
| EditorExitFailure FilePath Int
deriving Typeable
instance Show EditorException where
show EditorNotFound = "No editor found (tried $VISUAL, $PAGER, `nano`, `pico`, and `vi`.)"
show (EditorExitFailure p n) = "Editor (`" ++ p ++ "') exited with non-zero status: " ++ show n
instance Exception EditorException
stack-0.1.10.0/src/Data/Aeson/Extended.hs 0000644 0000000 0000000 00000012041 12623647202 016025 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}
-- | Extensions to Aeson parsing of objects.
module Data.Aeson.Extended (
module Export
-- * Extended failure messages
, (.:)
, (.:?)
-- * JSON Parser that emits warnings
, WarningParser
, JSONWarning (..)
, withObjectWarnings
, jsonSubWarnings
, jsonSubWarningsT
, jsonSubWarningsTT
, logJSONWarnings
, tellJSONField
, unWarningParser
, (..:)
, (..:?)
, (..!=)
) where
import Control.Monad.Logger (MonadLogger, logWarn)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
import Data.Aeson as Export hiding ((.:), (.:?))
import qualified Data.Aeson as A
import Data.Aeson.Types hiding ((.:), (.:?))
import qualified Data.HashMap.Strict as HashMap
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (unpack, Text)
import qualified Data.Text as T
import Data.Traversable
import qualified Data.Traversable as Traversable
import Prelude -- Fix redundant import warnings
-- | Extends @.:@ warning to include field name.
(.:) :: FromJSON a => Object -> Text -> Parser a
(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
{-# INLINE (.:) #-}
-- | Extends @.:?@ warning to include field name.
(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
{-# INLINE (.:?) #-}
-- | 'WarningParser' version of @.:@.
(..:)
:: FromJSON a
=> Object -> Text -> WarningParser a
o ..: k = tellJSONField k >> lift (o .: k)
-- | 'WarningParser' version of @.:?@.
(..:?)
:: FromJSON a
=> Object -> Text -> WarningParser (Maybe a)
o ..:? k = tellJSONField k >> lift (o .:? k)
-- | 'WarningParser' version of @.!=@.
(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
wp ..!= d =
flip mapWriterT wp $
\p ->
do a <- fmap snd p
fmap (, a) (fmap fst p .!= d)
-- | Tell warning parser about an expected field, so it doesn't warn about it.
tellJSONField :: Text -> WarningParser ()
tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
-- | 'WarningParser' version of 'withObject'.
withObjectWarnings :: String
-> (Object -> WarningParser a)
-> Value
-> Parser (a, [JSONWarning])
withObjectWarnings expected f =
withObject expected $
\obj ->
do (a,w) <- runWriterT (f obj)
let unrecognizedFields =
Set.toList
(Set.difference
(Set.fromList (HashMap.keys obj))
(wpmExpectedFields w))
return
( a
, wpmWarnings w ++
case unrecognizedFields of
[] -> []
_ -> [JSONUnrecognizedFields expected unrecognizedFields])
-- | Convert a 'WarningParser' to a 'Parser'.
unWarningParser :: WarningParser a -> Parser a
unWarningParser wp = do
(a,_) <- runWriterT wp
return a
-- | Log JSON warnings.
logJSONWarnings
:: MonadLogger m
=> FilePath -> [JSONWarning] -> m ()
logJSONWarnings fp =
mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w)))
-- | Handle warnings in a sub-object.
jsonSubWarnings :: WarningParser (a, [JSONWarning]) -> WarningParser a
jsonSubWarnings f = do
(result,warnings) <- f
tell
(mempty
{ wpmWarnings = warnings
})
return result
-- | Handle warnings in a @Traversable@ of sub-objects.
jsonSubWarningsT
:: Traversable t
=> WarningParser (t (a, [JSONWarning])) -> WarningParser (t a)
jsonSubWarningsT f =
Traversable.mapM (jsonSubWarnings . return) =<< f
-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
jsonSubWarningsTT
:: (Traversable t, Traversable u)
=> WarningParser (u (t (a, [JSONWarning])))
-> WarningParser (u (t a))
jsonSubWarningsTT f =
Traversable.mapM (jsonSubWarningsT . return) =<< f
-- | JSON parser that warns about unexpected fields in objects.
type WarningParser a = WriterT WarningParserMonoid Parser a
-- | Monoid used by 'WarningParser' to track expected fields and warnings.
data WarningParserMonoid = WarningParserMonoid
{ wpmExpectedFields :: !(Set Text)
, wpmWarnings :: [JSONWarning]
}
instance Monoid WarningParserMonoid where
mempty = WarningParserMonoid Set.empty []
mappend a b =
WarningParserMonoid
{ wpmExpectedFields = Set.union
(wpmExpectedFields a)
(wpmExpectedFields b)
, wpmWarnings = wpmWarnings a ++ wpmWarnings b
}
-- | Warning output from 'WarningParser'.
data JSONWarning = JSONUnrecognizedFields String [Text]
instance Show JSONWarning where
show (JSONUnrecognizedFields obj [field]) =
"Unrecognized field in " <> obj <> ": " <> T.unpack field
show (JSONUnrecognizedFields obj fields) =
"Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)
stack-0.1.10.0/src/Data/Attoparsec/Combinators.hs 0000644 0000000 0000000 00000001146 12546477354 017626 0 ustar 00 0000000 0000000 -- | More readable combinators for writing parsers.
module Data.Attoparsec.Combinators where
import Control.Applicative
import Data.Monoid
-- | Concatenate two parsers.
appending :: (Applicative f,Monoid a)
=> f a -> f a -> f a
appending a b = (<>) <$> a <*> b
-- | Alternative parsers.
alternating :: Alternative f
=> f a -> f a -> f a
alternating a b = a <|> b
-- | Pure something.
pured :: (Applicative g,Applicative f) => g a -> g (f a)
pured = fmap pure
-- | Concatting the result of an action.
concating :: (Monoid m,Applicative f) => f [m] -> f m
concating = fmap mconcat
stack-0.1.10.0/src/Data/Binary/VersionTagged.hs 0000644 0000000 0000000 00000006046 12623647202 017215 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
-- | Tag a Binary instance with the stack version number to ensure we're
-- reading a compatible format.
module Data.Binary.VersionTagged
( taggedDecodeOrLoad
, taggedEncodeFile
, Binary (..)
, BinarySchema
, HasStructuralInfo
, HasSemanticVersion
, decodeFileOrFailDeep
, NFData (..)
) where
import Control.DeepSeq (NFData (..))
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Data.Binary (Binary (..))
import Data.Binary.Get (ByteOffset)
import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)
import qualified Data.Binary.Tagged as BinaryTagged
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import Control.Exception.Enclosed (tryAnyDeep)
import Path
import Path.IO (createTree)
import qualified Data.Text as T
type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)
-- | Write to the given file, with a binary-tagged tag.
taggedEncodeFile :: (BinarySchema a, MonadIO m)
=> Path Abs File
-> a
-> m ()
taggedEncodeFile fp x = liftIO $ do
createTree (parent fp)
BinaryTagged.taggedEncodeFile (toFilePath fp) x
-- | Read from the given file. If the read fails, run the given action and
-- write that back to the file. Always starts the file off with the version
-- tag.
taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m)
=> Path Abs File
-> m a
-> m a
taggedDecodeOrLoad fp mx = do
let fpt = T.pack (toFilePath fp)
$logDebug $ "Trying to decode " <> fpt
eres <- decodeFileOrFailDeep fp
case eres of
Left _ -> do
$logDebug $ "Failure decoding " <> fpt
x <- mx
taggedEncodeFile fp x
return x
Right x -> do
$logDebug $ "Success decoding " <> fpt
return x
-- | Ensure that there are no lurking exceptions deep inside the parsed
-- value... because that happens unfortunately. See
-- https://github.com/commercialhaskell/stack/issues/554
decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n)
=> Path loc File
-> m (n a)
decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do
eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp)
case eres of
Left (offset, str) -> throwM $ DecodeFileFailure (toFilePath fp) offset str
Right x -> return x
data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String
deriving Typeable
instance Show DecodeFileFailure where
show (DecodeFileFailure fp offset str) = concat
[ "Decoding of "
, fp
, " failed at offset "
, show offset
, ": "
, str
]
instance Exception DecodeFileFailure
stack-0.1.10.0/src/Data/IORef/RunOnce.hs 0000644 0000000 0000000 00000000647 12571621073 015546 0 ustar 00 0000000 0000000 module Data.IORef.RunOnce (runOnce) where
import Control.Monad.IO.Class
import Data.IORef
runOnce :: MonadIO m => m a -> m (m a)
runOnce f = do
ref <- liftIO $ newIORef Nothing
return $ do
mval <- liftIO $ readIORef ref
case mval of
Just val -> return val
Nothing -> do
val <- f
liftIO $ writeIORef ref (Just val)
return val
stack-0.1.10.0/src/Data/Set/Monad.hs 0000644 0000000 0000000 00000001376 12546477354 015037 0 ustar 00 0000000 0000000 -- | Monadic operations for 'Set'.
module Data.Set.Monad
(mapM
,mapM_
,filterM)
where
import Control.Monad (liftM)
import qualified Control.Monad as L
import Data.Set (Set)
import qualified Data.Set as S
import Prelude hiding (mapM,mapM_)
-- | Map over a 'Set' in a monad.
mapM :: (Ord a,Ord b,Monad m)
=> (a -> m b) -> Set a -> m (Set b)
mapM f = liftM S.fromList . L.mapM f . S.toList
-- | Map over a 'Set' in a monad, discarding the result.
mapM_ :: (Ord a,Ord b,Monad m)
=> (a -> m b) -> Set a -> m ()
mapM_ f = L.mapM_ f . S.toList
-- | Filter elements of a 'Set' in a monad.
filterM :: (Ord a,Monad m)
=> (a -> m Bool) -> Set a -> m (Set a)
filterM f = liftM S.fromList . L.filterM f . S.toList
stack-0.1.10.0/src/Distribution/Version/Extra.hs 0000644 0000000 0000000 00000002105 12601012655 017530 0 ustar 00 0000000 0000000 -- A separate module so that we can contain all usage of deprecated identifiers here
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Distribution.Version.Extra
( hasUpper
, hasLower
) where
import Distribution.Version (VersionRange (..))
-- | Does the version range have an upper bound?
hasUpper :: VersionRange -> Bool
hasUpper AnyVersion = False
hasUpper (ThisVersion _) = True
hasUpper (LaterVersion _) = False
hasUpper (EarlierVersion _) = True
hasUpper (WildcardVersion _) = True
hasUpper (UnionVersionRanges x y) = hasUpper x && hasUpper y
hasUpper (IntersectVersionRanges x y) = hasUpper x || hasUpper y
hasUpper (VersionRangeParens x) = hasUpper x
-- | Does the version range have a lower bound?
hasLower :: VersionRange -> Bool
hasLower AnyVersion = False
hasLower (ThisVersion _) = True
hasLower (LaterVersion _) = True
hasLower (EarlierVersion _) = False
hasLower (WildcardVersion _) = True
hasLower (UnionVersionRanges x y) = hasLower x && hasLower y
hasLower (IntersectVersionRanges x y) = hasLower x || hasLower y
hasLower (VersionRangeParens x) = hasLower x
stack-0.1.10.0/src/main/Main.hs 0000644 0000000 0000000 00000143525 12630352213 014164 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-- | Main stack tool entry point.
module Main (main) where
import Control.Exception
import qualified Control.Exception.Lifted as EL
import Control.Monad hiding (mapM, forM)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (ask, asks, runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Attoparsec.Args (withInterpreterArgs, parseArgs, EscapingMode (Escaping))
import qualified Data.ByteString.Lazy as L
import Data.IORef
import Data.List
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Maybe.Extra (mapMaybeA)
import Data.Monoid
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Traversable
import Data.Typeable (Typeable)
import Data.Version (showVersion)
#ifdef USE_GIT_INFO
import Development.GitRev (gitCommitCount, gitHash)
#endif
import Distribution.System (buildArch, buildPlatform)
import Distribution.Text (display)
import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
import Network.HTTP.Client
import Options.Applicative
import Options.Applicative.Args
import Options.Applicative.Builder.Extra
import Options.Applicative.Complicated
#ifdef USE_GIT_INFO
import Options.Applicative.Simple (simpleVersion)
#endif
import Options.Applicative.Types (readerAsk)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import qualified Paths_stack as Meta
import Prelude hiding (pi, mapM)
import Stack.Build
import Stack.Clean (CleanOpts, clean)
import Stack.Config
import Stack.ConfigCmd as ConfigCmd
import Stack.Constants
import Stack.Coverage
import qualified Stack.Docker as Docker
import Stack.Dot
import Stack.Exec
import qualified Stack.Nix as Nix
import Stack.Fetch
import Stack.FileWatch
import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath)
import Stack.Ghci
import Stack.Ide
import qualified Stack.Image as Image
import Stack.Init
import Stack.New
import Stack.Options
import Stack.Package (getCabalFileName)
import qualified Stack.PackageIndex
import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball')
import Stack.Setup
import qualified Stack.Sig as Sig
import Stack.Solver (solveExtraDeps)
import Stack.Types
import Stack.Types.Internal
import Stack.Types.StackT
import Stack.Upgrade
import qualified Stack.Upload as Upload
import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing)
import qualified System.Directory as Directory (findExecutable)
import System.Environment (getEnvironment, getProgName)
import System.Exit
import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)
import System.FilePath (searchPathSeparator)
import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding)
import System.Process.Read
-- | Change the character encoding of the given Handle to transliterate
-- on unsupported characters instead of throwing an exception
hSetTranslit :: Handle -> IO ()
hSetTranslit h = do
menc <- hGetEncoding h
case fmap textEncodingName menc of
Just name
| '/' `notElem` name -> do
enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
hSetEncoding h enc'
_ -> return ()
-- | Commandline dispatcher.
main :: IO ()
main = withInterpreterArgs stackProgName $ \args isInterpreter -> do
-- Line buffer the output by default, particularly for non-terminal runs.
-- See https://github.com/commercialhaskell/stack/pull/360
hSetBuffering stdout LineBuffering
hSetBuffering stdin LineBuffering
hSetBuffering stderr LineBuffering
hSetTranslit stdout
hSetTranslit stderr
progName <- getProgName
isTerminal <- hIsTerminalDevice stdout
execExtraHelp args
dockerHelpOptName
(dockerOptsParser False)
("Only showing --" ++ Docker.dockerCmdName ++ "* options.")
execExtraHelp args
nixHelpOptName
(nixOptsParser False)
("Only showing --" ++ Nix.nixCmdName ++ "* options.")
#ifdef USE_GIT_INFO
let commitCount = $gitCommitCount
versionString' = concat $ concat
[ [$(simpleVersion Meta.version)]
-- Leave out number of commits for --depth=1 clone
-- See https://github.com/commercialhaskell/stack/issues/792
, [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&
commitCount /= ("UNKNOWN" :: String)]
, [" ", display buildArch]
]
#else
let versionString' = showVersion Meta.version ++ ' ' : display buildArch
#endif
let globalOpts hide =
extraHelpOption hide progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*>
extraHelpOption hide progName (Nix.nixCmdName ++ "*") nixHelpOptName <*>
globalOptsParser hide
addCommand' cmd title footerStr constr =
addCommand cmd title footerStr constr (globalOpts True)
addSubCommands' cmd title footerStr =
addSubCommands cmd title footerStr (globalOpts True)
eGlobalRun <- try $
complicatedOptions
Meta.version
(Just versionString')
"stack - The Haskell Tool Stack"
""
(globalOpts False)
-- when there's a parse failure
(Just $ \f as ->
-- fall-through to external executables in `git` style if they exist
-- (i.e. `stack something` looks for `stack-something` before
-- failing with "Invalid argument `something'")
case stripPrefix "Invalid argument" (fst (renderFailure f "")) of
Just _ -> do
mExternalExec <- Directory.findExecutable ("stack-" ++ head as)
case mExternalExec of
Just ex -> do
menv <- getEnvOverride buildPlatform
runNoLoggingT (exec menv ex (tail as))
Nothing -> handleParseResult (Failure f)
Nothing -> handleParseResult (Failure f)
)
(do addCommand' "build"
"Build the package(s) in this directory/configuration"
cmdFooter
buildCmd
(buildOptsParser Build)
addCommand' "install"
"Shortcut for 'build --copy-bins'"
cmdFooter
buildCmd
(buildOptsParser Install)
addCommand' "uninstall"
"DEPRECATED: This command performs no actions, and is present for documentation only"
cmdFooter
uninstallCmd
(many $ strArgument $ metavar "IGNORED")
addCommand' "test"
"Shortcut for 'build --test'"
cmdFooter
buildCmd
(buildOptsParser Test)
addCommand' "bench"
"Shortcut for 'build --bench'"
cmdFooter
buildCmd
(buildOptsParser Bench)
addCommand' "haddock"
"Shortcut for 'build --haddock'"
cmdFooter
buildCmd
(buildOptsParser Haddock)
addCommand' "new"
"Create a new project from a template. Run `stack templates' to see available templates."
cmdFooter
newCmd
newOptsParser
addCommand' "templates"
"List the templates available for `stack new'."
cmdFooter
templatesCmd
(pure ())
addCommand' "init"
"Initialize a stack project based on one or more cabal packages"
cmdFooter
initCmd
initOptsParser
addCommand' "solver"
"Use a dependency solver to try and determine missing extra-deps"
cmdFooter
solverCmd
solverOptsParser
addCommand' "setup"
"Get the appropriate GHC for your project"
cmdFooter
setupCmd
setupParser
addCommand' "path"
"Print out handy path information"
cmdFooter
pathCmd
(mapMaybeA
(\(desc,name,_) ->
flag Nothing
(Just name)
(long (T.unpack name) <>
help desc))
paths)
addCommand' "unpack"
"Unpack one or more packages locally"
cmdFooter
unpackCmd
(some $ strArgument $ metavar "PACKAGE")
addCommand' "update"
"Update the package index"
cmdFooter
updateCmd
(pure ())
addCommand' "upgrade"
"Upgrade to the latest stack (experimental)"
cmdFooter
upgradeCmd
((,) <$> switch
( long "git"
<> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
<*> strOption
( long "git-repo"
<> help "Clone from specified git repository"
<> value "https://github.com/commercialhaskell/stack"
<> showDefault ))
addCommand' "upload"
"Upload a package to Hackage"
cmdFooter
uploadCmd
((,,,)
<$> many (strArgument $ metavar "TARBALL/DIR")
<*> optional pvpBoundsOption
<*> ignoreCheckSwitch
<*> flag False True
(long "sign" <>
help "GPG sign & submit signature"))
addCommand' "sdist"
"Create source distribution tarballs"
cmdFooter
sdistCmd
((,,)
<$> many (strArgument $ metavar "DIR")
<*> optional pvpBoundsOption
<*> ignoreCheckSwitch)
addCommand' "dot"
"Visualize your project's dependency graph using Graphviz dot"
cmdFooter
dotCmd
dotOptsParser
addCommand' "exec"
"Execute a command"
cmdFooter
execCmd
(execOptsParser Nothing)
addCommand' "ghc"
"Run ghc"
cmdFooter
execCmd
(execOptsParser $ Just ExecGhc)
addCommand' "ghci"
"Run ghci in the context of package(s) (experimental)"
cmdFooter
ghciCmd
ghciOptsParser
addCommand' "repl"
"Run ghci in the context of package(s) (experimental) (alias for 'ghci')"
cmdFooter
ghciCmd
ghciOptsParser
addCommand' "runghc"
"Run runghc"
cmdFooter
execCmd
(execOptsParser $ Just ExecRunGhc)
addCommand' "runhaskell"
"Run runghc (alias for 'runghc')"
cmdFooter
execCmd
(execOptsParser $ Just ExecRunGhc)
addCommand' "eval"
"Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"
cmdFooter
evalCmd
(evalOptsParser "CODE")
addCommand' "clean"
"Clean the local packages"
cmdFooter
cleanCmd
cleanOptsParser
addCommand' "list-dependencies"
"List the dependencies"
cmdFooter
listDependenciesCmd
(textOption (long "separator" <>
metavar "SEP" <>
help ("Separator between package name " <>
"and package version.") <>
value " " <>
showDefault))
addCommand' "query"
"Query general build information (experimental)"
cmdFooter
queryCmd
(many $ strArgument $ metavar "SELECTOR...")
addSubCommands'
"ide"
"IDE-specific commands"
cmdFooter
(do addCommand'
"start"
"Start the ide-backend service"
cmdFooter
ideCmd
((,) <$> many (textArgument
(metavar "TARGET" <>
help ("If none specified, use all " <>
"packages defined in current directory")))
<*> argsOption (long "ghc-options" <>
metavar "OPTION" <>
help "Additional options passed to GHCi" <>
value []))
addCommand'
"packages"
"List all available local loadable packages"
cmdFooter
packagesCmd
(pure ())
addCommand'
"load-targets"
"List all load targets for a package target"
cmdFooter
targetsCmd
(textArgument
(metavar "TARGET")))
addSubCommands'
Docker.dockerCmdName
"Subcommands specific to Docker use"
cmdFooter
(do addCommand' Docker.dockerPullCmdName
"Pull latest version of Docker image from registry"
cmdFooter
dockerPullCmd
(pure ())
addCommand' "reset"
"Reset the Docker sandbox"
cmdFooter
dockerResetCmd
(switch (long "keep-home" <>
help "Do not delete sandbox's home directory"))
addCommand' Docker.dockerCleanupCmdName
"Clean up Docker images and containers"
cmdFooter
dockerCleanupCmd
dockerCleanupOptsParser)
addSubCommands'
ConfigCmd.cfgCmdName
"Subcommands specific to modifying stack.yaml files"
cmdFooter
(addCommand' ConfigCmd.cfgCmdSetName
"Sets a field in the project's stack.yaml to value"
cmdFooter
cfgSetCmd
configCmdSetParser)
addSubCommands'
Image.imgCmdName
"Subcommands specific to imaging (EXPERIMENTAL)"
cmdFooter
(addCommand' Image.imgDockerCmdName
"Build a Docker image for the project"
cmdFooter
imgDockerCmd
(boolFlags True
"build"
"building the project before creating the container"
idm))
addSubCommands'
"hpc"
"Subcommands specific to Haskell Program Coverage"
cmdFooter
(addCommand' "report"
"Generate HPC report a combined HPC report"
cmdFooter
hpcReportCmd
hpcReportOptsParser)
addSubCommands'
Sig.sigCmdName
"Subcommands specific to package signatures (EXPERIMENTAL)"
cmdFooter
(addSubCommands'
Sig.sigSignCmdName
"Sign a a single package or all your packages"
cmdFooter
(addCommand'
Sig.sigSignSdistCmdName
"Sign a single sdist package file"
cmdFooter
sigSignSdistCmd
Sig.sigSignSdistOpts)))
case eGlobalRun of
Left (exitCode :: ExitCode) -> do
when isInterpreter $
hPutStrLn stderr $ concat
[ "\nIf you are trying to use "
, stackProgName
, " as a script interpreter, a\n'-- "
, stackProgName
, " [options] runghc [options]' comment is required."
, "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/GUIDE.md#ghcrunghc" ]
throwIO exitCode
Right (globalMonoid,run) -> do
let global = globalOptsFromMonoid isTerminal globalMonoid
when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'
case globalReExecVersion global of
Just expectVersion
| expectVersion /= showVersion Meta.version ->
throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
_ -> return ()
run global `catch` \e ->
-- This special handler stops "stack: " from being printed before the
-- exception
case fromException e of
Just ec -> exitWith ec
Nothing -> do
printExceptionStderr e
exitFailure
where
ignoreCheckSwitch = switch (long "ignore-check" <> help "Do not check package for common mistakes")
dockerHelpOptName = Docker.dockerCmdName ++ "-help"
nixHelpOptName = Nix.nixCmdName ++ "-help"
cmdFooter = "Run 'stack --help' for global options that apply to all subcommands."
-- | Print out useful path information in a human-readable format (and
-- support others later).
pathCmd :: [Text] -> GlobalOpts -> IO ()
pathCmd keys go =
withBuildConfig
go
(do env <- ask
let cfg = envConfig env
bc = envConfigBuildConfig cfg
-- This is the modified 'bin-path',
-- including the local GHC or MSYS if not configured to operate on
-- global GHC.
-- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.
-- So it's not the *minimal* override path.
menv <- getMinimalEnvOverride
snap <- packageDatabaseDeps
local <- packageDatabaseLocal
extra <- packageDatabaseExtra
global <- getGlobalDB menv =<< getWhichCompiler
snaproot <- installationRootDeps
localroot <- installationRootLocal
distDir <- distRelativeDir
hpcDir <- hpcReportDir
forM_
-- filter the chosen paths in flags (keys),
-- or show all of them if no specific paths chosen.
(filter
(\(_,key,_) ->
null keys || elem key keys)
paths)
(\(_,key,path) ->
liftIO $ T.putStrLn
-- If a single path type is requested, output it directly.
-- Otherwise, name all the paths.
((if length keys == 1
then ""
else key <> ": ") <>
path
(PathInfo
bc
menv
snap
local
global
snaproot
localroot
distDir
hpcDir
extra))))
-- | Passed to all the path printers as a source of info.
data PathInfo = PathInfo
{ piBuildConfig :: BuildConfig
, piEnvOverride :: EnvOverride
, piSnapDb :: Path Abs Dir
, piLocalDb :: Path Abs Dir
, piGlobalDb :: Path Abs Dir
, piSnapRoot :: Path Abs Dir
, piLocalRoot :: Path Abs Dir
, piDistDir :: Path Rel Dir
, piHpcDir :: Path Abs Dir
, piExtraDbs :: [Path Abs Dir]
}
-- | The paths of interest to a user. The first tuple string is used
-- for a description that the optparse flag uses, and the second
-- string as a machine-readable key and also for @--foo@ flags. The user
-- can choose a specific path to list like @--global-stack-root@. But
-- really it's mainly for the documentation aspect.
--
-- When printing output we generate @PathInfo@ and pass it to the
-- function to generate an appropriate string. Trailing slashes are
-- removed, see #506
paths :: [(String, Text, PathInfo -> Text)]
paths =
[ ( "Global stack root directory"
, "global-stack-root"
, T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
, ( "Project root (derived from stack.yaml file)"
, "project-root"
, T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig )
, ( "Configuration location (where the stack.yaml file is)"
, "config-location"
, T.pack . toFilePath . bcStackYaml . piBuildConfig )
, ( "PATH environment variable"
, "bin-path"
, T.pack . intercalate [searchPathSeparator] . eoPath . piEnvOverride )
, ( "Installed GHCs (unpacked and archives)"
, "ghc-paths"
, T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )
, ( "Local bin path where stack installs executables"
, "local-bin-path"
, T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )
, ( "Extra include directories"
, "extra-include-dirs"
, T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig )
, ( "Extra library directories"
, "extra-library-dirs"
, T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig )
, ( "Snapshot package database"
, "snapshot-pkg-db"
, T.pack . toFilePathNoTrailingSep . piSnapDb )
, ( "Local project package database"
, "local-pkg-db"
, T.pack . toFilePathNoTrailingSep . piLocalDb )
, ( "Global package database"
, "global-pkg-db"
, T.pack . toFilePathNoTrailingSep . piGlobalDb )
, ( "GHC_PACKAGE_PATH environment variable"
, "ghc-package-path"
, \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piExtraDbs pi) (piGlobalDb pi))
, ( "Snapshot installation root"
, "snapshot-install-root"
, T.pack . toFilePathNoTrailingSep . piSnapRoot )
, ( "Local project installation root"
, "local-install-root"
, T.pack . toFilePathNoTrailingSep . piLocalRoot )
, ( "Snapshot documentation root"
, "snapshot-doc-root"
, \pi -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi docDirSuffix)))
, ( "Local project documentation root"
, "local-doc-root"
, \pi -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi docDirSuffix)))
, ( "Dist work directory"
, "dist-dir"
, T.pack . toFilePathNoTrailingSep . piDistDir )
, ( "Where HPC reports and tix files are stored"
, "local-hpc-root"
, T.pack . toFilePathNoTrailingSep . piHpcDir ) ]
data SetupCmdOpts = SetupCmdOpts
{ scoCompilerVersion :: !(Maybe CompilerVersion)
, scoForceReinstall :: !Bool
, scoUpgradeCabal :: !Bool
, scoStackSetupYaml :: !String
, scoGHCBindistURL :: !(Maybe String)
}
setupParser :: Parser SetupCmdOpts
setupParser = SetupCmdOpts
<$> optional (argument readVersion
(metavar "GHC_VERSION" <>
help ("Version of GHC to install, e.g. 7.10.2. " ++
"The default is to install the version implied by the resolver.")))
<*> boolFlags False
"reinstall"
"reinstalling GHC, even if available (implies no-system-ghc)"
idm
<*> boolFlags False
"upgrade-cabal"
"installing the newest version of the Cabal library globally"
idm
<*> strOption
( long "stack-setup-yaml"
<> help "Location of the main stack-setup.yaml file"
<> value defaultStackSetupYaml
<> showDefault )
<*> optional (strOption
(long "ghc-bindist"
<> metavar "URL"
<> help "Alternate GHC binary distribution (requires custom --ghc-variant)"))
where
readVersion = do
s <- readerAsk
case parseCompilerVersion ("ghc-" <> T.pack s) of
Nothing ->
case parseCompilerVersion (T.pack s) of
Nothing -> readerError $ "Invalid version: " ++ s
Just x -> return x
Just x -> return x
setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()
setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
(manager,lc) <- loadConfigWithOpts go
withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->
runStackTGlobal manager (lcConfig lc) go $
Docker.reexecWithOptionalContainer
(lcProjectRoot lc)
Nothing
(runStackTGlobal manager (lcConfig lc) go $
Nix.reexecWithOptionalShell $
runStackLoggingTGlobal manager go $ do
(wantedCompiler, compilerCheck, mstack) <-
case scoCompilerVersion of
Just v -> return (v, MatchMinor, Nothing)
Nothing -> do
bc <- lcLoadBuildConfig lc globalCompiler
return ( bcWantedCompiler bc
, configCompilerCheck (lcConfig lc)
, Just $ bcStackYaml bc
)
miniConfig <- loadMiniConfig (lcConfig lc)
mpaths <- runStackTGlobal manager miniConfig go $
ensureCompiler SetupOpts
{ soptsInstallIfMissing = True
, soptsUseSystem =
configSystemGHC (lcConfig lc) && not scoForceReinstall
, soptsWantedCompiler = wantedCompiler
, soptsCompilerCheck = compilerCheck
, soptsStackYaml = mstack
, soptsForceReinstall = scoForceReinstall
, soptsSanityCheck = True
, soptsSkipGhcCheck = False
, soptsSkipMsys = configSkipMsys $ lcConfig lc
, soptsUpgradeCabal = scoUpgradeCabal
, soptsResolveMissingGHC = Nothing
, soptsStackSetupYaml = scoStackSetupYaml
, soptsGHCBindistURL = scoGHCBindistURL
}
let compiler = case wantedCompiler of
GhcVersion _ -> "GHC"
GhcjsVersion {} -> "GHCJS"
case mpaths of
Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH"
Just _ -> $logInfo $ "stack will use a locally installed " <> compiler
$logInfo "For more information on paths, see 'stack path' and 'stack exec env'"
$logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:"
$logInfo "stack ghc, stack ghci, stack runghc, or stack exec"
)
Nothing
(Just $ munlockFile lk)
-- | Unlock a lock file, if the value is Just
munlockFile :: MonadIO m => Maybe FileLock -> m ()
munlockFile Nothing = return ()
munlockFile (Just lk) = liftIO $ unlockFile lk
-- | Enforce mutual exclusion of every action running via this
-- function, on this path, on this users account.
--
-- A lock file is created inside the given directory. Currently,
-- stack uses locks per-snapshot. In the future, stack may refine
-- this to an even more fine-grain locking approach.
--
withUserFileLock :: (MonadBaseControl IO m, MonadIO m)
=> GlobalOpts
-> Path Abs Dir
-> (Maybe FileLock -> m a)
-> m a
withUserFileLock go@GlobalOpts{} dir act = do
env <- liftIO getEnvironment
let toLock = lookup "STACK_LOCK" env == Just "true"
if toLock
then do
let lockfile = $(mkRelFile "lockfile")
let pth = dir lockfile
liftIO $ createDirectoryIfMissing True (toFilePath dir)
-- Just in case of asynchronous exceptions, we need to be careful
-- when using tryLockFile here:
EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)
(maybe (return ()) (liftIO . unlockFile))
(\fstTry ->
case fstTry of
Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk)
Nothing ->
do let chatter = globalLogLevel go /= LevelOther "silent"
when chatter $
liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++
"); other stack instance running. Waiting..."
EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive)
(liftIO . unlockFile)
(\lk -> do
when chatter $
liftIO $ hPutStrLn stderr "Lock acquired, proceeding."
act $ Just lk))
else act Nothing
withConfigAndLock :: GlobalOpts
-> StackT Config IO ()
-> IO ()
withConfigAndLock go@GlobalOpts{..} inner = do
(manager, lc) <- loadConfigWithOpts go
withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->
runStackTGlobal manager (lcConfig lc) go $
Docker.reexecWithOptionalContainer (lcProjectRoot lc)
Nothing
(runStackTGlobal manager (lcConfig lc) go inner)
Nothing
(Just $ munlockFile lk)
-- For now the non-locking version just unlocks immediately.
-- That is, there's still a serialization point.
withBuildConfig :: GlobalOpts
-> StackT EnvConfig IO ()
-> IO ()
withBuildConfig go inner =
withBuildConfigAndLock go (\lk -> do munlockFile lk
inner)
withBuildConfigAndLock :: GlobalOpts
-> (Maybe FileLock -> StackT EnvConfig IO ())
-> IO ()
withBuildConfigAndLock go inner =
withBuildConfigExt go Nothing inner Nothing
withBuildConfigExt
:: GlobalOpts
-> Maybe (StackT Config IO ())
-- ^ Action to perform after before build. This will be run on the host
-- OS even if Docker is enabled for builds. The build config is not
-- available in this action, since that would require build tools to be
-- installed on the host OS.
-> (Maybe FileLock -> StackT EnvConfig IO ())
-- ^ Action that uses the build config. If Docker is enabled for builds,
-- this will be run in a Docker container.
-> Maybe (StackT Config IO ())
-- ^ Action to perform after the build. This will be run on the host
-- OS even if Docker is enabled for builds. The build config is not
-- available in this action, since that would require build tools to be
-- installed on the host OS.
-> IO ()
withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do
(manager, lc) <- loadConfigWithOpts go
withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do
-- A local bit of state for communication between callbacks:
curLk <- newIORef lk0
let inner' lk =
-- Locking policy: This is only used for build commands, which
-- only need to lock the snapshot, not the global lock. We
-- trade in the lock here.
do dir <- installationRootDeps
-- Hand-over-hand locking:
withUserFileLock go dir $ \lk2 -> do
liftIO $ writeIORef curLk lk2
liftIO $ munlockFile lk
inner lk2
let inner'' lk = do
bconfig <- runStackLoggingTGlobal manager go $
lcLoadBuildConfig lc globalCompiler
envConfig <-
runStackTGlobal
manager bconfig go
(setupEnv Nothing)
runStackTGlobal
manager
envConfig
go
(inner' lk)
runStackTGlobal manager (lcConfig lc) go $
Docker.reexecWithOptionalContainer
(lcProjectRoot lc)
mbefore
(runStackTGlobal manager (lcConfig lc) go $
Nix.reexecWithOptionalShell (inner'' lk0)
)
mafter
(Just $ liftIO $
do lk' <- readIORef curLk
munlockFile lk')
cleanCmd :: CleanOpts -> GlobalOpts -> IO ()
cleanCmd opts go = withBuildConfigAndLock go (const (clean opts))
-- | Helper for build and install commands
buildCmd :: BuildOpts -> GlobalOpts -> IO ()
buildCmd opts go = do
when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsGhcOptions opts)) $ do
hPutStrLn stderr "When building with stack, you should not use the -prof GHC option"
hPutStrLn stderr "Instead, please use --library-profiling and --executable-profiling"
hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015"
error "-prof GHC option submitted"
case boptsFileWatch opts of
FileWatchPoll -> fileWatchPoll inner
FileWatch -> fileWatch inner
NoFileWatch -> inner $ const $ return ()
where
inner setLocalFiles = withBuildConfigAndLock go $ \lk ->
Stack.Build.build setLocalFiles lk opts
uninstallCmd :: [String] -> GlobalOpts -> IO ()
uninstallCmd _ go = withConfigAndLock go $ do
$logError "stack does not manage installations in global locations"
$logError "The only global mutation stack performs is executable copying"
$logError "For the default executable destination, please run 'stack path --local-bin-path'"
-- | Unpack packages to the filesystem
unpackCmd :: [String] -> GlobalOpts -> IO ()
unpackCmd names go = withConfigAndLock go $ do
menv <- getMinimalEnvOverride
Stack.Fetch.unpackPackages menv "." names
-- | Update the package index
updateCmd :: () -> GlobalOpts -> IO ()
updateCmd () go = withConfigAndLock go $
getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
upgradeCmd :: (Bool, String) -> GlobalOpts -> IO ()
upgradeCmd (fromGit, repo) go = withConfigAndLock go $
upgrade (if fromGit then Just repo else Nothing)
(globalResolver go)
#ifdef USE_GIT_INFO
(find (/= "UNKNOWN") [$gitHash])
#else
Nothing
#endif
-- | Upload to Hackage
uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool) -> GlobalOpts -> IO ()
uploadCmd ([], _, _, _) _ = error "To upload the current package, please run 'stack upload .'"
uploadCmd (args, mpvpBounds, ignoreCheck, shouldSign) go = do
let partitionM _ [] = return ([], [])
partitionM f (x:xs) = do
r <- f x
(as, bs) <- partitionM f xs
return $ if r then (x:as, bs) else (as, x:bs)
(files, nonFiles) <- partitionM doesFileExist args
(dirs, invalid) <- partitionM doesDirectoryExist nonFiles
unless (null invalid) $ error $
"stack upload expects a list sdist tarballs or cabal directories. Can't find " ++
show invalid
(_,lc) <- liftIO $ loadConfigWithOpts go
let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader
getUploader = do
config <- asks getConfig
manager <- asks envManager
let uploadSettings =
Upload.setGetManager (return manager) Upload.defaultUploadSettings
liftIO $ Upload.mkUploader config uploadSettings
sigServiceUrl = "https://sig.commercialhaskell.org/"
withBuildConfigAndLock go $ \_ -> do
uploader <- getUploader
unless ignoreCheck $
mapM_ (parseRelAsAbsFile >=> checkSDistTarball) files
forM_
files
(\file ->
do tarFile <- parseRelAsAbsFile file
liftIO
(Upload.upload uploader (toFilePath tarFile))
when
shouldSign
(Sig.sign
(lcProjectRoot lc)
sigServiceUrl
tarFile))
unless (null dirs) $
forM_ dirs $ \dir -> do
pkgDir <- parseRelAsAbsDir dir
(tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir
unless ignoreCheck $ checkSDistTarball' tarName tarBytes
liftIO $ Upload.uploadBytes uploader tarName tarBytes
tarPath <- parseRelFile tarName
when
shouldSign
(Sig.signTarBytes
(lcProjectRoot lc)
sigServiceUrl
tarPath
tarBytes)
sdistCmd :: ([String], Maybe PvpBounds, Bool) -> GlobalOpts -> IO ()
sdistCmd (dirs, mpvpBounds, ignoreCheck) go =
withBuildConfig go $ do -- No locking needed.
-- If no directories are specified, build all sdist tarballs.
dirs' <- if null dirs
then asks (Map.keys . envConfigPackages . getEnvConfig)
else mapM (parseAbsDir <=< liftIO . canonicalizePath) dirs
forM_ dirs' $ \dir -> do
(tarName, tarBytes) <- getSDistTarball mpvpBounds dir
distDir <- distDirFromDir dir
tarPath <- (distDir ) <$> parseRelFile tarName
liftIO $ createTree $ parent tarPath
liftIO $ L.writeFile (toFilePath tarPath) tarBytes
unless ignoreCheck (checkSDistTarball tarPath)
$logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)
-- | Execute a command.
execCmd :: ExecOpts -> GlobalOpts -> IO ()
execCmd ExecOpts {..} go@GlobalOpts{..} =
case eoExtra of
ExecOptsPlain -> do
(cmd, args) <- case (eoCmd, eoArgs) of
(ExecCmd cmd, args) -> return (cmd, args)
(ExecGhc, args) -> return ("ghc", args)
(ExecRunGhc, args) -> return ("runghc", args)
(manager,lc) <- liftIO $ loadConfigWithOpts go
withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->
runStackTGlobal manager (lcConfig lc) go $
Docker.reexecWithOptionalContainer
(lcProjectRoot lc)
-- Unlock before transferring control away, whether using docker or not:
(Just $ munlockFile lk)
(runStackTGlobal manager (lcConfig lc) go $ do
config <- asks getConfig
menv <- liftIO $ configEnvOverride config plainEnvSettings
Nix.reexecWithOptionalShell
(runStackTGlobal manager (lcConfig lc) go $
exec menv cmd args))
Nothing
Nothing -- Unlocked already above.
ExecOptsEmbellished {..} ->
withBuildConfigAndLock go $ \lk -> do
config <- asks getConfig
(cmd, args) <- case (eoCmd, eoArgs) of
(ExecCmd cmd, args) -> return (cmd, args)
(ExecGhc, args) -> execCompiler "" args
-- NOTE: this won't currently work for GHCJS, because it doesn't have
-- a runghcjs binary. It probably will someday, though.
(ExecRunGhc, args) -> execCompiler "run" args
let targets = concatMap words eoPackages
unless (null targets) $
Stack.Build.build (const $ return ()) lk defaultBuildOpts
{ boptsTargets = map T.pack targets
}
munlockFile lk -- Unlock before transferring control away.
menv <- liftIO $ configEnvOverride config eoEnvSettings
exec menv cmd args
where
execCompiler cmdPrefix args = do
wc <- getWhichCompiler
let cmd = cmdPrefix ++ compilerExeName wc
return (cmd, args)
-- | Evaluate some haskell code inline.
evalCmd :: EvalOpts -> GlobalOpts -> IO ()
evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go
where
execOpts =
ExecOpts { eoCmd = ExecGhc
, eoArgs = ["-e", evalArg]
, eoExtra = evalExtra
}
-- | Run GHCi in the context of a project.
ghciCmd :: GhciOpts -> GlobalOpts -> IO ()
ghciCmd ghciOpts go@GlobalOpts{..} =
withBuildConfigAndLock go $ \lk -> do
let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts)
unless (null packageTargets) $
Stack.Build.build (const $ return ()) lk defaultBuildOpts
{ boptsTargets = map T.pack packageTargets
}
munlockFile lk -- Don't hold the lock while in the GHCI.
ghci ghciOpts
-- | Run ide-backend in the context of a project.
ideCmd :: ([Text], [String]) -> GlobalOpts -> IO ()
ideCmd (targets,args) go@GlobalOpts{..} =
withBuildConfig go $ -- No locking needed.
ide targets args
-- | List packages in the project.
packagesCmd :: () -> GlobalOpts -> IO ()
packagesCmd () go@GlobalOpts{..} =
withBuildConfig go $
do econfig <- asks getEnvConfig
locals <-
forM (M.toList (envConfigPackages econfig)) $
\(dir,_) ->
do cabalfp <- getCabalFileName dir
parsePackageNameFromFilePath cabalfp
forM_ locals (liftIO . putStrLn . packageNameString)
-- | List load targets for a package target.
targetsCmd :: Text -> GlobalOpts -> IO ()
targetsCmd target go@GlobalOpts{..} =
withBuildConfig go $
do let bopts = defaultBuildOpts { boptsTargets = [target] }
(_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing
pwd <- getWorkingDir
targets <-
fmap
(concat . snd . unzip)
(mapM (getPackageOptsAndTargetFiles pwd) pkgs)
forM_ targets (liftIO . putStrLn)
-- | Pull the current Docker image.
dockerPullCmd :: () -> GlobalOpts -> IO ()
dockerPullCmd _ go@GlobalOpts{..} = do
(manager,lc) <- liftIO $ loadConfigWithOpts go
-- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->
runStackTGlobal manager (lcConfig lc) go $
Docker.preventInContainer Docker.pull
-- | Reset the Docker sandbox.
dockerResetCmd :: Bool -> GlobalOpts -> IO ()
dockerResetCmd keepHome go@GlobalOpts{..} = do
(manager,lc) <- liftIO (loadConfigWithOpts go)
-- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->
runStackTGlobal manager (lcConfig lc) go $
Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome
-- | Cleanup Docker images and containers.
dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()
dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do
(manager,lc) <- liftIO $ loadConfigWithOpts go
-- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->
runStackTGlobal manager (lcConfig lc) go $
Docker.preventInContainer $
Docker.cleanup cleanupOpts
cfgSetCmd :: ConfigCmd.ConfigCmdSet -> GlobalOpts -> IO ()
cfgSetCmd co go@GlobalOpts{..} =
withBuildConfigAndLock
go
(\_ -> do env <- ask
runReaderT
(cfgCmdSet co)
env)
imgDockerCmd :: Bool -> GlobalOpts -> IO ()
imgDockerCmd rebuild go@GlobalOpts{..} =
withBuildConfigExt
go
Nothing
(\lk ->
do when rebuild $ Stack.Build.build
(const (return ()))
lk
defaultBuildOpts
Image.stageContainerImageArtifacts)
(Just Image.createContainerImageFromStage)
sigSignSdistCmd :: (String, String) -> GlobalOpts -> IO ()
sigSignSdistCmd (url,path) go =
withConfigAndLock
go
(do (manager,lc) <- liftIO (loadConfigWithOpts go)
tarBall <- parseRelAsAbsFile path
runStackTGlobal
manager
(lcConfig lc)
go
(Sig.sign (lcProjectRoot lc) url tarBall))
-- | Load the configuration with a manager. Convenience function used
-- throughout this module.
loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))
loadConfigWithOpts go@GlobalOpts{..} = do
manager <- newTLSManager
mstackYaml <-
case globalStackYaml of
Nothing -> return Nothing
Just fp -> do
path <- canonicalizePath fp >>= parseAbsFile
return $ Just path
lc <- runStackLoggingTGlobal manager go $ do
lc <- loadConfig globalConfigMonoid mstackYaml globalResolver
-- If we have been relaunched in a Docker container, perform in-container initialization
-- (switch UID, etc.). We do this after first loading the configuration since it must
-- happen ASAP but needs a configuration.
case globalDockerEntrypoint of
Just de -> Docker.entrypoint (lcConfig lc) de
Nothing -> return ()
return lc
return (manager,lc)
-- | Project initialization
initCmd :: InitOpts -> GlobalOpts -> IO ()
initCmd initOpts go =
withConfigAndLock go $
do pwd <- getWorkingDir
config <- asks getConfig
miniConfig <- loadMiniConfig config
runReaderT (initProject pwd initOpts) miniConfig
-- | Create a project directory structure and initialize the stack config.
newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()
newCmd (newOpts,initOpts) go@GlobalOpts{..} =
withConfigAndLock go $
do dir <- new newOpts
config <- asks getConfig
miniConfig <- loadMiniConfig config
runReaderT (initProject dir initOpts) miniConfig
-- | List the available templates.
templatesCmd :: () -> GlobalOpts -> IO ()
templatesCmd _ go@GlobalOpts{..} = withConfigAndLock go listTemplates
-- | Fix up extra-deps for a project
solverCmd :: Bool -- ^ modify stack.yaml automatically?
-> GlobalOpts
-> IO ()
solverCmd fixStackYaml go =
withBuildConfigAndLock go (\_ -> solveExtraDeps fixStackYaml)
-- | Visualize dependencies
dotCmd :: DotOpts -> GlobalOpts -> IO ()
dotCmd dotOpts go = withBuildConfigAndLock go (\_ -> dot dotOpts)
-- | List the dependencies
listDependenciesCmd :: Text -> GlobalOpts -> IO ()
listDependenciesCmd sep go = withBuildConfig go (listDependencies sep')
where sep' = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
-- | Query build information
queryCmd :: [String] -> GlobalOpts -> IO ()
queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selectors
-- | Generate a combined HPC report
hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO ()
hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts
data MainException = InvalidReExecVersion String String
deriving (Typeable)
instance Exception MainException
instance Show MainException where
show (InvalidReExecVersion expected actual) = concat
[ "When re-executing '"
, stackProgName
, "' in a container, the incorrect version was found\nExpected: "
, expected
, "; found: "
, actual]
stack-0.1.10.0/test/integration/IntegrationSpec.hs 0000644 0000000 0000000 00000011355 12623647202 020167 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Applicative
import Control.Arrow
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Conduit
import Data.Conduit.Binary (sinkLbs)
import Data.Conduit.Filesystem (sourceDirectoryDeep)
import qualified Data.Conduit.List as CL
import Data.Conduit.Process
import Data.List (isSuffixOf, stripPrefix, sort)
import qualified Data.Map as Map
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Typeable
import Prelude -- Fix redundant import warnings
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO.Temp
import System.PosixCompat.Files
import Test.Hspec
main :: IO ()
main = do
currDir <- canonicalizePath "test/integration"
let findExe name = do
mexe <- findExecutable name
case mexe of
Nothing -> error $ name ++ " not found on PATH"
Just exe -> return exe
runghc <- findExe "runghc"
stack <- findExe "stack"
let testDir = currDir "tests"
tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) . sort
envOrig <- getEnvironment
withSystemTempDirectory ("stack-integration-home") $ \newHome -> do
let env' = Map.toList
$ Map.insert "STACK_EXE" stack
$ Map.insert "HOME" newHome
$ Map.insert "APPDATA" newHome
$ Map.delete "GHC_PACKAGE_PATH"
$ Map.fromList
$ map (first (map toUpper)) envOrig
origStackRoot <- getAppUserDataDirectory "stack"
hspec $ mapM_ (test runghc env' currDir origStackRoot newHome) tests
hasTest :: FilePath -> FilePath -> IO Bool
hasTest root dir = doesFileExist $ root dir "Main.hs"
test :: FilePath -- ^ runghc
-> [(String, String)] -- ^ env
-> FilePath -- ^ currdir
-> FilePath -- ^ origStackRoot
-> FilePath -- ^ newHome
-> String
-> Spec
test runghc env' currDir origStackRoot newHome name = it name $ withDir $ \dir -> do
removeDirectoryRecursive newHome
copyTree toCopyRoot origStackRoot (newHome takeFileName origStackRoot)
let testDir = currDir "tests" name
mainFile = testDir "Main.hs"
libDir = currDir "lib"
cp = (proc runghc
[ "-clear-package-db"
, "-global-package-db"
, "-i" ++ libDir
, mainFile
])
{ cwd = Just dir
, env = Just env'
}
copyTree (const True) (testDir "files") dir
(ClosedStream, outSrc, errSrc, sph) <- streamingProcess cp
(out, err, ec) <- runConcurrently $ (,,)
<$> Concurrently (outSrc $$ sinkLbs)
<*> Concurrently (errSrc $$ sinkLbs)
<*> Concurrently (waitForStreamingProcess sph)
when (ec /= ExitSuccess) $ throwIO $ TestFailure out err ec
where
withDir = withSystemTempDirectory ("stack-integration-" ++ name)
data TestFailure = TestFailure L.ByteString L.ByteString ExitCode
deriving Typeable
instance Show TestFailure where
show (TestFailure out err ec) = concat
[ "Exited with " ++ show ec
, "\n\nstdout:\n"
, toStr out
, "\n\nstderr:\n"
, toStr err
]
where
toStr = TL.unpack . TL.decodeUtf8With lenientDecode
instance Exception TestFailure
copyTree :: (FilePath -> Bool) -> FilePath -> FilePath -> IO ()
copyTree toCopy src dst =
runResourceT (sourceDirectoryDeep False src $$ CL.mapM_ go)
`catch` \(_ :: IOException) -> return ()
where
go srcfp = when (toCopy srcfp) $ liftIO $ do
Just suffix <- return $ stripPrefix src srcfp
let dstfp = dst ++ "/" ++ suffix
createDirectoryIfMissing True $ takeDirectory dstfp
createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) ->
copyFile srcfp dstfp -- for Windows
toCopyRoot :: FilePath -> Bool
toCopyRoot srcfp = any (`isSuffixOf` srcfp)
-- FIXME command line parameters to control how many of these get
-- copied, trade-off of runtime/bandwidth vs isolation of tests
[ ".tar"
, ".xz"
-- , ".gz"
, ".7z.exe"
, "00-index.cache"
]
stack-0.1.10.0/test/integration/lib/StackTest.hs 0000644 0000000 0000000 00000006570 12630352213 017540 0 ustar 00 0000000 0000000 module StackTest where
import Control.Exception
import Data.List (intercalate)
import System.Environment
import System.FilePath
import System.Directory
import System.IO
import System.Process
import System.Exit
run' :: FilePath -> [String] -> IO ExitCode
run' cmd args = do
logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args)
(Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args)
waitForProcess ph
run :: FilePath -> [String] -> IO ()
run cmd args = do
ec <- run' cmd args
if ec == ExitSuccess
then return ()
else error $ "Exited with exit code: " ++ show ec
stack' :: [String] -> IO ExitCode
stack' args = do
stack <- getEnv "STACK_EXE"
run' stack args
stack :: [String] -> IO ()
stack args = do
ec <- stack' args
if ec == ExitSuccess
then return ()
else error $ "Exited with exit code: " ++ show ec
stackErr :: [String] -> IO ()
stackErr args = do
ec <- stack' args
if ec == ExitSuccess
then error "stack was supposed to fail, but didn't"
else return ()
-- | Run stack with arguments and apply a check to the resulting
-- stderr output if the process succeeded.
stackCheckStderr :: [String] -> (String -> IO ()) -> IO ()
stackCheckStderr args check = do
stack <- getEnv "STACK_EXE"
logInfo $ "Running: " ++ stack ++ " " ++ intercalate " " (map showProcessArgDebug args)
(ec, _, err) <- readProcessWithExitCode stack args ""
hPutStr stderr err
if ec /= ExitSuccess
then error $ "Exited with exit code: " ++ show ec
else check err
doesNotExist :: FilePath -> IO ()
doesNotExist fp = do
logInfo $ "doesNotExist " ++ fp
exists <- doesFileOrDirExist fp
case exists of
(Right msg) -> error msg
(Left _) -> return ()
doesExist :: FilePath -> IO ()
doesExist fp = do
logInfo $ "doesExist " ++ fp
exists <- doesFileOrDirExist fp
case exists of
(Right msg) -> return ()
(Left _) -> error "No file or directory exists"
doesFileOrDirExist :: FilePath -> IO (Either () String)
doesFileOrDirExist fp = do
isFile <- doesFileExist fp
if isFile
then return (Right ("File exists: " ++ fp))
else do
isDir <- doesDirectoryExist fp
if isDir
then return (Right ("Directory exists: " ++ fp))
else return (Left ())
copy :: FilePath -> FilePath -> IO ()
copy src dest = do
logInfo ("Copy " ++ show src ++ " to " ++ show dest)
System.Directory.copyFile src dest
fileContentsMatch :: FilePath -> FilePath -> IO ()
fileContentsMatch f1 f2 = do
doesExist f1
doesExist f2
f1Contents <- readFile f1
f2Contents <- readFile f2
if f1Contents == f2Contents
then return ()
else error
("contents do not match for " ++
show f1 ++
" " ++
show f2)
logInfo :: String -> IO ()
logInfo = hPutStrLn stderr
-- TODO: use stack's process running utilties? (better logging)
-- for now just copy+modifying this one from System.Process.Log
-- | Show a process arg including speechmarks when necessary. Just for
-- debugging purposes, not functionally important.
showProcessArgDebug :: String -> String
showProcessArgDebug x
| any special x = show x
| otherwise = x
where special '"' = True
special ' ' = True
special _ = False
stack-0.1.10.0/src/test/Test.hs 0000644 0000000 0000000 00000000116 12546477354 014262 0 ustar 00 0000000 0000000 import Test.Hspec (hspec)
import Spec (spec)
main :: IO ()
main = hspec spec
stack-0.1.10.0/src/test/Spec.hs 0000644 0000000 0000000 00000000105 12546477354 014233 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
stack-0.1.10.0/src/test/Stack/BuildPlanSpec.hs 0000644 0000000 0000000 00000011710 12630352213 017053 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.BuildPlanSpec where
import Stack.BuildPlan
import Control.Monad.Logger
import Control.Exception hiding (try)
import Control.Monad.Catch (try)
import Data.Monoid
import qualified Data.Map as Map
import qualified Data.Set as Set
import Network.HTTP.Conduit (Manager)
import Prelude -- Fix redundant import warnings
import System.Directory
import System.Environment
import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec
import Stack.Config
import Stack.Types
import Stack.Types.StackT
data T = T
{ manager :: Manager
}
setup :: IO T
setup = do
manager <- newTLSManager
unsetEnv "STACK_YAML"
return T{..}
teardown :: T -> IO ()
teardown _ = return ()
main :: IO ()
main = hspec spec
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
let logLevel = LevelDebug
let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing)
let loadBuildConfigRest m = runStackLoggingT m logLevel False False
let inTempDir action = do
currentDirectory <- getCurrentDirectory
withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do
let enterDir = setCurrentDirectory tempDir
let exitDir = setCurrentDirectory currentDirectory
bracket_ enterDir exitDir action
it "finds missing transitive dependencies #159" $ \T{..} -> inTempDir $ do
-- Note: this test is somewhat fragile, depending on packages on
-- Hackage remaining in a certain state. If it fails, confirm that
-- github still depends on failure.
writeFile "stack.yaml" "resolver: lts-2.9"
LoadConfig{..} <- loadConfig' manager
bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing)
runStackT manager logLevel bconfig False False $ do
mbp <- loadMiniBuildPlan $ LTS 2 9
eres <- try $ resolveBuildPlan
mbp
(const False)
(Map.fromList
[ ($(mkPackageName "github"), Set.empty)
])
case eres of
Left (UnknownPackages _ unknown _) -> do
case Map.lookup $(mkPackageName "github") unknown of
Nothing -> error "doesn't list github as unknown"
Just _ -> return ()
{- Currently not implemented, see: https://github.com/fpco/stack/issues/159#issuecomment-107809418
case Map.lookup $(mkPackageName "failure") unknown of
Nothing -> error "failure not listed"
Just _ -> return ()
-}
_ -> error $ "Unexpected result from resolveBuildPlan: " ++ show eres
return ()
describe "shadowMiniBuildPlan" $ do
let version = $(mkVersion "1.0.0") -- unimportant for this test
pn = either throw id . parsePackageNameFromString
mkMPI deps = MiniPackageInfo
{ mpiVersion = version
, mpiFlags = Map.empty
, mpiPackageDeps = Set.fromList $ map pn $ words deps
, mpiToolDeps = Set.empty
, mpiExes = Set.empty
, mpiHasLibrary = True
}
go x y = (pn x, mkMPI y)
resourcet = go "resourcet" ""
conduit = go "conduit" "resourcet"
conduitExtra = go "conduit-extra" "conduit"
text = go "text" ""
attoparsec = go "attoparsec" "text"
aeson = go "aeson" "text attoparsec"
mkMBP pkgs = MiniBuildPlan
{ mbpCompilerVersion = GhcVersion version
, mbpPackages = Map.fromList pkgs
}
mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson]
test name input shadowed output extra =
it name $ const $
shadowMiniBuildPlan input (Set.fromList $ map pn $ words shadowed)
`shouldBe` (output, Map.fromList extra)
test "no shadowing" mbpAll "" mbpAll []
test "shadow something that isn't there" mbpAll "does-not-exist" mbpAll []
test "shadow a leaf" mbpAll "conduit-extra"
(mkMBP [resourcet, conduit, text, attoparsec, aeson])
[]
test "shadow direct dep" mbpAll "conduit"
(mkMBP [resourcet, text, attoparsec, aeson])
[conduitExtra]
test "shadow deep dep" mbpAll "resourcet"
(mkMBP [text, attoparsec, aeson])
[conduit, conduitExtra]
test "shadow deep dep and leaf" mbpAll "resourcet aeson"
(mkMBP [text, attoparsec])
[conduit, conduitExtra]
test "shadow deep dep and direct dep" mbpAll "resourcet conduit"
(mkMBP [text, attoparsec, aeson])
[conduitExtra]
stack-0.1.10.0/src/test/Stack/Build/ExecuteSpec.hs 0000644 0000000 0000000 00000000205 12571621073 017646 0 ustar 00 0000000 0000000 module Stack.Build.ExecuteSpec (main, spec) where
import Test.Hspec
main :: IO ()
main = hspec spec
spec :: Spec
spec = return ()
stack-0.1.10.0/src/test/Stack/Build/TargetSpec.hs 0000644 0000000 0000000 00000002003 12562412301 017460 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Build.TargetSpec (main, spec) where
import qualified Data.Text as T
import Stack.Build.Target
import Stack.Types
import Test.Hspec
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "parseRawTarget" $ do
let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e
test "foobar" $ Just $ RTPackage $(mkPackageName "foobar")
test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier
$(mkPackageName "foobar") $(mkVersion "1.2.3")
test "./foobar" Nothing
test "foobar/" Nothing
test "/foobar" Nothing
test ":some-exe" $ Just $ RTComponent "some-exe"
test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe"
test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar")
$ ResolvedComponent $ CExe "some-exe"
stack-0.1.10.0/src/test/Stack/ConfigSpec.hs 0000644 0000000 0000000 00000007601 12630352213 016412 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.ConfigSpec where
import Control.Applicative
import Control.Monad.Logger
import Control.Exception
import Data.Maybe
import Data.Monoid
import Network.HTTP.Conduit (Manager)
import Path
import Path.IO
--import System.FilePath
import Prelude -- Fix redundant import warnings
import System.Directory
import System.Environment
import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec
import Stack.Config
import Stack.Types.Config
import Stack.Types.StackT
sampleConfig :: String
sampleConfig =
"resolver: lts-2.10\n" ++
"packages: ['.']\n"
stackDotYaml :: Path Rel File
stackDotYaml = $(mkRelFile "stack.yaml")
data T = T
{ manager :: Manager
}
setup :: IO T
setup = do
manager <- newTLSManager
unsetEnv "STACK_YAML"
return T{..}
teardown :: T -> IO ()
teardown _ = return ()
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
let logLevel = LevelDebug
-- TODO(danburton): not use inTempDir
let inTempDir action = do
currentDirectory <- getCurrentDirectory
withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do
let enterDir = setCurrentDirectory tempDir
let exitDir = setCurrentDirectory currentDirectory
bracket_ enterDir exitDir action
-- TODO(danburton): a safer version of this?
let withEnvVar name newValue action = do
originalValue <- fromMaybe "" <$> lookupEnv name
let setVar = setEnv name newValue
let resetVar = setEnv name originalValue
bracket_ setVar resetVar action
describe "loadConfig" $ do
let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing)
let loadBuildConfigRest m = runStackLoggingT m logLevel False False
-- TODO(danburton): make sure parent dirs also don't have config file
it "works even if no config file exists" $ \T{..} -> example $ do
_config <- loadConfig' manager
return ()
it "works with a blank config file" $ \T{..} -> inTempDir $ do
writeFile (toFilePath stackDotYaml) ""
-- TODO(danburton): more specific test for exception
loadConfig' manager `shouldThrow` anyException
it "finds the config file in a parent directory" $ \T{..} -> inTempDir $ do
writeFile (toFilePath stackDotYaml) sampleConfig
parentDir <- getCurrentDirectory >>= parseAbsDir
let childDir = "child"
createDirectory childDir
setCurrentDirectory childDir
LoadConfig{..} <- loadConfig' manager
bc@BuildConfig{..} <- loadBuildConfigRest manager
(lcLoadBuildConfig Nothing)
bcRoot bc `shouldBe` parentDir
it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do
withCanonicalizedSystemTempDirectory "config-is-here" $ \dir -> do
let stackYamlFp = toFilePath (dir stackDotYaml)
writeFile stackYamlFp sampleConfig
withEnvVar "STACK_YAML" stackYamlFp $ do
LoadConfig{..} <- loadConfig' manager
BuildConfig{..} <- loadBuildConfigRest manager
(lcLoadBuildConfig Nothing)
bcStackYaml `shouldBe` dir stackDotYaml
parent bcStackYaml `shouldBe` dir
it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do
parentDir <- getCurrentDirectory >>= parseAbsDir
let childRel = $(mkRelDir "child")
yamlRel = childRel $(mkRelFile "some-other-name.config")
yamlAbs = parentDir yamlRel
createDirectoryIfMissing True $ toFilePath $ parent yamlAbs
writeFile (toFilePath yamlAbs) "resolver: ghc-7.8"
withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do
LoadConfig{..} <- loadConfig' manager
BuildConfig{..} <- loadBuildConfigRest manager
(lcLoadBuildConfig Nothing)
bcStackYaml `shouldBe` yamlAbs
stack-0.1.10.0/src/test/Stack/DotSpec.hs 0000644 0000000 0000000 00000012562 12556257741 015756 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | Test suite for Stack.Dot
module Stack.DotSpec where
import Control.Monad (filterM)
import Data.ByteString.Char8 (ByteString)
import Data.Foldable as F
import Data.Functor.Identity
import Data.List ((\\))
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Stack.Types
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (forAll,choose,Gen)
import Stack.Dot
dummyVersion :: Version
dummyVersion = fromMaybe (error "dotspec: parser error") (parseVersionFromString "0.0.0.0")
spec :: Spec
spec = do
let graph =
Map.mapKeys pkgName
. fmap (\p -> (Set.map pkgName p, Just dummyVersion))
. Map.fromList $ [("one",Set.fromList ["base","free"])
,("two",Set.fromList ["base","free","mtl","transformers","one"])
]
describe "Stack.Dot" $ do
it "does nothing if depth is 0" $
resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph
it "with depth 1, more dependencies are resolved" $ do
let graph' = Map.insert (pkgName "cycle")
(Set.singleton (pkgName "cycle"), Just dummyVersion)
graph
resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader)
resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader)
Map.size resultGraph < Map.size resultGraph' `shouldBe` True
it "cycles are ignored" $ do
let graph' = Map.insert (pkgName "cycle")
(Set.singleton (pkgName "cycle"), Just dummyVersion)
graph
resultGraph = resolveDependencies Nothing graph stubLoader
resultGraph' = resolveDependencies Nothing graph' stubLoader
fmap Map.size resultGraph' `shouldBe` fmap ((+1) . Map.size) resultGraph
let graphElem e = Set.member e . Set.unions . Map.elems
prop "requested packages are pruned" $ do
let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)
allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g))
forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->
let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph
in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune)
prop "pruning removes orhpans" $ do
let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)
allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g))
orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g
forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->
let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph
in null (Map.keys (orphans (fmap fst pruned)) \\ [pkgName "one", pkgName "two"])
{- Helper functions below -}
-- Backport from QuickCheck 2.8 to 2.7.6
sublistOf :: [a] -> Gen [a]
sublistOf = filterM (\_ -> choose (False, True))
-- Unsafe internal helper to create a package name
pkgName :: ByteString -> PackageName
pkgName = fromMaybe failure . parsePackageName
where
failure = error "Internal error during package name creation in DotSpec.pkgName"
-- Stub, simulates the function to load package dependecies
stubLoader :: PackageName -> Identity (Set PackageName, Maybe Version)
stubLoader name = return . (, Just dummyVersion) . Set.fromList . map pkgName $ case show name of
"StateVar" -> ["stm","transformers"]
"array" -> []
"bifunctors" -> ["semigroupoids","semigroups","tagged"]
"binary" -> ["array","bytestring","containers"]
"bytestring" -> ["deepseq","ghc-prim","integer-gmp"]
"comonad" -> ["containers","contravariant","distributive"
,"semigroups","tagged","transformers","transformers-compat"
]
"cont" -> ["StateVar","semigroups","transformers","transformers-compat","void"]
"containers" -> ["array","deepseq","ghc-prim"]
"deepseq" -> ["array"]
"distributive" -> ["ghc-prim","tagged","transformers","transformers-compat"]
"free" -> ["bifunctors","comonad","distributive","mtl"
,"prelude-extras","profunctors","semigroupoids"
,"semigroups","template-haskell","transformers"
]
"ghc" -> []
"hashable" -> ["bytestring","ghc-prim","integer-gmp","text"]
"integer" -> []
"mtl" -> ["transformers"]
"nats" -> []
"one" -> ["free"]
"prelude" -> []
"profunctors" -> ["comonad","distributive","semigroupoids","tagged","transformers"]
"semigroupoids" -> ["comonad","containers","contravariant","distributive"
,"semigroups","transformers","transformers-compat"
]
"semigroups" -> ["bytestring","containers","deepseq","hashable"
,"nats","text","unordered-containers"
]
"stm" -> ["array"]
"tagged" -> ["template-haskell"]
"template" -> []
"text" -> ["array","binary","bytestring","deepseq","ghc-prim","integer-gmp"]
"transformers" -> []
"two" -> ["free","mtl","one","transformers"]
"unordered" -> ["deepseq","hashable"]
"void" -> ["ghc-prim","hashable","semigroups"]
_ -> []
stack-0.1.10.0/src/test/Stack/PackageDumpSpec.hs 0000644 0000000 0000000 00000023041 12623647202 017371 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Stack.PackageDumpSpec where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Control.Monad.Trans.Resource (runResourceT)
import Stack.PackageDump
import Stack.Types
import Test.Hspec
import Test.Hspec.QuickCheck
import System.Process.Read
import Control.Monad.Logger
import Distribution.System (buildPlatform)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "eachSection" $ do
let test name content expected = it name $ do
actual <- yield content $$ eachSection CL.consume =$ CL.consume
actual `shouldBe` expected
test
"unix line endings"
"foo\nbar\n---\nbaz---\nbin\n---\n"
[ ["foo", "bar"]
, ["baz---", "bin"]
]
test
"windows line endings"
"foo\r\nbar\r\n---\r\nbaz---\r\nbin\r\n---\r\n"
[ ["foo", "bar"]
, ["baz---", "bin"]
]
it "eachPair" $ do
let bss =
[ "key1: val1"
, "key2: val2a"
, " val2b"
, "key3:"
, "key4:"
, " val4a"
, " val4b"
]
sink k = fmap (k, ) CL.consume
actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume
actual `shouldBe`
[ ("key1", ["val1"])
, ("key2", ["val2a", "val2b"])
, ("key3", [])
, ("key4", ["val4a", "val4b"])
]
describe "conduitDumpPackage" $ do
it "ghc 7.8" $ do
haskell2010:_ <- runResourceT
$ CB.sourceFile "test/package-dump/ghc-7.8.txt"
$$ conduitDumpPackage
=$ CL.consume
ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"
packageIdent <- parsePackageIdentifier "haskell2010-1.1.2.0"
depends <- mapM parseGhcPkgId
[ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
, "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"
, "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37"
]
haskell2010 `shouldBe` DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = packageIdent
, dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"]
, dpDepends = depends
, dpLibraries = ["HShaskell2010-1.1.2.0"]
, dpHasExposedModules = True
, dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"]
, dpHaddockHtml = Just "/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0"
, dpProfiling = ()
, dpHaddock = ()
, dpIsExposed = False
}
it "ghc 7.10" $ do
haskell2010:_ <- runResourceT
$ CB.sourceFile "test/package-dump/ghc-7.10.txt"
$$ conduitDumpPackage
=$ CL.consume
ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"
pkgIdent <- parsePackageIdentifier "ghc-7.10.1"
depends <- mapM parseGhcPkgId
[ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"
, "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"
, "bin-package-db-0.0.0.0-708fc7d634a370b311371a5bcde40b62"
, "bytestring-0.10.6.0-0909f8f31271f3d75749190bf2ee35db"
, "containers-0.5.6.2-2114032c163425cc264e6e1169dc2f6d"
, "directory-1.2.2.0-b4959b472d9eee380c6b32291ade29e0"
, "filepath-1.4.0.0-40d643aa87258c186441a1f8f3e13ca6"
, "hoopl-3.10.0.2-8c8dfc4c3140e5f7c982da224c3cb1f0"
, "hpc-0.6.0.2-ac9064885aa8cb08a93314222939ead4"
, "process-1.2.3.0-3b1e9bca6ac38225806ff7bbf3f845b1"
, "template-haskell-2.10.0.0-e895139a0ffff267d412e3d0191ce93b"
, "time-1.5.0.1-e17a9220d438435579d2914e90774246"
, "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f"
, "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f"
]
haskell2010 `shouldBe` DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = pkgIdent
, dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"]
, dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"]
, dpHaddockHtml = Just "/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1"
, dpDepends = depends
, dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"]
, dpHasExposedModules = True
, dpProfiling = ()
, dpHaddock = ()
, dpIsExposed = False
}
it "ghc 7.8.4 (osx)" $ do
hmatrix:_ <- runResourceT
$ CB.sourceFile "test/package-dump/ghc-7.8.4-osx.txt"
$$ conduitDumpPackage
=$ CL.consume
ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe"
pkgId <- parsePackageIdentifier "hmatrix-0.16.1.5"
depends <- mapM parseGhcPkgId
[ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
, "base-4.7.0.2-918c7ac27f65a87103264a9f51652d63"
, "binary-0.7.1.0-108d06eea2ef05e517f9c1facf10f63c"
, "bytestring-0.10.4.0-78bc8f2c724c765c78c004a84acf6cc3"
, "deepseq-1.3.0.2-0ddc77716bd2515426e1ba39f6788a4f"
, "random-1.1-822c19b7507b6ac1aaa4c66731e775ae"
, "split-0.2.2-34cfb851cc3784e22bfae7a7bddda9c5"
, "storable-complex-0.2.2-e962c368d58acc1f5b41d41edc93da72"
, "vector-0.10.12.3-f4222db607fd5fdd7545d3e82419b307"]
hmatrix `shouldBe` DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = pkgId
, dpLibDirs =
[ "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/lib/x86_64-osx-ghc-7.8.4/hmatrix-0.16.1.5"
, "/opt/local/lib/"
, "/usr/local/lib/"
, "C:/Program Files/Example/"]
, dpHaddockInterfaces = ["/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html/hmatrix.haddock"]
, dpHaddockHtml = Just "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html"
, dpDepends = depends
, dpLibraries = ["HShmatrix-0.16.1.5"]
, dpHasExposedModules = True
, dpProfiling = ()
, dpHaddock = ()
, dpIsExposed = True
}
it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do
menv' <- getEnvOverride buildPlatform
menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv'
icache <- newInstalledCache
ghcPkgDump menv Ghc []
$ conduitDumpPackage
=$ addProfiling icache
=$ addHaddock icache
=$ CL.sinkNull
it "sinkMatching" $ do
menv' <- getEnvOverride buildPlatform
menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv'
icache <- newInstalledCache
m <- runNoLoggingT $ ghcPkgDump menv Ghc []
$ conduitDumpPackage
=$ addProfiling icache
=$ addHaddock icache
=$ sinkMatching False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1"))
case Map.lookup $(mkPackageName "base") m of
Nothing -> error "base not present"
Just _ -> return ()
Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing
Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing
describe "pruneDeps" $ do
it "sanity check" $ do
let prunes =
[ ((1, 'a'), [])
, ((1, 'b'), [])
, ((2, 'a'), [(1, 'b')])
, ((2, 'b'), [(1, 'a')])
, ((3, 'a'), [(1, 'c')])
, ((4, 'a'), [(2, 'a')])
]
actual = fmap fst $ pruneDeps fst fst snd bestPrune prunes
actual `shouldBe` Map.fromList
[ (1, (1, 'b'))
, (2, (2, 'a'))
, (4, (4, 'a'))
]
prop "invariant holds" $ \prunes' ->
-- Force uniqueness
let prunes = Map.toList $ Map.fromList prunes'
in checkDepsPresent prunes $ fmap fst $ pruneDeps fst fst snd bestPrune prunes
type PruneCheck = ((Int, Char), [(Int, Char)])
bestPrune :: PruneCheck -> PruneCheck -> PruneCheck
bestPrune x y
| fst x > fst y = x
| otherwise = y
checkDepsPresent :: [PruneCheck] -> Map Int (Int, Char) -> Bool
checkDepsPresent prunes selected =
all hasDeps $ Set.toList allIds
where
depMap = Map.fromList prunes
allIds = Set.fromList $ Map.elems selected
hasDeps ident =
case Map.lookup ident depMap of
Nothing -> error "checkDepsPresent: missing in depMap"
Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds
stack-0.1.10.0/src/test/Stack/ArgsSpec.hs 0000644 0000000 0000000 00000001757 12546477354 016133 0 ustar 00 0000000 0000000 -- | Args parser test suite.
module Stack.ArgsSpec where
import Control.Monad
import Options.Applicative.Args
import Test.Hspec
-- | Test spec.
spec :: Spec
spec =
forM_
tests
(\(input,output) ->
it input (parseArgsFromString input == output))
-- | Fairly comprehensive checks.
tests :: [(String, Either String [String])]
tests =
[ ("x", Right ["x"])
, ("x y z", Right ["x", "y", "z"])
, ("aaa bbb ccc", Right ["aaa", "bbb", "ccc"])
, (" aaa bbb ccc ", Right ["aaa", "bbb", "ccc"])
, ("aaa\"", Left "unterminated string: endOfInput")
, ("\"", Left "unterminated string: endOfInput")
, ("\"\"", Right [""])
, ("\"aaa", Left "unterminated string: endOfInput")
, ("\"aaa\" bbb ccc \"ddd\"", Right ["aaa", "bbb", "ccc", "ddd"])
, ("\"aa\\\"a\" bbb ccc \"ddd\"", Right ["aa\"a", "bbb", "ccc", "ddd"])
, ("\"aa\\\"a\" bb\\b ccc \"ddd\"", Right ["aa\"a", "bb\\b", "ccc", "ddd"])
, ("\"\" \"\" c", Right ["","","c"])]
stack-0.1.10.0/src/test/Stack/NixSpec.hs 0000644 0000000 0000000 00000003714 12630352213 015744 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Stack.NixSpec where
import Test.Hspec
import Control.Monad.Logger
import Control.Exception
import Data.Monoid
import Network.HTTP.Conduit (Manager)
import System.Environment
import Path
import System.Directory
import System.IO.Temp (withSystemTempDirectory)
import Stack.Config
import Stack.Types.Config
import Stack.Types.StackT
import Stack.Types.Nix
import Prelude -- to remove the warning about Data.Monoid being redundant on GHC 7.10
sampleConfig :: String
sampleConfig =
"resolver: lts-2.10\n" ++
"packages: ['.']\n" ++
"nix:\n" ++
" enable: True\n" ++
" packages: [glpk]"
stackDotYaml :: Path Rel File
stackDotYaml = $(mkRelFile "stack.yaml")
data T = T
{ manager :: Manager
}
setup :: IO T
setup = do
manager <- newTLSManager
unsetEnv "STACK_YAML"
return T{..}
teardown :: T -> IO ()
teardown _ = return ()
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
let loadConfig' m = runStackLoggingT m LevelDebug False False (loadConfig mempty Nothing Nothing)
inTempDir action = do
currentDirectory <- getCurrentDirectory
withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do
let enterDir = setCurrentDirectory tempDir
exitDir = setCurrentDirectory currentDirectory
bracket_ enterDir exitDir action
describe "nix" $ do
it "sees that the nix shell is enabled" $ \T{..} -> inTempDir $ do
writeFile (toFilePath stackDotYaml) sampleConfig
lc <- loadConfig' manager
(nixEnable $ configNix $ lcConfig lc) `shouldBe` True
it "sees that the only package asked for is glpk and adds GHC from nixpkgs mirror of LTS resolver" $ \T{..} -> inTempDir $ do
writeFile (toFilePath stackDotYaml) sampleConfig
lc <- loadConfig' manager
(nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk", "haskell.packages.lts-2_10.ghc"]
stack-0.1.10.0/src/test/Network/HTTP/Download/VerifiedSpec.hs 0000644 0000000 0000000 00000014134 12607713542 021665 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module Network.HTTP.Download.VerifiedSpec where
import Crypto.Hash
import Control.Monad (unless)
import Control.Monad.Trans.Reader
import Control.Retry (limitRetries)
import Data.Maybe
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.IO
import System.Directory
import Test.Hspec hiding (shouldNotBe, shouldNotReturn)
-- TODO: share across test files
withTempDir :: (Path Abs Dir -> IO a) -> IO a
withTempDir = withCanonicalizedSystemTempDirectory "NHD_VerifiedSpec"
-- | An example path to download the exampleReq.
getExamplePath :: Path Abs Dir -> IO (Path Abs File)
getExamplePath dir = do
file <- parseRelFile "cabal-install-1.22.4.0.tar.gz"
return (dir file)
-- | An example DownloadRequest that uses a SHA1
exampleReq :: DownloadRequest
exampleReq = fromMaybe (error "exampleReq") $ do
req <- parseUrl "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz"
return DownloadRequest
{ drRequest = req
, drHashChecks = [exampleHashCheck]
, drLengthCheck = Just exampleLengthCheck
, drRetryPolicy = limitRetries 1
}
exampleHashCheck :: HashCheck
exampleHashCheck = HashCheck
{ hashCheckAlgorithm = SHA1
, hashCheckHexDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec2"
}
exampleLengthCheck :: LengthCheck
exampleLengthCheck = 302513
-- | The wrong ContentLength for exampleReq
exampleWrongContentLength :: Int
exampleWrongContentLength = 302512
-- | The wrong SHA1 digest for exampleReq
exampleWrongDigest :: CheckHexDigest
exampleWrongDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec3"
exampleWrongContent :: String
exampleWrongContent = "example wrong content"
isWrongContentLength :: VerifiedDownloadException -> Bool
isWrongContentLength WrongContentLength{} = True
isWrongContentLength _ = False
isWrongDigest :: VerifiedDownloadException -> Bool
isWrongDigest WrongDigest{} = True
isWrongDigest _ = False
data T = T
{ manager :: Manager
}
runWith :: Manager -> ReaderT Manager m r -> m r
runWith = flip runReaderT
setup :: IO T
setup = do
manager <- newManager
return T{..}
teardown :: T -> IO ()
teardown _ = return ()
shouldNotBe :: (Show a, Eq a) => a -> a -> Expectation
actual `shouldNotBe` expected =
unless (actual /= expected) (expectationFailure msg)
where
msg = "Value was exactly what it shouldn't be: " ++ show expected
shouldNotReturn :: (Show a, Eq a) => IO a -> a -> Expectation
action `shouldNotReturn` unexpected = action >>= (`shouldNotBe` unexpected)
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
let exampleProgressHook _ = return ()
describe "verifiedDownload" $ do
-- Preconditions:
-- * the exampleReq server is running
-- * the test runner has working internet access to it
it "downloads the file correctly" $ \T{..} -> withTempDir $ \dir -> do
examplePath <- getExamplePath dir
let exampleFilePath = toFilePath examplePath
doesFileExist exampleFilePath `shouldReturn` False
let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook
go `shouldReturn` True
doesFileExist exampleFilePath `shouldReturn` True
it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir $ \dir -> do
examplePath <- getExamplePath dir
let exampleFilePath = toFilePath examplePath
doesFileExist exampleFilePath `shouldReturn` False
let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook
go `shouldReturn` True
doesFileExist exampleFilePath `shouldReturn` True
go `shouldReturn` False
doesFileExist exampleFilePath `shouldReturn` True
-- https://github.com/commercialhaskell/stack/issues/372
it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir $ \dir -> do
examplePath <- getExamplePath dir
let exampleFilePath = toFilePath examplePath
writeFile exampleFilePath exampleWrongContent
doesFileExist exampleFilePath `shouldReturn` True
readFile exampleFilePath `shouldReturn` exampleWrongContent
let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook
go `shouldReturn` True
doesFileExist exampleFilePath `shouldReturn` True
readFile exampleFilePath `shouldNotReturn` exampleWrongContent
it "rejects incorrect content length" $ \T{..} -> withTempDir $ \dir -> do
examplePath <- getExamplePath dir
let exampleFilePath = toFilePath examplePath
let wrongContentLengthReq = exampleReq
{ drLengthCheck = Just exampleWrongContentLength
}
let go = runWith manager $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook
go `shouldThrow` isWrongContentLength
doesFileExist exampleFilePath `shouldReturn` False
it "rejects incorrect digest" $ \T{..} -> withTempDir $ \dir -> do
examplePath <- getExamplePath dir
let exampleFilePath = toFilePath examplePath
let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }
let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }
let go = runWith manager $ verifiedDownload wrongDigestReq examplePath exampleProgressHook
go `shouldThrow` isWrongDigest
doesFileExist exampleFilePath `shouldReturn` False
-- https://github.com/commercialhaskell/stack/issues/240
it "can download hackage tarballs" $ \T{..} -> withTempDir $ \dir -> do
dest <- fmap (dir ) $ parseRelFile "acme-missiles-0.3.tar.gz"
let destFp = toFilePath dest
req <- parseUrl "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"
let dReq = DownloadRequest
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
, drRetryPolicy = limitRetries 1
}
let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook
doesFileExist destFp `shouldReturn` False
go `shouldReturn` True
doesFileExist destFp `shouldReturn` True
stack-0.1.10.0/LICENSE 0000644 0000000 0000000 00000002724 12623647202 012240 0 ustar 00 0000000 0000000 Copyright (c) 2015, Stack contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of stack nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
stack-0.1.10.0/Setup.hs 0000644 0000000 0000000 00000000056 12546477354 012700 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
stack-0.1.10.0/stack.cabal 0000644 0000000 0000000 00000023504 00000000000 013260 0 ustar 00 0000000 0000000 name: stack
version: 0.1.10.0
cabal-version: >=1.10
build-type: Simple
license: BSD3
license-file: LICENSE
maintainer: manny@fpcomplete.com
homepage: http://haskellstack.org
synopsis: The Haskell Tool Stack
description:
Please see the README.md for usage information, and
the wiki on Github for more details. Also, note that
the API for the library is not currently stable, and may
change significantly, even between minor releases. It is
currently only intended for use by the executable.
category: Development
author: Commercial Haskell SIG
extra-source-files:
CONTRIBUTING.md
ChangeLog.md
README.md
test/package-dump/ghc-7.8.txt
test/package-dump/ghc-7.8.4-osx.txt
test/package-dump/ghc-7.10.txt
stack.yaml
source-repository head
type: git
location: https://github.com/commercialhaskell/stack.git
flag integration-tests
description:
Run the integration test suite
default: False
manual: True
flag disable-git-info
description:
Disable compile-time inclusion of current git info in stack
default: False
manual: True
library
if os(windows)
build-depends:
Win32 >=2.3.1.0 && <2.4
cpp-options: -DWINDOWS
else
build-depends:
unix >=2.7.0.1 && <2.8
exposed-modules:
Options.Applicative.Builder.Extra
Options.Applicative.Args
Options.Applicative.Complicated
Stack.BuildPlan
Stack.Clean
Stack.Config
Stack.Config.Docker
Stack.Config.Nix
Stack.ConfigCmd
Stack.Constants
Stack.Coverage
Stack.Docker
Stack.Docker.GlobalDB
Stack.Dot
Stack.Fetch
Stack.Exec
Stack.FileWatch
Stack.GhcPkg
Stack.Init
Stack.New
Stack.Nix
Stack.Options
Stack.Package
Stack.PackageDump
Stack.PackageIndex
Stack.Ghci
Stack.Ide
Stack.Image
Stack.SDist
Stack.Setup
Stack.Setup.Installed
Stack.Solver
Stack.Types
Stack.Types.Internal
Stack.Types.BuildPlan
Stack.Types.Compiler
Stack.Types.Config
Stack.Types.Docker
Stack.Types.FlagName
Stack.Types.GhcPkgId
Stack.Types.Image
Stack.Types.Nix
Stack.Types.PackageIdentifier
Stack.Types.PackageIndex
Stack.Types.PackageName
Stack.Types.TemplateName
Stack.Types.Version
Stack.Types.Sig
Stack.Types.StackT
Stack.Types.Build
Stack.Types.Package
Stack.Build
Stack.Build.Cache
Stack.Build.ConstructPlan
Stack.Build.Execute
Stack.Build.Haddock
Stack.Build.Installed
Stack.Build.Source
Stack.Build.Target
Stack.Sig
Stack.Sig.GPG
Stack.Sig.Sign
Stack.Upgrade
Stack.Upload
System.Process.Read
System.Process.Log
System.Process.Run
Network.HTTP.Download.Verified
Data.Attoparsec.Args
Data.Maybe.Extra
Path.IO
Path.Extra
build-depends:
Cabal >=1.18.1.5 && <1.23,
aeson >=0.8.0.2 && <0.10,
ansi-terminal >=0.6.2.3 && <0.7,
async >=2.0.2 && <2.1,
attoparsec >=0.12.1.5 && <0.14,
base >=4.7 && <5,
base16-bytestring >=0.1.1.6 && <0.2,
base64-bytestring >=1.0.0.1 && <1.1,
bifunctors >=4.2.1 && <5.1,
binary ==0.7.*,
binary-tagged >=0.1.1 && <0.2,
blaze-builder >=0.4.0.1 && <0.5,
byteable >=0.1.1 && <0.2,
bytestring >=0.10.6.0 && <0.11,
conduit-combinators >=0.3.1 && <1.1,
conduit >=1.2.4 && <1.3,
conduit-extra >=1.1.7.1 && <1.2,
containers >=0.5.5.1 && <0.6,
cryptohash >=0.11.6 && <0.12,
cryptohash-conduit >=0.1.1 && <0.2,
directory >=1.2.1.0 && <1.3,
edit-distance ==0.2.*,
either >=4.4.1 && <4.5,
enclosed-exceptions >=1.0.1.1 && <1.1,
exceptions >=0.8.0.2 && <0.9,
extra >=1.4.2 && <1.5,
fast-logger >=2.3.1 && <2.5,
filelock >=0.1.0.1 && <0.2,
filepath >=1.3.0.2 && <1.5,
fsnotify >=0.2.1 && <0.3,
hashable >=1.2.3.2 && <1.3,
hpc >=0.6.0.2 && <0.7,
http-client >=0.4.17 && <0.5,
http-client-tls >=0.2.2 && <0.3,
http-conduit >=2.1.7 && <2.2,
http-types >=0.8.6 && <0.9,
lifted-base >=0.2.3.6 && <0.3,
monad-control >=1.0.0.4 && <1.1,
monad-logger >=0.3.13.1 && <0.4,
monad-loops >=0.4.2.1 && <0.5,
mtl >=2.1.3.1 && <2.3,
old-locale >=1.0.0.6 && <1.1,
optparse-applicative >=0.11.0.2 && <0.12,
path >=0.5.1 && <0.6,
persistent >=2.1.2 && <2.3,
persistent-sqlite >=2.1.4 && <2.3,
persistent-template >=2.1.1 && <2.2,
pretty >=1.1.2.0 && <1.2,
process >=1.2.0.0 && <1.3,
resourcet >=1.1.4.1 && <1.2,
retry >=0.6 && <0.8,
safe ==0.3.*,
semigroups >=0.5 && <0.18,
split >=0.2.2 && <0.3,
stm >=2.4.4 && <2.5,
streaming-commons >=0.1.10.0 && <0.2,
tar >=0.4.1.0 && <0.5,
template-haskell >=2.9.0.0 && <2.11,
temporary >=1.2.0.3 && <1.3,
text >=1.2.0.4 && <1.3,
time >=1.4.2 && <1.6,
transformers >=0.3.0.0 && <0.5,
transformers-base >=0.4.4 && <0.5,
unix-compat >=0.4.1.4 && <0.5,
unordered-containers >=0.2.5.1 && <0.3,
vector >=0.10.12.3 && <0.12,
vector-binary-instances >=0.2.1.0 && <0.3,
void ==0.7.*,
yaml >=0.8.10.1 && <0.9,
zlib >=0.5.4.2 && <0.6,
deepseq ==1.4.*,
file-embed >=0.0.9 && <0.1,
word8 >=0.1.2 && <0.2,
hastache >=0.6.1 && <0.7,
project-template ==0.2.*,
email-validate >=2.0 && <2.2,
uuid >=1.3.11 && <1.4
default-language: Haskell2010
hs-source-dirs: src/
other-modules:
Network.HTTP.Download
Control.Concurrent.Execute
Path.Find
System.Process.PagerEditor
Paths_stack
Data.Aeson.Extended
Data.Attoparsec.Combinators
Data.Binary.VersionTagged
Data.IORef.RunOnce
Data.Set.Monad
Distribution.Version.Extra
ghc-options: -Wall
executable stack
if os(windows)
build-depends:
Win32 >=2.3.1.0 && <2.4
cpp-options: -DWINDOWS
if !flag(disable-git-info)
build-depends:
gitrev ==1.1.*,
optparse-simple >=0.0.3 && <0.1
cpp-options: -DUSE_GIT_INFO
main-is: Main.hs
build-depends:
base >=4.7 && <5,
bytestring >=0.10.4.0 && <0.11,
Cabal >=1.22.4.0 && <1.23,
containers >=0.5.6.2 && <0.6,
exceptions >=0.8.0.2 && <0.9,
filepath >=1.4.0.0 && <1.5,
filelock >=0.1.0.1 && <0.2,
http-conduit >=2.1.5 && <2.2,
lifted-base >=0.2.3.6 && <0.3,
monad-control >=1.0.0.4 && <1.1,
monad-logger >=0.3.13.1 && <0.4,
mtl >=2.1.3.1 && <2.3,
old-locale >=1.0.0.6 && <1.1,
optparse-applicative >=0.11.0.2 && <0.12,
path >=0.5.2 && <0.6,
process >=1.2.3.0 && <1.3,
resourcet >=1.1.4.1 && <1.2,
stack >=0.1.10.0 && <0.2,
text >=1.2.0.4 && <1.3,
either >=4.4.1 && <4.5,
directory >=1.2.2.0 && <1.3,
split >=0.2.2 && <0.3,
unordered-containers >=0.2.5.1 && <0.3,
hashable >=1.2.3.3 && <1.3,
conduit >=1.2.5.1 && <1.3,
transformers >=0.4.2.0 && <0.5,
http-client >=0.4.24 && <0.5
default-language: Haskell2010
hs-source-dirs: src/main
other-modules:
Paths_stack
ghc-options: -Wall -threaded -rtsopts
test-suite stack-test
type: exitcode-stdio-1.0
main-is: Test.hs
build-depends:
base >=4.7 && <5,
hspec >=2.1.10 && <2.3,
containers >=0.5.6.2 && <0.6,
directory >=1.2.2.0 && <1.3,
exceptions >=0.8.0.2 && <0.9,
filepath >=1.4.0.0 && <1.5,
path >=0.5.2 && <0.6,
temporary >=1.2.0.3 && <1.3,
stack >=0.1.10.0 && <0.2,
monad-logger >=0.3.15 && <0.4,
http-conduit >=2.1.8 && <2.2,
cryptohash >=0.11.6 && <0.12,
transformers >=0.4.2.0 && <0.5,
conduit >=1.2.5.1 && <1.3,
conduit-extra >=1.1.9.1 && <1.2,
resourcet >=1.1.6 && <1.2,
Cabal >=1.22.4.0 && <1.23,
text >=1.2.1.3 && <1.3,
optparse-applicative >=0.11.0.2 && <0.12,
bytestring >=0.10.6.0 && <0.11,
QuickCheck >=2.8.1 && <2.9,
retry >=0.6 && <0.8
default-language: Haskell2010
hs-source-dirs: src/test
other-modules:
Spec
Stack.BuildPlanSpec
Stack.Build.ExecuteSpec
Stack.Build.TargetSpec
Stack.ConfigSpec
Stack.DotSpec
Stack.PackageDumpSpec
Stack.ArgsSpec
Stack.NixSpec
Network.HTTP.Download.VerifiedSpec
ghc-options: -Wall -threaded
test-suite stack-integration-test
if !flag(integration-tests)
buildable: False
type: exitcode-stdio-1.0
main-is: IntegrationSpec.hs
build-depends:
base >=4.7 && <5,
temporary >=1.2.0.3 && <1.3,
hspec >=2.1.10 && <2.3,
process >=1.2.3.0 && <1.3,
filepath >=1.4.0.0 && <1.5,
directory >=1.2.2.0 && <1.3,
text >=1.2.1.3 && <1.3,
unix-compat >=0.4.1.4 && <0.5,
containers >=0.5.6.2 && <0.6,
conduit >=1.2.5.1 && <1.3,
conduit-extra >=1.1.9.1 && <1.2,
resourcet >=1.1.6 && <1.2,
async >=2.0.2 && <2.1,
transformers >=0.4.2.0 && <0.5,
bytestring >=0.10.6.0 && <0.11
default-language: Haskell2010
hs-source-dirs: test/integration test/integration/lib
other-modules:
StackTest
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
stack-0.1.10.0/CONTRIBUTING.md 0000644 0000000 0000000 00000006023 12630352213 013451 0 ustar 00 0000000 0000000 # Contributors Guide
## Bug Reports
When reporting a bug, please write in the following format:
> [Any general summary/comments if desired]
> **Steps to reproduce:**
> 1. _Remove directory *blah*._
> 2. _Run command `stack blah`._
> 3. _Edit file blah._
> 3. _Run command `stack blah`._
> **Expected:**
> _What I expected to see and happen._
> **Actual:**
> _What actually happened._
>
> Here is the `stack --version` output:
>
> ```
> $ stack --version
> Version 0.0.2, Git revision 6a86ee32e5b869a877151f74064572225e1a0398
> ```
> Here is the command I ran **with `--verbose`**:
>
> ```
> $ stack --verbose
>