stack 0.0.1 → 0.0.2
raw patch · 38 files changed
+2152/−1147 lines, 38 filesdep +base16-bytestringdep +conduit-combinators
Dependencies added: base16-bytestring, conduit-combinators
Files
- ChangeLog.md +13/−0
- README.md +10/−6
- src/Control/Concurrent/Execute.hs +18/−11
- src/Control/Monad/Logger/Sticky.hs +0/−112
- src/Data/Aeson/Extended.hs +23/−0
- src/Network/HTTP/Download.hs +2/−19
- src/Network/HTTP/Download/Verified.hs +61/−14
- src/Stack/Build.hs +7/−12
- src/Stack/Build/Cache.hs +55/−74
- src/Stack/Build/ConstructPlan.hs +112/−95
- src/Stack/Build/Execute.hs +399/−174
- src/Stack/Build/Installed.hs +12/−7
- src/Stack/Build/Source.hs +116/−34
- src/Stack/Build/Types.hs +80/−41
- src/Stack/BuildPlan.hs +8/−9
- src/Stack/Config.hs +207/−41
- src/Stack/Constants.hs +89/−62
- src/Stack/Docker.hs +73/−106
- src/Stack/Fetch.hs +58/−66
- src/Stack/GhcPkg.hs +14/−10
- src/Stack/Package.hs +8/−7
- src/Stack/PackageDump.hs +37/−22
- src/Stack/PackageIndex.hs +34/−33
- src/Stack/Setup.hs +147/−43
- src/Stack/Types/Config.hs +171/−28
- src/Stack/Types/Docker.hs +2/−2
- src/Stack/Types/FlagName.hs +1/−1
- src/Stack/Types/GhcPkgId.hs +1/−1
- src/Stack/Types/Internal.hs +16/−1
- src/Stack/Types/PackageIdentifier.hs +1/−1
- src/Stack/Types/PackageName.hs +1/−1
- src/Stack/Types/StackT.hs +125/−15
- src/Stack/Types/Version.hs +1/−1
- src/System/Process/Read.hs +124/−46
- src/System/Process/Run.hs +75/−0
- src/main/Main.hs +41/−46
- src/test/Stack/PackageDumpSpec.hs +4/−2
- stack.cabal +6/−4
ChangeLog.md view
@@ -1,3 +1,16 @@+## 0.0.2++* Fix some Windows specific bugs [#216](https://github.com/commercialhaskell/stack/issues/216)+* Improve output for package index updates [#227](https://github.com/commercialhaskell/stack/issues/227)+* Automatically update indices as necessary [#227](https://github.com/commercialhaskell/stack/issues/227)+* --verbose flag [#217](https://github.com/commercialhaskell/stack/issues/217)+* Remove packages (HTTPS and Git) [#199](https://github.com/commercialhaskell/stack/issues/199)+* Config values for system-ghc and install-ghc+* Merge `stack deps` functionality into `stack build`+* `install` command [#153](https://github.com/commercialhaskell/stack/issues/153) and [#272](https://github.com/commercialhaskell/stack/issues/272)+* overriding architecture value (useful to force 64-bit GHC on Windows, for example)+* Overhauled test running (allows cycles, avoids unnecessary recompilation, etc)+ ## 0.0.1 * First public release, beta quality
README.md view
@@ -46,12 +46,16 @@ A full description of the architecture [is available here](https://github.com/commercialhaskell/stack/wiki/Architecture). -#### Frequently Asked Questions+#### Questions, Feedback, Discussion -For frequently asked questions about detailed or specific use-cases,-please see [the FAQ](https://github.com/commercialhaskell/stack/wiki/FAQ) or-[open an issue](https://github.com/commercialhaskell/stack/issues/new) with label-`question`.+* For frequently asked questions about detailed or specific use-cases,+ please see+ [the FAQ](https://github.com/commercialhaskell/stack/wiki/FAQ).+* For general questions, comments, feedback and support please write+ to+ [the Commercial Haskell mailing list](https://groups.google.com/d/forum/commercialhaskell).+* For bugs, issues, or requests please+ [open an issue](https://github.com/commercialhaskell/stack/issues/new). #### Why stack? @@ -65,7 +69,7 @@ While stack itself has been around since June of 2015, it is based on codebases used by FP Complete for its corporate customers and internally for years prior. stack is a refresh of that codebase combined with other open source efforts-like [stackage-cli](https://github.com/commercialhaskell/stackage-cli) to meet the needs of+like [stackage-cli](https://github.com/fpco/stackage-cli) to meet the needs of users everywhere. A large impetus for the work on stack was a [large survey of people interested
src/Control/Concurrent/Execute.hs view
@@ -11,7 +11,7 @@ ) where import Control.Applicative-import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.Async (Concurrently (..), async) import Control.Concurrent.STM import Control.Exception import Control.Monad (join)@@ -24,8 +24,7 @@ data ActionType = ATBuild- | ATInstall- | ATWanted+ | ATFinal deriving (Show, Eq, Ord) data ActionId = ActionId !PackageIdentifier !ActionType deriving (Show, Eq, Ord)@@ -36,7 +35,7 @@ } data ActionContext = ActionContext- { acRemaining :: !Int+ { acRemaining :: !(Set ActionId) -- ^ Does not include the current action } deriving Show@@ -44,7 +43,8 @@ data ExecuteState = ExecuteState { esActions :: TVar [Action] , esExceptions :: TVar [SomeException]- , esInAction :: TVar Int+ , esInAction :: TVar (Set ActionId)+ , esCompleted :: TVar Int } data ExecuteException@@ -58,12 +58,15 @@ runActions :: Int -- ^ threads -> [Action]+ -> (TVar Int -> IO ()) -- ^ progress updated -> IO [SomeException]-runActions threads actions0 = do+runActions threads actions0 withProgress = do es <- ExecuteState <$> newTVarIO actions0 <*> newTVarIO []+ <*> newTVarIO Set.empty <*> newTVarIO 0+ _ <- async $ withProgress $ esCompleted es if threads <= 1 then runActions' es else runConcurrently $ sequenceA_ $ replicate threads $ Concurrently $ runActions' es@@ -87,7 +90,7 @@ case break (Set.null . actionDeps) as of (_, []) -> do inAction <- readTVar esInAction- if inAction == 0+ if Set.null inAction then do modifyTVar esExceptions (toException InconsistentDependencies:) return $ return ()@@ -95,9 +98,11 @@ (xs, action:ys) -> do let as' = xs ++ ys inAction <- readTVar esInAction- let remaining = length as' + inAction+ let remaining = Set.union+ (Set.fromList $ map actionId as')+ inAction writeTVar esActions as'- modifyTVar esInAction (+ 1)+ modifyTVar esInAction (Set.insert $ actionId action) return $ mask $ \restore -> do eres <- try $ restore $ actionDo action ActionContext { acRemaining = remaining@@ -105,10 +110,12 @@ case eres of Left err -> atomically $ do modifyTVar esExceptions (err:)- modifyTVar esInAction (subtract 1)+ modifyTVar esInAction (Set.delete $ actionId action)+ modifyTVar esCompleted (+1) Right () -> do atomically $ do- modifyTVar esInAction (subtract 1)+ modifyTVar esInAction (Set.delete $ actionId action)+ modifyTVar esCompleted (+1) let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a } modifyTVar esActions $ map dropDep restore loop
− src/Control/Monad/Logger/Sticky.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Output a sticky line at the end of output.--module Control.Monad.Logger.Sticky- (StickyLoggingT- ,runStickyLoggingT- ,logSticky)- where--import Control.Applicative-import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Trans.Class-import Control.Monad.Catch-import Control.Monad.Reader-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Monoid-import Language.Haskell.TH-import System.IO-import System.Log.FastLogger--import Prelude -- avoid AMP warnings--data State = State- { stateCurrentLine :: !(Maybe ByteString)- , stateMaxColumns :: !Int- , stateLastWasSticky :: !Bool- }--newtype StickyLoggingT m a = StickyLoggingT- { unStickyLoggingT :: ReaderT (MVar State) m a- } deriving (Functor,Applicative,Monad,MonadIO,MonadTrans,MonadThrow)--runStickyLoggingT :: MonadIO m => StickyLoggingT m a -> m a-runStickyLoggingT m = do- state <- liftIO (newMVar (State Nothing 0 False))- originalMode <- liftIO (hGetBuffering stdout)- liftIO (hSetBuffering stdout NoBuffering)- a <- runReaderT (unStickyLoggingT m) state- state' <- liftIO (takeMVar state)- liftIO (when (stateLastWasSticky state') (S8.putStr "\n"))- liftIO (hSetBuffering stdout originalMode)- return a--logSticky :: Q Exp-logSticky =- logOther "sticky"--instance (MonadLogger m, MonadIO m) => MonadLogger (StickyLoggingT m) where- monadLoggerLog loc src level msg = do- ref <- StickyLoggingT ask- state <- liftIO (takeMVar ref) -- TODO: make exception-safe.- case level of- LevelOther "sticky" ->- liftIO $- do S8.putStr- ("\r" <>- pad (stateMaxColumns state) msgBytes)- putMVar- ref- (state- { stateLastWasSticky = True- , stateMaxColumns = max- (stateMaxColumns state)- (S8.length msgBytes)- , stateCurrentLine = Just msgBytes- })- _ -> do- liftIO- (S8.putStr- ("\r" <>- S8.replicate- (stateMaxColumns state)- ' ' <>- "\r"))- lift (monadLoggerLog loc src level msg)- liftIO- (case stateCurrentLine state of- Nothing ->- putMVar- ref- (state- { stateLastWasSticky = False- , stateMaxColumns = max- (stateMaxColumns state)- (S8.length msgBytes)- })- Just line -> do- S8.putStr line- putMVar- ref- (state- { stateLastWasSticky = True- , stateMaxColumns = max- (stateMaxColumns state)- (S8.length msgBytes)- }))- where- msgBytes =- fromLogStr- (toLogStr msg)- pad width s =- S8.take- (max width (S8.length s))- (s <>- S8.replicate width ' ')
+ src/Data/Aeson/Extended.hs view
@@ -0,0 +1,23 @@+-- | The purpose of this module is to provide better failure messages+-- When parsing a key of an object, this makes sure the key itself will show up+module Data.Aeson.Extended (+ module Export+ , (.:)+ , (.:?)+ ) where++import Data.Aeson as Export hiding ((.:), (.:?))+import qualified Data.Aeson as A++import Data.Aeson.Types hiding ((.:), (.:?))++import Data.Text (unpack, Text)+import Data.Monoid ((<>))++(.:) :: FromJSON a => Object -> Text -> Parser a+(.:) o p = modifyFailure (("failed to parse field " <> unpack p <> ": ") <>) (o A..: p)+{-# INLINE (.:) #-}++(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)+(.:?) o p = modifyFailure (("failed to parse field " <> unpack p <> ": ") <>) (o A..:? p)+{-# INLINE (.:?) #-}
src/Network/HTTP/Download.hs view
@@ -5,6 +5,7 @@ ( verifiedDownload , DownloadRequest(..) , HashCheck(..)+ , CheckHexDigest(..) , LengthCheck , VerifiedDownloadException(..) @@ -25,7 +26,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)-import Data.Aeson (FromJSON, parseJSON)+import Data.Aeson.Extended (FromJSON, parseJSON) import Data.Aeson.Parser (json') import Data.Aeson.Types (parseEither) import qualified Data.ByteString as S@@ -71,24 +72,6 @@ } let progressHook = return () verifiedDownload downloadReq destpath progressHook-- -- env <- ask- -- liftIO $ unlessM (doesFileExist fp) $ do- -- createDirectoryIfMissing True dir- -- withBinaryFile fptmp WriteMode $ \h ->- -- flip runReaderT env $- -- withResponse req $ \res ->- -- responseBody res $$ sinkHandle h- -- renameFile fptmp fp- --where- -- unlessM mp m = do- -- p <- mp- -- if p then return () else m-- -- fp = toFilePath destpath- -- fptmp = fp <.> "tmp"- -- dir = toFilePath $ parent destpath- -- | Same as 'download', but will download a file a second time if it is already present. --
src/Network/HTTP/Download/Verified.hs view
@@ -10,6 +10,7 @@ ( verifiedDownload , DownloadRequest(..) , HashCheck(..)+ , CheckHexDigest(..) , LengthCheck , VerifiedDownloadException(..) ) where@@ -17,7 +18,6 @@ import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BC import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import qualified Data.Text as Text@@ -35,6 +35,7 @@ import Data.Conduit.Binary (sourceHandle, sinkHandle) import Data.Foldable (traverse_) import Data.Monoid+import Data.String import Data.Typeable (Typeable) import Network.HTTP.Client.Conduit import Network.HTTP.Types.Header (hContentLength, hContentMD5)@@ -54,10 +55,18 @@ data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck { hashCheckAlgorithm :: a- , hashCheckHexDigest :: String+ , 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.@@ -70,11 +79,26 @@ Int -- actual | WrongDigest String -- algorithm- String -- expected- String -- actual- deriving (Show, Typeable)+ CheckHexDigest -- expected+ String -- actual (shown)+ deriving (Typeable)+instance Show VerifiedDownloadException where+ show (WrongContentLength expected actual) =+ "Download expectation failure: ContentLength header\n"+ ++ "Expected: " ++ show expected ++ "\n"+ ++ "Actual: " ++ displayByteString actual+ show (WrongStreamLength expected actual) =+ "Download expectation failure: download size\n"+ ++ "Expected: " ++ show expected ++ "\n"+ ++ "Actual: " ++ show actual+ show (WrongDigest algo expected actual) =+ "Download expectation failure: content hash (" ++ algo ++ ")\n"+ ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"+ ++ "Actual: " ++ actual+ instance Exception VerifiedDownloadException +-- This exception is always caught and never thrown outside of this module. data VerifyFileException = WrongFileSize Int -- expected@@ -82,6 +106,20 @@ 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. --@@ -92,7 +130,18 @@ sinkCheckHash HashCheck{..} = do digest <- sinkHashUsing hashCheckAlgorithm let actualDigestString = show digest- when (actualDigestString /= hashCheckHexDigest) $+ 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++ when (not passedCheck) $ throwM $ WrongDigest (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString assertLengthSink :: MonadThrow m@@ -180,8 +229,7 @@ checkContentLengthHeader headers expectedContentLength = do case List.lookup hContentLength headers of Just lengthBS -> do- let lengthText = Text.strip $ Text.decodeUtf8 lengthBS- lengthStr = Text.unpack lengthText+ let lengthStr = displayByteString lengthBS when (lengthStr /= show expectedContentLength) $ throwM $ WrongContentLength expectedContentLength lengthBS _ -> return ()@@ -191,12 +239,11 @@ whenJust drLengthCheck $ checkContentLengthHeader headers let hashChecks = (case List.lookup hContentMD5 headers of Just md5BS ->- let md5ExpectedHexDigest = BC.unpack (B64.decodeLenient md5BS)- in [ HashCheck- { hashCheckAlgorithm = MD5- , hashCheckHexDigest = md5ExpectedHexDigest- }- ]+ [ HashCheck+ { hashCheckAlgorithm = MD5+ , hashCheckHexDigest = CheckHexDigestHeader md5BS+ }+ ] Nothing -> [] ) ++ drHashChecks
src/Stack/Build.hs view
@@ -23,10 +23,9 @@ import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource-import Data.Either import Data.Function import Data.Map.Strict (Map)-import qualified Data.Set as S+import qualified Data.Map as Map import Network.HTTP.Client.Conduit (HasHttpManager) import Path.IO import Prelude hiding (FilePath, writeFile)@@ -48,25 +47,23 @@ #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)+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) -- | Build build :: M env m => BuildOpts -> m () build bopts = do menv <- getMinimalEnvOverride- cabalPkgVer <- getCabalPkgVer menv - (mbp, locals, sourceMap) <- loadSourceMap bopts+ (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts (installedMap, locallyRegistered) <- getInstalled menv profiling sourceMap baseConfigOpts <- mkBaseConfigOpts bopts- let extraToBuild = either (const []) id $ boptsTargets bopts plan <- withLoadPackage menv $ \loadPackage -> constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap if boptsDryrun bopts- then printPlan plan- else executePlan menv bopts baseConfigOpts cabalPkgVer locals plan+ then printPlan (boptsFinalAction bopts) plan+ else executePlan menv bopts baseConfigOpts locals plan where profiling = boptsLibProfile bopts || boptsExeProfile bopts @@ -112,11 +109,9 @@ clean :: (M env m) => m () clean = do bconfig <- asks getBuildConfig- menv <- getMinimalEnvOverride- cabalPkgVer <- getCabalPkgVer menv forM_- (S.toList (bcPackages bconfig))- (distDirFromDir cabalPkgVer >=> removeTreeIfExists)+ (Map.keys (bcPackages bconfig))+ (distDirFromDir >=> removeTreeIfExists) ---------------------------------------------------------- -- DEAD CODE BELOW HERE
src/Stack/Build/Cache.hs view
@@ -6,6 +6,7 @@ module Stack.Build.Cache ( tryGetBuildCache , tryGetConfigCache+ , tryGetCabalMod , getPackageFileModTimes , getInstalledExes , buildCacheTimes@@ -15,40 +16,34 @@ , writeFlagCache , writeBuildCache , writeConfigCache+ , writeCabalMod ) where import Control.Exception.Enclosed (handleIO, tryIO)-import Control.Monad (liftM) import Control.Monad.Catch (MonadCatch, MonadThrow, catch, throwM) import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger)-import Control.Monad.Reader (MonadReader)-import Data.Binary (Binary)-import qualified Data.Binary as Binary-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, mapMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)-import Data.Time (UTCTime (..), toModifiedJulianDay)-import GHC.Generics (Generic)+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Reader+import Data.Binary (Binary)+import qualified Data.Binary as Binary+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as Set+import GHC.Generics (Generic) import Path import Path.IO import Stack.Build.Types import Stack.Constants-import Stack.GhcPkg (getCabalPkgVer) import Stack.Package import Stack.Types import System.Directory (createDirectoryIfMissing, getDirectoryContents, getModificationTime)-import System.IO.Error (isDoesNotExistError)+import System.IO.Error (isDoesNotExistError) -- | Directory containing files to mark an executable as installed exeInstalledDir :: (MonadReader env m, HasBuildConfig env, MonadThrow m)@@ -86,39 +81,28 @@ deriving (Generic,Eq) instance Binary BuildCache --- | Used for storage and comparison.-newtype ModTime = ModTime (Integer,Rational)- deriving (Ord,Show,Generic,Eq)-instance Binary ModTime---- | One-way conversion to serialized time.-modTime :: UTCTime -> ModTime-modTime x =- ModTime- ( toModifiedJulianDay- (utctDay x)- , toRational- (utctDayTime x))- -- | Try to read the dirtiness cache for the given package directory.-tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) => Path Abs Dir -> m (Maybe BuildCache) tryGetBuildCache = 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)+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, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)- => (PackageIdentifier -> Path Abs Dir -> m (Path Abs File))+tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+ => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a) tryGetCache get' dir = do- menv <- getMinimalEnvOverride- cabalPkgVer <- getCabalPkgVer menv- fp <- get' cabalPkgVer dir+ fp <- get' dir liftIO (catch (fmap (decodeMaybe . L.fromStrict) (S.readFile (toFilePath fp)))@@ -130,7 +114,7 @@ where thd (_,_,x) = x -- | Write the dirtiness cache for this package's files.-writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) => Path Abs Dir -> Map FilePath ModTime -> m () writeBuildCache dir times = writeCache@@ -141,57 +125,57 @@ }) -- | Write the dirtiness cache for this package's configuration.-writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) => Path Abs Dir- -> [Text]- -> Set GhcPkgId -- ^ dependencies+ -> ConfigCache -> m ()-writeConfigCache dir opts deps =- writeCache- dir- configCacheFile- (ConfigCache- { configCacheOpts = map encodeUtf8 opts- , configCacheDeps = deps- })+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)+deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> m () deleteCaches dir = do- menv <- getMinimalEnvOverride- cabalPkgVer <- getCabalPkgVer menv- bfp <- buildCacheFile cabalPkgVer dir+ {- FIXME confirm that this is acceptable to remove+ bfp <- buildCacheFile dir removeFileIfExists bfp- cfp <- configCacheFile cabalPkgVer dir+ -}+ cfp <- configCacheFile dir removeFileIfExists cfp -- | Write to a cache.-writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)+writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) => Path Abs Dir- -> (PackageIdentifier -> Path Abs Dir -> m (Path Abs File))+ -> (Path Abs Dir -> m (Path Abs File)) -> a -> m () writeCache dir get' content = do- menv <- getMinimalEnvOverride- cabalPkgVer <- getCabalPkgVer menv- fp <- get' cabalPkgVer dir+ fp <- get' dir liftIO (L.writeFile (toFilePath fp) (Binary.encode content)) flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasBuildConfig env)- => GhcPkgId+ => Installed -> m (Path Abs File)-flagCacheFile gid = do- rel <- parseRelFile $ ghcPkgIdString gid+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, HasBuildConfig env)- => GhcPkgId+ => Installed -> m (Maybe ConfigCache) tryGetFlagCache gid = do file <- flagCacheFile gid@@ -201,18 +185,15 @@ _ -> return Nothing writeFlagCache :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m)- => GhcPkgId- -> [ByteString]- -> Set GhcPkgId+ => Installed+ -> ConfigCache -> m ()-writeFlagCache gid flags deps = do+writeFlagCache gid cache = do file <- flagCacheFile gid liftIO $ do createDirectoryIfMissing True $ toFilePath $ parent file- Binary.encodeFile (toFilePath file) ConfigCache- { configCacheOpts = flags- , configCacheDeps = deps- }++ Binary.encodeFile (toFilePath file) cache -- | Get the modified times of all known files in the package, -- including the package's cabal file itself.
src/Stack/Build/ConstructPlan.hs view
@@ -13,26 +13,28 @@ import Control.Monad.IO.Class import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource-import qualified Data.ByteString.Char8 as S8+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.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.Encoding (encodeUtf8)-import Distribution.Package (Dependency (..))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Distribution.Package (Dependency (..)) import Distribution.Version (anyVersion, intersectVersionRanges)-import Prelude hiding (FilePath, pi, writeFile)+import Prelude hiding (FilePath, pi, writeFile) import Stack.Build.Cache import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Types import Stack.BuildPlan+ import Stack.Package import Stack.Types @@ -67,7 +69,9 @@ type M = RWST Ctx- (Map PackageName Task) -- JustFinal+ ( Map PackageName (Either ConstructPlanException Task) -- finals+ , Map Text Location -- executable to be installed, and location where the binary is placed+ ) (Map PackageName (Either ConstructPlanException AddDepRes)) IO @@ -79,6 +83,7 @@ , toolToPackages :: !(Dependency -> Map PackageName VersionRange) , ctxBuildConfig :: !BuildConfig , callStack :: ![PackageName]+ , extraToBuild :: !(Set PackageName) } instance HasStackRoot Ctx@@ -92,45 +97,50 @@ => MiniBuildPlan -> BaseConfigOpts -> [LocalPackage]- -> [PackageName] -- ^ additional packages that must be built+ -> Set PackageName -- ^ additional packages that must be built -> Set GhcPkgId -- ^ locally registered -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> m Plan-constructPlan mbp0 baseConfigOpts0 locals extraToBuild locallyRegistered loadPackage0 sourceMap installedMap = do+constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPackage0 sourceMap installedMap = do bconfig <- asks getBuildConfig- let inner = mapM_ addDep $ Set.toList allTargets- ((), m, justFinals) <- liftIO $ runRWST inner (ctx bconfig) M.empty+ let inner = do+ mapM_ addFinal $ filter lpWanted locals+ mapM_ addDep $ Set.toList extraToBuild0+ ((), m, (efinals, installExes)) <- liftIO $ runRWST inner (ctx bconfig) M.empty let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v)- case partitionEithers $ map toEither $ M.toList m of- ([], adrs) -> do+ (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 return Plan- { planTasks = Map.union tasks justFinals+ { planTasks = tasks+ , planFinals = M.fromList finals , planUnregisterLocal = mkUnregisterLocal tasks locallyRegistered+ , planInstallExes =+ if boptsInstallExes $ bcoBuildOpts baseConfigOpts0+ then installExes+ else Map.empty }- (errs, _) -> throwM $ ConstructPlanExceptions errs+ else throwM $ ConstructPlanExceptions errs where- allTargets = Set.fromList- $ map (packageName . lpPackage) (filter lpWanted locals) ++- extraToBuild- ctx bconfig = Ctx { mbp = mbp0 , baseConfigOpts = baseConfigOpts0 , loadPackage = loadPackage0 , combinedMap = combineMap sourceMap installedMap , toolToPackages = \ (Dependency name _) ->- Map.fromList- $ map (, anyVersion)- $ maybe [] Set.toList- $ Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap+ maybe Map.empty (Map.fromSet (\_ -> anyVersion)) $+ Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap , ctxBuildConfig = bconfig , callStack = []+ , extraToBuild = extraToBuild0 } toolMap = getToolMap mbp0 @@ -143,14 +153,39 @@ toUnregister gid = case M.lookup name tasks of Nothing -> False- Just task ->- case taskType task of- TTLocal _ JustFinal -> False- _ -> True+ Just _ -> True where ident = ghcPkgIdPackageIdentifier gid name = packageIdentifierName ident +addFinal :: LocalPackage -> M ()+addFinal lp = do+ void $ addDep $ packageName package++ depsRes <- addPackageDeps package+ res <- case depsRes of+ Left e -> return $ Left e+ Right (missing, present) -> do+ ctx <- ask+ return $ Right Task+ { taskProvides = PackageIdentifier+ (packageName package)+ (packageVersion package)+ , taskConfigOpts = TaskConfigOpts missing $ \missing' ->+ let allDeps = Set.union present missing'+ in configureOpts+ (baseConfigOpts ctx)+ allDeps+ True -- wanted+ Local+ (packageFlags package)+ , taskPresent = present+ , taskType = TTLocal lp+ }+ tell (Map.singleton (packageName package) res, mempty)+ where+ package = lpPackageFinal lp+ addDep :: PackageName -> M (Either ConstructPlanException AddDepRes) addDep name = do m <- get@@ -177,20 +212,44 @@ -- TODO look up in the package index and see if there's a -- recommendation available Nothing -> return $ Left $ UnknownPackage name- Just (PIOnlyInstalled version _ installed) ->+ Just (PIOnlyInstalled version loc installed) -> do+ tellExecutablesUpstream name version loc Map.empty -- slightly hacky, no flags since they likely won't affect executable names return $ Right $ ADRFound version installed- Just (PIOnlySource ps) -> installPackage Nothing name ps+ Just (PIOnlySource ps) -> do+ tellExecutables name ps+ installPackage name ps Just (PIBoth ps installed) -> do- mneededSteps <- checkNeededSteps name ps installed- case mneededSteps of- Nothing -> return $ Right $ ADRFound (piiVersion ps) installed- Just neededSteps -> installPackage (Just neededSteps) name ps+ tellExecutables name ps+ needInstall <- checkNeedInstall name ps installed+ if needInstall+ then installPackage name ps+ else return $ Right $ ADRFound (piiVersion ps) installed +tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above?+tellExecutables _ (PSLocal lp)+ | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp+ | otherwise = return ()+tellExecutables name (PSUpstream version loc flags) = do+ tellExecutablesUpstream name version loc flags++tellExecutablesUpstream :: PackageName -> Version -> Location -> 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 :: Location -> Package -> M ()+tellExecutablesPackage loc p =+ tell (Map.empty, m)+ where+ m = Map.fromList $ map (, loc) $ Set.toList $ packageExes p+ -- TODO There are a lot of duplicated computations below. I've kept that for -- simplicity right now -installPackage :: Maybe NeededSteps -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)-installPackage mneededSteps name ps = do+installPackage :: PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)+installPackage name ps = do ctx <- ask package <- psPackage name ps depsRes <- addPackageDeps package@@ -213,39 +272,18 @@ , taskType = case ps of PSLocal lp -> TTLocal lp- $ case mneededSteps of- Just neededSteps -> neededSteps- Nothing ->- case lpLastConfigOpts lp of- Nothing -> AllSteps- Just configOpts- | not $ Set.null missing -> AllSteps- | otherwise ->- let newOpts = configureOpts- (baseConfigOpts ctx)- present- (psWanted ps)- (piiLocation ps)- (packageFlags package)- configCache = ConfigCache- { configCacheOpts = map encodeUtf8 newOpts- , configCacheDeps = present- }- in if configCache == configOpts- then SkipConfig- else AllSteps PSUpstream _ loc _ -> TTUpstream package loc } -checkNeededSteps :: PackageName -> PackageSource -> Installed -> M (Maybe NeededSteps)-checkNeededSteps name ps installed = assert (piiLocation ps == Local) $ do+checkNeedInstall :: PackageName -> PackageSource -> Installed -> M Bool+checkNeedInstall name ps installed = assert (piiLocation ps == Local) $ do package <- psPackage name ps depsRes <- addPackageDeps package case depsRes of- Left _e -> return $ Just AllSteps -- installPackage will find the error again+ Left _e -> return True -- installPackage will find the error again Right (missing, present) | Set.null missing -> checkDirtiness ps installed package present- | otherwise -> return $ Just AllSteps+ | otherwise -> return True addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId)) addPackageDeps package = do@@ -263,13 +301,17 @@ return $ Left (depname, (range, DependencyMismatch $ adrVersion adr)) Right (ADRToInstall task) -> return $ Right (Set.singleton $ taskProvides task, Set.empty)- Right (ADRFound _ Executable) -> return $ Right+ Right (ADRFound _ (Executable _)) -> return $ Right (Set.empty, Set.empty) Right (ADRFound _ (Library gid)) -> return $ Right (Set.empty, Set.singleton gid) case partitionEithers deps of ([], pairs) -> return $ Right $ mconcat pairs- (errs, _) -> return $ Left $ DependencyPlanFailures (packageName package) (Map.fromList errs)+ (errs, _) -> return $ Left $ DependencyPlanFailures+ (PackageIdentifier+ (packageName package)+ (packageVersion package))+ (Map.fromList errs) where adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task adrVersion (ADRFound v _) = v@@ -278,9 +320,8 @@ -> Installed -> Package -> Set GhcPkgId- -> M (Maybe NeededSteps)-checkDirtiness _ Executable _ _ = return Nothing -- TODO reinstall executables in the future-checkDirtiness ps (Library installed) package present = do+ -> M Bool+checkDirtiness ps installed package present = do ctx <- ask let configOpts = configureOpts (baseConfigOpts ctx)@@ -292,38 +333,14 @@ { configCacheOpts = map encodeUtf8 configOpts , configCacheDeps = present }- moldOpts <- psOldOpts ps installed+ moldOpts <- tryGetFlagCache installed case moldOpts of- Nothing -> return $ Just AllSteps- Just oldOpts- | oldOpts /= configCache -> return $ Just AllSteps- | psDirty ps -> return $ Just SkipConfig- | otherwise -> do- case ps of- PSLocal lp | lpWanted lp -> do- -- track the fact that we need to perform a JustFinal. But- -- don't put this in the main State Map, as that would- -- trigger dependencies to rebuild also.- tell $ Map.singleton (packageName package) Task- { taskProvides = PackageIdentifier- (packageName package)- (packageVersion package)- , taskType = TTLocal lp JustFinal- , taskConfigOpts = TaskConfigOpts Set.empty $ \missing' ->- assert (Set.null missing') configOpts- , taskPresent = present- }- -- FIXME need to force reconfigure when GhcPkgId for dependencies change- _ -> return ()- return Nothing+ Nothing -> return True+ Just oldOpts -> return $ oldOpts /= configCache || psDirty ps psDirty :: PackageSource -> Bool psDirty (PSLocal lp) = lpDirtyFiles lp psDirty (PSUpstream _ _ _) = False -- files never change in an upstream package--psOldOpts :: PackageSource -> GhcPkgId -> M (Maybe ConfigCache)-psOldOpts (PSLocal lp) _ = return $ lpLastConfigOpts lp-psOldOpts (PSUpstream _ _ _) installed = tryGetFlagCache installed psWanted :: PackageSource -> Bool psWanted (PSLocal lp) = lpWanted lp
src/Stack/Build/Execute.hs view
@@ -10,7 +10,8 @@ , executePlan ) where -import Control.Concurrent (forkIO, getNumCapabilities)+import Control.Applicative ((<$>), (<*>))+import Control.Concurrent.Lifted (fork) import Control.Concurrent.Execute import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM@@ -39,33 +40,41 @@ import qualified Data.Streaming.Process as Process import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Text.Encoding (encodeUtf8) import Distribution.System (OS (Windows), Platform (Platform)) import Network.HTTP.Client.Conduit (HasHttpManager) import Path+import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache import Stack.Build.Installed import Stack.Build.Types-import Stack.Constants import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package+import Stack.Constants import Stack.Types+import Stack.Types.StackT import Stack.Types.Internal import System.Directory hiding (findExecutable, findFiles)+import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess))+import qualified System.FilePath as FP import System.IO import System.IO.Temp (withSystemTempDirectory) import System.Process.Internals (createProcess_) import System.Process.Read -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)+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) -printPlan :: M env m => Plan -> m ()-printPlan plan = do+printPlan :: M env m+ => FinalAction+ -> Plan+ -> m ()+printPlan finalAction plan = do case Set.toList $ planUnregisterLocal plan of [] -> $logInfo "Nothing to unregister" xs -> do@@ -80,6 +89,38 @@ $logInfo "Would build:" mapM_ ($logInfo . displayTask) xs + let mfinalLabel =+ case finalAction of+ DoNothing -> Nothing+ DoBenchmarks -> Just "benchmark"+ DoTests -> Just "test"+ DoHaddock -> Just "haddock"+ case mfinalLabel of+ Nothing -> return ()+ Just finalLabel -> do+ $logInfo ""++ case Map.toList $ planFinals plan of+ [] -> $logInfo $ "Nothing to " <> finalLabel+ xs -> do+ $logInfo $ "Would " <> finalLabel <> ":"+ forM_ xs $ \(name, _) -> $logInfo $ T.pack $ packageNameString name++ $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@@ -90,12 +131,8 @@ Local -> "local" , ", source=" , case taskType task of- TTLocal lp steps -> concat+ TTLocal lp -> concat [ toFilePath $ lpDir lp- , case steps of- AllSteps -> " (configure)"- SkipConfig -> " (build)"- JustFinal -> " (already built)" ] TTUpstream _ _ -> "package index" , if Set.null missing@@ -114,7 +151,7 @@ , eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed)) , eeTempDir :: !(Path Abs Dir) , eeSetupHs :: !(Path Abs File)- , eeCabalPkgVer :: !PackageIdentifier+ , eeCabalPkgVer :: !Version , eeTotalWanted :: !Int } @@ -123,11 +160,10 @@ => EnvOverride -> BuildOpts -> BaseConfigOpts- -> PackageIdentifier -- ^ cabal version -> [LocalPackage] -> Plan -> m ()-executePlan menv bopts baseConfigOpts cabalPkgVer locals plan =+executePlan menv bopts baseConfigOpts locals plan = do withSystemTempDirectory stackProgName $ \tmpdir -> do tmpdir' <- parseAbsDir tmpdir configLock <- newMVar ()@@ -135,6 +171,7 @@ idMap <- liftIO $ newTVarIO M.empty let setupHs = tmpdir' </> $(mkRelFile "Setup.hs") liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"+ cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) executePlan' plan ExecuteEnv { eeEnvOverride = menv , eeBuildOpts = bopts@@ -152,6 +189,66 @@ , eeTotalWanted = length $ filter lpWanted locals } + unless (Map.null $ planInstallExes plan) $ do+ snapBin <- (</> bindirSuffix) `liftM` installationRootDeps+ localBin <- (</> bindirSuffix) `liftM` installationRootLocal+ destDir <- asks $ configLocalBin . getConfig+ let destDir' = toFilePath destDir+ liftIO $ createDirectoryIfMissing True destDir'++ when (not $ any (FP.equalFilePath destDir') (envSearchPath menv)) $+ $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++ forM_ (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 -> $logWarn $ T.concat+ [ "Couldn't find executable "+ , name+ , " in directory "+ , T.pack $ toFilePath bindir+ ]+ 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+ _ -> copyFile (toFilePath file) destFile++-- | 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+ copyFile src new+ renameFile dest old+ renameFile new dest+ where+ new = dest ++ ".new"+ old = dest ++ ".old"+ -- | Perform the actual plan (internal) executePlan' :: M env m => Plan@@ -175,151 +272,146 @@ -- stack always using transformer stacks that are safe for this use case. runInBase <- liftBaseWith $ \run -> return (void . run) - let actions = concatMap (toActions runInBase ee) $ Map.elems $ planTasks plan- threads <- liftIO getNumCapabilities -- TODO make a build opt to override this- errs <- liftIO $ runActions threads actions+ let actions = concatMap (toActions 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+ errs <- liftIO $ runActions threads actions $ \doneVar -> do+ let total = length actions+ loop prev+ | prev == total =+ runInBase $ $logStickyDone ("Completed all " <> T.pack (show total) <> " actions.")+ | otherwise = do+ 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 () unless (null errs) $ throwM $ ExecutionFailure errs toActions :: M env m => (m () -> IO ()) -> ExecuteEnv- -> Task+ -> (Maybe Task, Maybe Task) -- build and final -> [Action]-toActions runInBase ee task@Task {..} =- -- TODO in the future, we need to have proper support for cyclic- -- dependencies from test suites, in which case we'll need more than one- -- Action here+toActions 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 ac ee task+ }+ ]+ afinal =+ case (,) <$> mfinal <*> mfunc of+ Just (task@Task {..}, (func, checkTask)) | checkTask task ->+ [ Action+ { actionId = ActionId taskProvides ATFinal+ , actionDeps = addBuild taskProvides $+ (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))+ , actionDo = \ac -> runInBase $ func ac ee task+ }+ ]+ _ -> []+ where+ addBuild ident =+ case mbuild of+ Nothing -> id+ Just _ -> Set.insert $ ActionId ident ATBuild - [ Action- { actionId = ActionId taskProvides ATBuild- , actionDeps =- (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))- , actionDo = \ac -> runInBase $ singleBuild ac ee task- }- ]+ mfunc =+ case boptsFinalAction $ eeBuildOpts ee of+ DoNothing -> Nothing+ DoTests -> Just (singleTest, checkTest)+ DoBenchmarks -> Just (singleBench, checkBench)+ DoHaddock -> Just (singleHaddock, const True) -singleBuild :: M env m- => ActionContext- -> ExecuteEnv- -> Task- -> m ()-singleBuild ActionContext {..} ExecuteEnv {..} task@Task {..} =- withPackage $ \package cabalfp pkgDir ->- withLogFile package $ \mlogFile ->- withCabal pkgDir mlogFile $ \cabal -> do- mconfigOpts <- if needsConfig- then withMVar eeConfigureLock $ \_ -> do- deleteCaches pkgDir- idMap <- liftIO $ readTVarIO eeGhcPkgIds- let getMissing ident =- case Map.lookup ident idMap of- Nothing -> error "singleBuild: invariant violated, missing package ID missing"- Just (Library x) -> Just x- Just Executable -> Nothing- missing' = Set.fromList $ mapMaybe getMissing $ Set.toList missing- TaskConfigOpts missing mkOpts = taskConfigOpts- configOpts = mkOpts missing'- allDeps = Set.union missing' taskPresent- announce "configure"- cabal False $ "configure" : map T.unpack configOpts- $logDebug $ T.pack $ show configOpts- writeConfigCache pkgDir configOpts allDeps- return $ Just (configOpts, allDeps)- else return Nothing+ checkTest task =+ case taskType task of+ TTLocal lp -> not $ Set.null $ packageTests $ lpPackage lp+ _ -> assert False False - fileModTimes <- getPackageFileModTimes package cabalfp- writeBuildCache pkgDir fileModTimes+ checkBench task =+ case taskType task of+ TTLocal lp -> not $ Set.null $ packageBenchmarks $ lpPackage lp+ _ -> assert False False - unless justFinal $ do- announce "build"- config <- asks getConfig- cabal (console && configHideTHLoading config) ["build"]+-- | Ensure that the configuration for the package matches what is given+ensureConfig :: M env m+ => Path Abs Dir -- ^ package directory+ -> ExecuteEnv+ -> Task+ -> m () -- ^ announce+ -> (Bool -> [String] -> m ()) -- ^ cabal+ -> Path Abs File -- ^ .cabal file+ -> [Text]+ -> m (ConfigCache, Bool)+ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do+ -- Determine the old and new configuration in the local directory, to+ -- determine if we need to reconfigure.+ mOldConfigCache <- tryGetConfigCache pkgDir - case boptsFinalAction eeBuildOpts of- DoTests -> when wanted $ do- announce "test"- runTests package pkgDir mlogFile- DoBenchmarks -> when wanted $ do- announce "benchmarks"- cabal False ["bench"]- DoHaddock -> do- announce "haddock"- hscolourExists <- doesExecutableExist eeEnvOverride "hscolour"- {- EKB TODO: doc generation for stack-doc-server- #ifndef mingw32_HOST_OS- liftIO (removeDocLinks docLoc package)- #endif- ifcOpts <- liftIO (haddockInterfaceOpts docLoc package packages)- -}- cabal False (concat [["haddock", "--html"]- ,["--hyperlink-source" | hscolourExists]])- {- EKB TODO: doc generation for stack-doc-server- ,"--hoogle"- ,"--html-location=../$pkg-$version/"- ,"--haddock-options=" ++ intercalate " " ifcOpts ]- haddockLocs <-- liftIO (findFiles (packageDocDir package)- (\loc -> FilePath.takeExtensions (toFilePath loc) ==- "." ++ haddockExtension)- (not . isHiddenDir))- forM_ haddockLocs $ \haddockLoc ->- do let hoogleTxtPath = FilePath.replaceExtension (toFilePath haddockLoc) "txt"- hoogleDbPath = FilePath.replaceExtension hoogleTxtPath hoogleDbExtension- hoogleExists <- liftIO (doesFileExist hoogleTxtPath)- when hoogleExists- (callProcess- "hoogle"- ["convert"- ,"--haddock"- ,hoogleTxtPath- ,hoogleDbPath])- -}- {- EKB TODO: doc generation for stack-doc-server- #ifndef mingw32_HOST_OS- case setupAction of- DoHaddock -> liftIO (createDocLinks docLoc package)- _ -> return ()- #endif+ mOldCabalMod <- tryGetCabalMod pkgDir+ newCabalMod <- liftIO (fmap modTime (getModificationTime (toFilePath cabalfp))) --- | Package's documentation directory.-packageDocDir :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> Package- -> m (Path Abs Dir)-packageDocDir cabalPkgVer package' = do- dist <- distDirFromDir cabalPkgVer (packageDir package')- return (dist </> $(mkRelDir "doc/"))- --}- DoNothing -> return ()+ idMap <- liftIO $ readTVarIO eeGhcPkgIds+ let getMissing ident =+ case Map.lookup ident idMap of+ Nothing -> error "singleBuild: invariant violated, missing package ID missing"+ Just (Library x) -> Just x+ Just (Executable _) -> Nothing+ missing' = Set.fromList $ mapMaybe getMissing $ Set.toList missing+ TaskConfigOpts missing mkOpts = taskConfigOpts+ configOpts = mkOpts missing' ++ extra+ allDeps = Set.union missing' taskPresent+ newConfigCache = ConfigCache+ { configCacheOpts = map encodeUtf8 configOpts+ , configCacheDeps = allDeps+ } - unless justFinal $ withMVar eeInstallLock $ \_ -> do- announce "install"- cabal False ["install"]+ let needConfig = mOldConfigCache /= Just newConfigCache+ || mOldCabalMod /= Just newCabalMod+ when needConfig $ withMVar eeConfigureLock $ \_ -> do+ deleteCaches pkgDir+ announce+ cabal False $ "configure" : map T.unpack configOpts+ $logDebug $ T.pack $ show configOpts+ writeConfigCache pkgDir newConfigCache+ writeCabalMod pkgDir newCabalMod - -- It seems correct to leave this outside of the "justFinal" check above,- -- in case another package depends on a justFinal target- let pkgDbs =- case taskLocation task of- Snap -> [bcoSnapDB eeBaseConfigOpts]- Local ->- [ bcoSnapDB eeBaseConfigOpts- , bcoLocalDB eeBaseConfigOpts- ]- mpkgid <- findGhcPkgId eeEnvOverride pkgDbs (packageName package)- mpkgid' <- case (packageHasLibrary package, mpkgid) of- (False, _) -> assert (isNothing mpkgid) $ do- markExeInstalled (taskLocation task) taskProvides- return Executable- (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package- (True, Just pkgid) -> do- case mconfigOpts of- Nothing -> return ()- Just (configOpts, deps) -> writeFlagCache- pkgid- (map encodeUtf8 configOpts)- deps- return $ Library pkgid- liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid'+ return (newConfigCache, needConfig)++withSingleContext :: M env m+ => ActionContext+ -> ExecuteEnv+ -> Task+ -> ( Package+ -> Path Abs File+ -> Path Abs Dir+ -> (Bool -> [String] -> m ())+ -> (Text -> m ())+ -> Bool+ -> Maybe (Path Abs File, Handle)+ -> m a)+ -> m a+withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 =+ withPackage $ \package cabalfp pkgDir ->+ withLogFile package $ \mlogFile ->+ withCabal pkgDir mlogFile $ \cabal ->+ inner0 package cabalfp pkgDir cabal announce console mlogFile where announce x = $logInfo $ T.concat [ T.pack $ packageIdentifierString taskProvides@@ -327,27 +419,20 @@ , x ] - needsConfig =- case taskType of- TTLocal _ y -> y == AllSteps- TTUpstream _ _ -> True- justFinal =- case taskType of- TTLocal _ JustFinal -> True- _ -> False- wanted = case taskType of- TTLocal lp _ -> lpWanted lp+ TTLocal lp -> lpWanted lp TTUpstream _ _ -> False - console = wanted && acRemaining == 0 && eeTotalWanted == 1+ 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)+ TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) TTUpstream package _ -> do- mdist <- liftM Just $ distRelativeDir eeCabalPkgVer+ mdist <- liftM Just distRelativeDir m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides case M.toList m of [(ident, dir)]@@ -361,7 +446,7 @@ withLogFile package inner | console = inner Nothing | otherwise = do- logPath <- buildLogPath package+ logPath <- buildLogPath package -- TODO give a difference suffix for test, bench, etc? liftIO $ createDirectoryIfMissing True $ toFilePath $ parent logPath let fp = toFilePath logPath bracket@@ -376,12 +461,15 @@ , esIncludeGhcPackagePath = False } exeName <- liftIO $ join $ findExecutable menv "runhaskell"- distRelativeDir' <- distRelativeDir eeCabalPkgVer+ distRelativeDir' <- distRelativeDir msetuphs <- liftIO $ getSetupHs pkgDir let setuphs = fromMaybe eeSetupHs msetuphs inner $ \stripTHLoading args -> do let fullArgs =- ("-package=" ++ packageIdentifierString eeCabalPkgVer)+ ("-package=" +++ packageIdentifierString+ (PackageIdentifier cabalPackageName+ eeCabalPkgVer)) : "-clear-package-db" : "-global-package-db" -- TODO: Perhaps we want to include the snapshot package database here@@ -395,10 +483,8 @@ , Process.env = envHelper menv , std_in = CreatePipe , std_out =- if stripTHLoading- then CreatePipe- else case mlogFile of- Nothing -> Inherit+ case mlogFile of+ Nothing -> CreatePipe Just (_, h) -> UseHandle h , std_err = case mlogFile of@@ -411,7 +497,10 @@ (Just inH, moutH, Nothing, ph) <- liftIO $ createProcess_ "singleBuild" cp liftIO $ hClose inH case moutH of- Just outH -> assert stripTHLoading $ printWithoutTHLoading outH+ Just outH ->+ case mlogFile of+ Just{} -> return ()+ Nothing -> printBuildOutput stripTHLoading outH Nothing -> return () ec <- liftIO $ waitForProcess ph case ec of@@ -431,9 +520,65 @@ (fmap fst mlogFile) bs - runTests package pkgDir mlogFile = do+singleBuild :: M env m+ => ActionContext+ -> ExecuteEnv+ -> Task+ -> m ()+singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =+ withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console _mlogFile -> do+ (cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp []++ fileModTimes <- getPackageFileModTimes package cabalfp+ writeBuildCache pkgDir fileModTimes++ announce "build"+ config <- asks getConfig+ cabal (console && configHideTHLoading config) ["build"]++ withMVar eeInstallLock $ \() -> do+ announce "install"+ cabal False ["install"]++ let pkgDbs =+ case taskLocation task of+ Snap -> [bcoSnapDB eeBaseConfigOpts]+ Local ->+ [ bcoSnapDB eeBaseConfigOpts+ , bcoLocalDB eeBaseConfigOpts+ ]+ mpkgid <- findGhcPkgId eeEnvOverride pkgDbs (packageName package)+ mpkgid' <- case (packageHasLibrary package, mpkgid) of+ (False, _) -> assert (isNothing mpkgid) $ do+ markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?+ return $ Executable $ PackageIdentifier+ (packageName package)+ (packageVersion package)+ (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package+ (True, Just pkgid) -> return $ Library pkgid+ writeFlagCache mpkgid' cache+ liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid'++singleTest :: M env m+ => ActionContext+ -> ExecuteEnv+ -> Task+ -> m ()+singleTest ac ee task =+ withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console mlogFile -> do+ (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"]+ config <- asks getConfig++ let needBuild = neededConfig ||+ (case taskType task of+ TTLocal lp -> lpDirtyFiles lp+ _ -> assert False True)+ when needBuild $ do+ announce "build (test)"+ cabal (console && configHideTHLoading config) ["build"]+ bconfig <- asks getBuildConfig- distRelativeDir' <- distRelativeDir eeCabalPkgVer+ distRelativeDir' <- distRelativeDir let buildDir = pkgDir </> distRelativeDir' let exeExtension = case configPlatform $ getConfig bconfig of@@ -445,7 +590,6 @@ nameExe <- liftIO $ parseRelFile $ T.unpack testName ++ exeExtension let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe exists <- liftIO $ doesFileExist $ toFilePath exeName- config <- asks getConfig menv <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True@@ -482,20 +626,101 @@ , T.pack $ packageNameString $ packageName package ] return $ Map.singleton testName Nothing- unless (Map.null errs) $ throwM $ TestSuiteFailure taskProvides errs (fmap fst mlogFile)+ unless (Map.null errs) $ throwM $ TestSuiteFailure+ (taskProvides task)+ errs+ (fmap fst mlogFile) +singleBench :: M env m+ => ActionContext+ -> ExecuteEnv+ -> Task+ -> m ()+singleBench ac ee task =+ withSingleContext ac ee task $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do+ (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"]++ let needBuild = neededConfig ||+ (case taskType task of+ TTLocal lp -> lpDirtyFiles lp+ _ -> assert False True)+ when needBuild $ do+ announce "build (benchmarks)"+ config <- asks getConfig+ cabal (console && configHideTHLoading config) ["build"]++ announce "benchmarks"+ cabal False ["bench"]++singleHaddock :: M env m+ => ActionContext+ -> ExecuteEnv+ -> Task+ -> m ()+singleHaddock ac ee task =+ withSingleContext ac ee task $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do+ announce "haddock"+ hscolourExists <- doesExecutableExist (eeEnvOverride ee) "hscolour"+ {- EKB TODO: doc generation for stack-doc-server+ #ifndef mingw32_HOST_OS+ liftIO (removeDocLinks docLoc package)+ #endif+ ifcOpts <- liftIO (haddockInterfaceOpts docLoc package packages)+ -}+ cabal False (concat [["haddock", "--html"]+ ,["--hyperlink-source" | hscolourExists]])+ {- EKB TODO: doc generation for stack-doc-server+ ,"--hoogle"+ ,"--html-location=../$pkg-$version/"+ ,"--haddock-options=" ++ intercalate " " ifcOpts ]+ haddockLocs <-+ liftIO (findFiles (packageDocDir package)+ (\loc -> FilePath.takeExtensions (toFilePath loc) ==+ "." ++ haddockExtension)+ (not . isHiddenDir))+ forM_ haddockLocs $ \haddockLoc ->+ do let hoogleTxtPath = FilePath.replaceExtension (toFilePath haddockLoc) "txt"+ hoogleDbPath = FilePath.replaceExtension hoogleTxtPath hoogleDbExtension+ hoogleExists <- liftIO (doesFileExist hoogleTxtPath)+ when hoogleExists+ (callProcess+ "hoogle"+ ["convert"+ ,"--haddock"+ ,hoogleTxtPath+ ,hoogleDbPath])+ -}+ {- EKB TODO: doc generation for stack-doc-server+ #ifndef mingw32_HOST_OS+ case setupAction of+ DoHaddock -> liftIO (createDocLinks docLoc package)+ _ -> return ()+ #endif++ -- | Package's documentation directory.+ packageDocDir :: (MonadThrow m, MonadReader env m, HasPlatform env)+ => PackageIdentifier -- ^ Cabal version+ -> Package+ -> m (Path Abs Dir)+ packageDocDir cabalPkgVer package' = do+ dist <- distDirFromDir cabalPkgVer (packageDir package')+ return (dist </> $(mkRelDir "doc/"))+ --}+ -- | Grab all output from the given @Handle@ and print it to stdout, stripping -- Template Haskell "Loading package" lines. Does work in a separate thread.-printWithoutTHLoading :: MonadIO m => Handle -> m ()-printWithoutTHLoading outH = liftIO $ void $ forkIO $- CB.sourceHandle outH+printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)+ => Bool -> Handle -> m ()+printBuildOutput excludeTHLoading outH = void $ fork $+ CB.sourceHandle outH $$ CB.lines =$ CL.filter (not . isTHLoading)- =$ CL.mapM_ S8.putStrLn+ =$ CL.mapM_ ($logInfo . T.decodeUtf8) 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)@@ -503,7 +728,7 @@ taskLocation :: Task -> Location taskLocation task = case taskType task of- TTLocal _ _ -> Local+ TTLocal _ -> Local TTUpstream _ loc -> loc -- | Ensure Setup.hs exists in the given directory. Returns an action
src/Stack/Build/Installed.hs view
@@ -41,13 +41,11 @@ data LoadHelper = LoadHelper { lhId :: !GhcPkgId , lhDeps :: ![GhcPkgId]- , lhPair :: !(PackageName, (Version, Location, Installed))+ , lhPair :: !(PackageName, (Version, Location, Installed)) -- TODO Version is now redundant and can be gleaned from Installed } deriving Show -type InstalledMap = Map PackageName (Version, Location, Installed)-data Installed = Library GhcPkgId | Executable- deriving (Show, Eq, Ord)+type InstalledMap = Map PackageName (Version, Location, Installed) -- TODO Version is now redundant and can be gleaned from Installed -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: (M env m, PackageInstallInfo pii)@@ -103,7 +101,7 @@ -- Passed all the tests, mark this as installed! _ -> m where- m = Map.singleton name (version, loc, Executable)+ m = Map.singleton name (version, loc, Executable $ PackageIdentifier name version) exesSnap <- getInstalledExes Snap exesLocal <- getInstalledExes Local let installedMap = Map.unions@@ -172,8 +170,15 @@ where toInclude = case Map.lookup name sourceMap of- -- The sourceMap has nothing to say about this package, so we can use it- Nothing -> True+ Nothing ->+ case mloc of+ -- The sourceMap has nothing to say about this global+ -- package, so we can use it+ Nothing -> True+ -- For non-global packages, don't include unknown packages.+ -- See:+ -- https://github.com/commercialhaskell/stack/issues/292+ Just _ -> False Just pii -> version == piiVersion pii -- only accept the desired version
src/Stack/Build/Source.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -- Load information on package sources module Stack.Build.Source ( loadSourceMap@@ -10,6 +11,7 @@ ) where import Network.HTTP.Client.Conduit (HasHttpManager)+import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class@@ -17,12 +19,14 @@ import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource import Data.Either+import qualified Data.Foldable as F import Data.Function import Data.List 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 qualified Data.Text as T import Path@@ -31,7 +35,9 @@ import Stack.Build.Types import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan)+import Stack.Constants (wiredInPackages) import Stack.Package+import Stack.PackageIndex import Stack.Types import System.Directory hiding (findExecutable, findFiles) @@ -46,9 +52,13 @@ piiLocation (PSLocal _) = Local piiLocation (PSUpstream _ loc _) = loc -loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m)+loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env) => BuildOpts- -> m (MiniBuildPlan, [LocalPackage], SourceMap)+ -> m ( MiniBuildPlan+ , [LocalPackage]+ , Set PackageName -- non-local targets+ , SourceMap+ ) loadSourceMap bopts = do bconfig <- asks getBuildConfig mbp0 <- case bcResolver bconfig of@@ -61,71 +71,102 @@ , mbpPackages = Map.empty } - locals <- loadLocals bopts+ menv <- getMinimalEnvOverride+ caches <- getPackageCaches menv+ let latestVersion = Map.fromList $ map toTuple $ Map.keys caches+ (locals, extraNames, extraIdents) <- loadLocals bopts latestVersion + let nonLocalTargets = extraNames <> Set.map packageIdentifierName extraIdents++ -- Extend extra-deps to encompass targets requested on the command line+ -- that are not in the snapshot.+ extraDeps0 = extendExtraDeps+ (bcExtraDeps bconfig)+ mbp0+ latestVersion+ extraNames+ extraIdents+ let shadowed = Set.fromList (map (packageName . lpPackage) locals)- <> Map.keysSet (bcExtraDeps bconfig)- (mbp, extraDeps0) = shadowMiniBuildPlan mbp0 shadowed+ <> Map.keysSet extraDeps0+ (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed -- Add the extra deps from the stack.yaml file to the deps grabbed from -- the snapshot- extraDeps1 = Map.union- (Map.map (\v -> (v, Map.empty)) (bcExtraDeps bconfig))- (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi)) extraDeps0)+ extraDeps2 = Map.union+ (Map.map (\v -> (v, Map.empty)) extraDeps0)+ (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi)) extraDeps1) -- Overwrite any flag settings with those from the config file- extraDeps2 = Map.mapWithKey+ extraDeps3 = Map.mapWithKey (\n (v, f) -> PSUpstream v Local $ fromMaybe f $ Map.lookup n $ bcFlags bconfig)- extraDeps1+ extraDeps2 let sourceMap = Map.unions [ Map.fromList $ flip map locals $ \lp -> let p = lpPackage lp in (packageName p, PSLocal lp)- , extraDeps2+ , extraDeps3 , flip fmap (mbpPackages mbp) $ \mpi -> (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi))- ]+ ] `Map.difference` Map.fromList (map (, ()) wiredInPackages) - return (mbp, locals, sourceMap)+ let unknown = Set.difference nonLocalTargets $ Map.keysSet sourceMap+ unless (Set.null unknown) $ do+ let toEither name =+ case Map.lookup name latestVersion of+ Nothing -> Left name+ Just version -> Right (name, version)+ eithers = map toEither $ Set.toList unknown+ (unknown', notInIndex) = partitionEithers eithers+ throwM $ UnknownTargets+ (Set.fromList unknown')+ (Map.fromList notInIndex)+ (bcStackYaml bconfig) -loadLocals :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+ return (mbp, locals, nonLocalTargets, sourceMap)++-- | Returns locals and extra target packages+loadLocals :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m,HasEnvConfig env) => BuildOpts- -> m [LocalPackage]-loadLocals bopts = do+ -> Map PackageName Version+ -> m ([LocalPackage], Set PackageName, Set PackageIdentifier)+loadLocals bopts latestVersion = do targets <- mapM parseTarget $ case boptsTargets bopts of- Left [] -> ["."]- Left x -> x- Right _ -> []- (dirs, names0) <- case partitionEithers targets of- ([], targets') -> return $ partitionEithers targets'+ [] -> ["."]+ x -> x+ (dirs, (names0, idents)) <- case partitionEithers targets of+ ([], targets') -> return $ fmap partitionEithers $ partitionEithers targets' (bad, _) -> throwM $ Couldn'tParseTargets bad let names = Set.fromList names0 bconfig <- asks getBuildConfig- lps <- forM (Set.toList $ bcPackages bconfig) $ \dir -> do+ lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do cabalfp <- getCabalFileName dir name <- parsePackageNameFromFilePath cabalfp- let wanted = isWanted dirs names dir name- pkg <- readPackage- PackageConfig- { packageConfigEnableTests = wanted && boptsFinalAction bopts == DoTests- , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks+ let wanted = validWanted && isWanted dirs names dir name+ config = PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False , packageConfigFlags = localFlags bopts bconfig name , packageConfigGhcVersion = bcGhcVersion bconfig , packageConfigPlatform = configPlatform $ getConfig bconfig }- cabalfp+ configFinal = config+ { packageConfigEnableTests = wanted && boptsFinalAction bopts == DoTests+ , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks+ }+ pkg <- readPackage config cabalfp+ pkgFinal <- readPackage configFinal cabalfp when (packageName pkg /= name) $ throwM $ MismatchedCabalName cabalfp (packageName pkg) mbuildCache <- tryGetBuildCache dir- mconfigCache <- tryGetConfigCache dir fileModTimes <- getPackageFileModTimes pkg cabalfp return LocalPackage { lpPackage = pkg+ , lpPackageFinal = pkgFinal , lpWanted = wanted- , lpLastConfigOpts = mconfigCache , lpDirtyFiles = maybe True ((/= fileModTimes) . buildCacheTimes)@@ -136,9 +177,8 @@ let known = Set.fromList $ map (packageName . lpPackage) lps unknown = Set.difference names known- unless (Set.null unknown) $ throwM $ UnknownTargets $ Set.toList unknown - return lps+ return (lps, unknown, Set.fromList idents) where parseTarget t = do let s = T.unpack t@@ -146,8 +186,17 @@ if isDir then liftM (Right . Left) $ liftIO (canonicalizePath s) >>= parseAbsDir else return $ case parsePackageNameFromString s of- Left _ -> Left t- Right pname -> Right $ Right pname+ Left _ ->+ case parsePackageIdentifierFromString s of+ Left _ ->+ case T.stripSuffix ":latest" t of+ Just t'+ | Just name <- parsePackageNameFromString $ T.unpack t'+ , Just version <- Map.lookup name latestVersion+ -> Right $ Right $ Right $ PackageIdentifier name version+ _ -> Left t+ Right ident -> Right $ Right $ Right ident+ Right pname -> Right $ Right $ Left pname isWanted dirs names dir name = name `Set.member` names || any (`isParentOf` dir) dirs ||@@ -158,3 +207,36 @@ localFlags bopts bconfig name = Map.union (fromMaybe Map.empty $ Map.lookup name $ boptsFlags bopts) (fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig)++-- | Add in necessary packages to extra dependencies+--+-- See https://github.com/commercialhaskell/stack/issues/272 for the requirements of this function+extendExtraDeps :: Map PackageName Version -- ^ original extra deps+ -> MiniBuildPlan+ -> Map PackageName Version -- ^ latest versions in indices+ -> Set PackageName -- ^ extra package names desired+ -> Set PackageIdentifier -- ^ extra package identifiers desired+ -> Map PackageName Version -- ^ new extradeps+extendExtraDeps extraDeps0 mbp latestVersion extraNames extraIdents =+ F.foldl' addIdent+ (F.foldl' addName extraDeps0 extraNames)+ extraIdents+ where+ snapshot = fmap mpiVersion $ mbpPackages mbp++ addName m name =+ case Map.lookup name m <|> Map.lookup name snapshot of+ -- alright exists in snapshot or extra-deps+ Just _ -> m+ Nothing ->+ case Map.lookup name latestVersion of+ -- use the latest version in the index+ Just v -> Map.insert name v m+ -- does not exist, will be reported as an error+ Nothing -> m++ addIdent m (PackageIdentifier name version) =+ case Map.lookup name snapshot of+ -- the version matches what's in the snapshot, so just use the snapshot version+ Just version' | version == version' -> m+ _ -> Map.insert name version m
src/Stack/Build/Types.hs view
@@ -11,33 +11,35 @@ module Stack.Build.Types where -import Control.DeepSeq-import Control.Exception-import Data.Aeson-import Data.Binary (Binary(..))+import Control.DeepSeq+import Control.Exception+import Data.Aeson.Extended+import Data.Binary (Binary(..)) import qualified Data.ByteString as S-import Data.Char (isSpace)-import Data.Data-import Data.Hashable-import Data.List (dropWhileEnd, nub, intercalate)-import Data.Map.Strict (Map)+import Data.Char (isSpace)+import Data.Data+import Data.Hashable+import Data.List (dropWhileEnd, nub, intercalate) import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Set (Set)+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 Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Distribution.Text (display)-import GHC.Generics-import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, (</>))-import Prelude hiding (FilePath)-import Stack.Package-import Stack.Types-import System.Exit (ExitCode)-import System.FilePath (pathSeparator)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time.Calendar+import Data.Time.Clock+import Distribution.Text (display)+import GHC.Generics+import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, (</>))+import Prelude hiding (FilePath)+import Stack.Package+import Stack.Types+import System.Exit (ExitCode)+import System.FilePath (pathSeparator) ---------------------------------------------- -- Exceptions@@ -46,7 +48,10 @@ | GHCVersionMismatch (Maybe Version) Version (Maybe (Path Abs File)) -- ^ Path to the stack.yaml file | Couldn'tParseTargets [Text]- | UnknownTargets [PackageName]+ | 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)) | ConstructPlanExceptions [ConstructPlanException] | CabalExitedUnsuccessfully@@ -82,9 +87,27 @@ show (Couldn'tParseTargets targets) = unlines $ "The following targets could not be parsed as package names or directories:" : map T.unpack targets- show (UnknownTargets 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 targets)+ 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) = unlines $ concat [ ["Test suite failure for package " ++ packageIdentifierString ident] , flip map (Map.toList codes) $ \(name, mcode) -> concat@@ -128,7 +151,7 @@ data ConstructPlanException = DependencyCycleDetected [PackageName]- | DependencyPlanFailures PackageName (Map PackageName (VersionRange, BadDependency))+ | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, 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)@@ -146,9 +169,9 @@ (DependencyCycleDetected pNames) -> "While checking call stack,\n" ++ " dependency cycle detected in packages:" ++ indent (appendLines pNames)- (DependencyPlanFailures pName (Map.toList -> pDeps)) ->+ (DependencyPlanFailures pIdent (Map.toList -> pDeps)) -> "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++- " needed for package: " ++ show pName+ " needed for package: " ++ packageIdentifierString pIdent (UnknownPackage pName) -> "While attempting to add dependency,\n" ++ " Could not find package " ++ show pName ++ " in known packages"@@ -183,9 +206,7 @@ -- | Configuration for building. data BuildOpts =- BuildOpts {boptsTargets :: !(Either [Text] [PackageName])- -- ^ Right value indicates that we're only installing- -- dependencies, no local packages+ BuildOpts {boptsTargets :: ![Text] ,boptsLibProfile :: !Bool ,boptsExeProfile :: !Bool ,boptsEnableOptimizations :: !(Maybe Bool)@@ -193,6 +214,8 @@ ,boptsDryrun :: !Bool ,boptsGhcOptions :: ![Text] ,boptsFlags :: !(Map PackageName (Map FlagName Bool))+ ,boptsInstallExes :: !Bool+ -- ^ Install executables to user path after building? } deriving (Show) @@ -274,11 +297,11 @@ -- | Information on a locally available package of source code data LocalPackage = LocalPackage- { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags+ { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any final actions+ , lpPackageFinal :: !Package -- ^ Same as lpPackage, but with any test suites or benchmarks enabled as necessary , lpWanted :: !Bool -- ^ Is this package a \"wanted\" target based on command line input , lpDir :: !(Path Abs Dir) -- ^ Directory of the package. , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file- , lpLastConfigOpts :: !(Maybe ConfigCache) -- ^ configure options used during last Setup.hs configure, if available , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build? } deriving Show@@ -323,19 +346,20 @@ -- | The type of a task, either building local code or something from the -- package index (upstream)-data TaskType = TTLocal LocalPackage NeededSteps+data TaskType = TTLocal LocalPackage | TTUpstream Package Location deriving Show --- | How many steps must be taken when building-data NeededSteps = AllSteps | SkipConfig | JustFinal- deriving (Show, Eq)- -- | 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 :: !(Set GhcPkgId)+ , planInstallExes :: !(Map Text Location)+ -- ^ Executables that should be installed after successful building }+ deriving Show -- | Basic information used to calculate what the configure options are data BaseConfigOpts = BaseConfigOpts@@ -366,8 +390,6 @@ ] , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts] , ["--enable-executable-profiling" | boptsExeProfile bopts]- , ["--enable-tests" | wanted && boptsFinalAction bopts == DoTests]- , ["--enable-benchmarks" | wanted && boptsFinalAction bopts == DoBenchmarks] , map (\(name,enabled) -> "-f" <> (if enabled@@ -413,3 +435,20 @@ ] where PackageIdentifier name version = ghcPkgIdPackageIdentifier gid++-- | Used for storage and comparison.+newtype ModTime = ModTime (Integer,Rational)+ deriving (Ord,Show,Generic,Eq)+instance Binary ModTime++-- | One-way conversion to serialized time.+modTime :: UTCTime -> ModTime+modTime x =+ ModTime+ ( toModifiedJulianDay+ (utctDay x)+ , toRational+ (utctDayTime x))++data Installed = Library GhcPkgId | Executable PackageIdentifier+ deriving (Show, Eq, Ord)
src/Stack/BuildPlan.hs view
@@ -36,8 +36,7 @@ import Control.Monad.State.Strict (State, execState, get, modify, put) import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Aeson (FromJSON (..))-import Data.Aeson (withObject, withText, (.:))+import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:)) import Data.Binary.VersionTagged (taggedDecodeOrLoad) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8@@ -72,6 +71,7 @@ import Stack.Package import Stack.PackageIndex import Stack.Types+import Stack.Types.StackT import System.Directory (createDirectoryIfMissing, getDirectoryContents) import System.FilePath (takeDirectory) @@ -313,8 +313,7 @@ return $ Set.singleton dep else do shadowed <- goName dep (Set.singleton name)- let m = Map.fromList $ map (\x -> (x, Set.singleton $ PackageIdentifier name (mpiVersion mpi)))- $ Set.toList shadowed+ let m = Map.fromSet (\_ -> Set.singleton $ PackageIdentifier name (mpiVersion mpi)) shadowed modify $ \rs' -> rs' { rsShadowed = Map.unionWith Set.union m $ rsShadowed rs' }@@ -423,10 +422,10 @@ $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e) liftIO $ createDirectoryIfMissing True $ takeDirectory $ toFilePath fp req <- parseUrl $ T.unpack url- $logInfo $ "Downloading " <> renderSnapName name <> " build plan ..."+ $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." $logDebug $ "Downloading build plan from: " <> url _ <- download req fp- $logInfo $ "Downloaded " <> renderSnapName name <> " build plan."+ $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return where@@ -518,8 +517,9 @@ -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m) => GenericPackageDescription+ -> Snapshots -> m (Maybe (SnapName, Map FlagName Bool))-findBuildPlan gpd = do+findBuildPlan gpd snapshots = 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.@@ -533,7 +533,6 @@ isNightly Nightly{} = True isNightly LTS{} = False - snapshots <- getSnapshots let names = nubOrd $ concat [ take 2 $ filter isLTS existing , take 2 $ filter isNightly existing@@ -566,7 +565,7 @@ shadowMiniBuildPlan (MiniBuildPlan ghc pkgs0) shadowed = (MiniBuildPlan ghc $ Map.fromList met, Map.fromList unmet) where- pkgs1 = Map.difference pkgs0 $ Map.fromList $ map (, ()) $ Set.toList shadowed+ pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1)
src/Stack/Config.hs view
@@ -25,30 +25,42 @@ , loadConfig ) where +import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip import Control.Applicative+import Control.Concurrent (getNumCapabilities) import Control.Monad import Control.Monad.Catch 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 Data.Aeson+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Aeson.Extended+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as L import Data.Either (partitionEithers) import Data.Map (Map) import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C+import qualified Distribution.Text+import Distribution.Version (simplifyVersionRange) import Data.Maybe import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Yaml as Yaml import Distribution.System (OS (Windows), Platform (..), buildPlatform)-import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager)-import Options.Applicative (Parser)+import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)+import Network.HTTP.Download (download)+import Options.Applicative (Parser, idm, strOption, long, short, metavar, help, option, auto)+import Options.Applicative.Builder.Extra (maybeBoolFlags) import Path import Path.IO+import qualified Paths_stack as Meta import Stack.BuildPlan import Stack.Types.Config import Stack.Constants@@ -57,43 +69,57 @@ import Stack.Types import System.Directory import System.Environment-import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride)+import System.IO (IOMode (ReadMode), withBinaryFile)+import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull) -- | Get the default resolver value getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) => Path Abs Dir- -> m (Resolver, Map PackageName (Map FlagName Bool), Bool)+ -> m (Resolver, Map PackageName (Map FlagName Bool)) getDefaultResolver dir = do- ecabalfp <- try $ getCabalFileName dir- let cabalFileExists = either (const False) (const True) ecabalfp- msnap <- case ecabalfp of- Left e -> do- $logWarn $ T.pack $ show (e :: PackageException)- return Nothing- Right cabalfp -> do- gpd <- readPackageUnresolved cabalfp- mpair <- findBuildPlan gpd- let name =- case C.package $ C.packageDescription gpd of- C.PackageIdentifier cname _ ->- fromCabalPackageName cname- return $ fmap (, name) mpair- case msnap of- Just ((snap, flags), name) ->- return (ResolverSnapshot snap, Map.singleton name flags, cabalFileExists)+ cabalfp <- getCabalFileName dir+ gpd <- readPackageUnresolved cabalfp+ snapshots <- getSnapshots `catch` \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/wiki/stack.yaml"+ $logError ""+ throwM (e :: SomeException)+ mpair <- findBuildPlan gpd snapshots+ let name =+ case C.package $ C.packageDescription gpd of+ C.PackageIdentifier cname _ ->+ fromCabalPackageName cname+ case mpair of+ Just (snap, flags) ->+ return (ResolverSnapshot snap, Map.singleton name flags) Nothing -> do- s <- getSnapshots- let snap = case IntMap.maxViewWithKey (snapshotsLts s) of+ let snap = case IntMap.maxViewWithKey (snapshotsLts snapshots) of Just ((x, y), _) -> LTS x y- Nothing -> Nightly $ snapshotsNightly s- return (ResolverSnapshot snap, Map.empty, cabalFileExists)+ Nothing -> Nightly $ snapshotsNightly snapshots+ $logWarn $ T.concat+ [ "No matching snapshot was found for your package, "+ , "falling back to: "+ , renderSnapName snap+ ]+ $logWarn "This behavior will improve in the future, please see: https://github.com/commercialhaskell/stack/issues/253"+ return (ResolverSnapshot snap, Map.empty) data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid instance FromJSON ProjectAndConfigMonoid where parseJSON = withObject "Project, ConfigMonoid" $ \o -> do- dirs <- o .:? "packages" .!= ["."]+ dirs <- o .:? "packages" .!= [packageEntryCurrDir] extraDeps' <- o .:? "extra-deps" .!= [] extraDeps <- case partitionEithers $ goDeps extraDeps' of@@ -148,7 +174,7 @@ configMonoidLatestSnapshotUrl configPackageIndices = fromMaybe [PackageIndex- { indexName = IndexName "hackage.haskell.org"+ { indexName = IndexName "Hackage" , indexLocation = ILGitHttp "https://github.com/commercialhaskell/all-cabal-hashes.git" "https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz"@@ -158,10 +184,20 @@ }] configMonoidPackageIndices + configSystemGHC = fromMaybe True configMonoidSystemGHC+ configInstallGHC = fromMaybe False configMonoidInstallGHC+ -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured.- configPlatform = buildPlatform+ (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+ origEnv <- getEnvOverride configPlatform let configEnvOverride _ = return origEnv @@ -174,13 +210,53 @@ return $ progsDir </> $(mkRelDir stackProgName) </> platform _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform + configLocalBin <- do+ localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir+ return $ localDir </> $(mkRelDir "bin")++ configJobs <-+ case configMonoidJobs of+ Nothing -> liftIO getNumCapabilities+ Just i -> return i+ return Config {..} -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker =- (\opts -> mempty { configMonoidDockerOpts = opts })+ (\opts systemGHC installGHC arch os jobs -> mempty+ { configMonoidDockerOpts = opts+ , configMonoidSystemGHC = systemGHC+ , configMonoidInstallGHC = installGHC+ , configMonoidArch = arch+ , configMonoidOS = os+ , configMonoidJobs = jobs+ }) <$> Docker.dockerOptsParser docker+ <*> maybeBoolFlags+ "system-ghc"+ "using the system installed GHC (on the PATH) if available and a matching version"+ idm+ <*> maybeBoolFlags+ "install-ghc"+ "downloading and installing GHC if necessary (can be done manually with stack setup)"+ idm+ <*> optional (strOption+ ( long "arch"+ <> metavar "ARCH"+ <> help "System architecture, e.g. i386, x86_64"+ ))+ <*> optional (strOption+ ( long "os"+ <> metavar "OS"+ <> help "Operating system, e.g. linux, windows"+ ))+ <*> optional (option auto+ ( long "jobs"+ <> short 'j'+ <> metavar "JOBS"+ <> help "Number of concurrent jobs to run"+ )) -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at:@@ -206,7 +282,7 @@ -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary.-loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)+loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env) => ConfigMonoid -- ^ Config monoid from parsed command-line arguments -> m (LoadConfig m)@@ -218,20 +294,32 @@ case mproject of Nothing -> configArgs : extraConfigs Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs+ unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)+ (throwM (BadStackVersionException (configRequireStackVersion config)))+ menv <- runReaderT getMinimalEnvOverride config return $ LoadConfig { lcConfig = config- , lcLoadBuildConfig = loadBuildConfig mproject config+ , lcLoadBuildConfig = loadBuildConfig menv mproject config , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject } +-- | A PackageEntry for the current directory, used as a default+packageEntryCurrDir :: PackageEntry+packageEntryCurrDir = PackageEntry+ { peValidWanted = True+ , peLocation = PLFilePath "."+ , peSubdirs = []+ }+ -- | 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)- => Maybe (Project, Path Abs File, ConfigMonoid)+ => EnvOverride+ -> Maybe (Project, Path Abs File, ConfigMonoid) -> Config -> NoBuildConfigStrategy -> m BuildConfig-loadBuildConfig mproject config noConfigStrat = do+loadBuildConfig menv mproject config noConfigStrat = do env <- ask let miniConfig = MiniConfig (getHttpManager env) config (project, stackYamlFP) <- case mproject of@@ -244,17 +332,14 @@ error "You do not have a stack.yaml. This will be handled in the future, see https://github.com/fpco/stack/issues/59" CreateConfig -> do currDir <- getWorkingDir- (r, flags, cabalFileExists) <- runReaderT (getDefaultResolver currDir) miniConfig+ (r, flags) <- runReaderT (getDefaultResolver currDir) miniConfig let dest = currDir </> stackDotYaml dest' = toFilePath dest exists <- liftIO $ doesFileExist dest' when exists $ error "Invariant violated: in toBuildConfig's Nothing branch, and the stack.yaml file exists" $logInfo $ "Writing default config file to: " <> T.pack dest' let p = Project- { projectPackages =- if cabalFileExists- then ["."]- else []+ { projectPackages = [packageEntryCurrDir] , projectExtraDeps = Map.empty , projectFlags = flags , projectResolver = r@@ -270,8 +355,8 @@ ResolverGhc m -> return $ fromMajorVersion m let root = parent stackYamlFP- packages' <- mapM (resolveDir root) (projectPackages project)- let packages = S.fromList packages'+ packages' <- mapM (resolvePackageEntry menv root) (projectPackages project)+ let packages = Map.fromList $ concat packages' return BuildConfig { bcConfig = config@@ -283,6 +368,87 @@ , bcStackYaml = stackYamlFP , bcFlags = projectFlags project }++-- | 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)+ => 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+ return $ map (, peValidWanted 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)+ => EnvOverride+ -> Path Abs Dir -- ^ project root+ -> PackageLocation+ -> m (Path Abs Dir)+resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp+resolvePackageLocation _ projRoot (PLHttpTarball url) = do+ let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 url+ root = projRoot </> workDirRel </> $(mkRelDir "downloaded")+ fileRel <- parseRelFile $ name ++ ".tar.gz"+ dirRel <- parseRelDir name+ dirRelTmp <- parseRelDir $ name ++ ".tmp"+ let file = root </> fileRel+ dir = root </> dirRel+ dirTmp = root </> dirRelTmp++ exists <- liftIO $ doesDirectoryExist $ toFilePath dir+ unless exists $ do+ req <- parseUrl $ T.unpack url+ _ <- download req file++ removeTreeIfExists dirTmp+ liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do+ lbs <- L.hGetContents h+ let entries = Tar.read $ GZip.decompress lbs+ Tar.unpack (toFilePath dirTmp) entries+ renameDirectory (toFilePath dirTmp) (toFilePath dir)++ x <- listDirectory dir+ case x of+ ([dir'], []) -> return dir'+ (dirs, files) -> do+ removeFileIfExists file+ removeTreeIfExists dir+ throwM $ UnexpectedTarballContents dirs files++resolvePackageLocation menv projRoot (PLGit url commit) = do+ let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 $ T.unwords [url, commit]+ root = projRoot </> workDirRel </> $(mkRelDir "downloaded")+ dirRel <- parseRelDir $ name ++ ".git"+ dirRelTmp <- parseRelDir $ name ++ ".git.tmp"+ let dir = root </> dirRel+ dirTmp = root </> dirRelTmp++ exists <- liftIO $ doesDirectoryExist $ toFilePath dir+ unless exists $ do+ removeTreeIfExists dirTmp+ liftIO $ createDirectoryIfMissing True $ toFilePath $ parent dirTmp+ readInNull (parent dirTmp) "git" menv+ [ "clone"+ , T.unpack url+ , toFilePath dirTmp+ ]+ Nothing+ readInNull dirTmp "git" menv+ [ "reset"+ , "--hard"+ , T.unpack commit+ ]+ Nothing+ liftIO $ renameDirectory (toFilePath dirTmp) (toFilePath dir)++ return dir -- | Get the stack root, e.g. ~/.stack determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)
src/Stack/Constants.hs view
@@ -17,58 +17,61 @@ ,stackRootEnvVar ,userDocsDir ,configCacheFile+ ,configCabalMod ,buildCacheFile ,stackProgName+ ,wiredInPackages+ ,cabalPackageName ) where -import Control.Monad (liftM)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.Reader (MonadReader)-import Data.Text (Text)++import Control.Monad.Catch (MonadThrow)+import Control.Monad.Reader++import Data.Maybe (fromMaybe)+import Data.Text (Text) import qualified Data.Text as T-import Path as FL-import Prelude-import Stack.Types.Config-import Stack.Types.PackageIdentifier-import Stack.Types.Version+import Path as FL+import Prelude+import Stack.Types.Config+import Stack.Types.PackageIdentifier +import Stack.Types.PackageName++ -- | Extensions used for Haskell files. haskellFileExts :: [Text] haskellFileExts = ["hs","hsc","lhs"] -- | The filename used for completed build indicators.-builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir+builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -> m (Path Abs File)-builtFileFromDir cabalPkgVer fp = do- dist <- distDirFromDir cabalPkgVer fp+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)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir+configuredFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -> m (Path Abs File)-configuredFileFromDir cabalPkgVer fp = do- dist <- distDirFromDir cabalPkgVer fp+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)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir+builtConfigFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -> m (Path Abs File)-builtConfigFileFromDir cabalPkgVer fp =- liftM (fp </>) (builtConfigRelativeFile cabalPkgVer)+builtConfigFileFromDir fp =+ liftM (fp </>) builtConfigRelativeFile -- | Relative location of completed build indicators.-builtConfigRelativeFile :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> m (Path Rel File)-builtConfigRelativeFile cabalPkgVer = do- dist <- distRelativeDir cabalPkgVer+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.@@ -94,52 +97,54 @@ userDocsDir config = configStackRoot config </> $(mkRelDir "doc/") -- | The filename used for dirtiness check of source files.-buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir -- ^ Package directory.+buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory. -> m (Path Abs File)-buildCacheFile cabalPkgVersion dir = do+buildCacheFile dir = do liftM (</> $(mkRelFile "stack-build-cache"))- (distDirFromDir cabalPkgVersion dir)+ (distDirFromDir dir) -- | The filename used for dirtiness check of config.-configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir -- ^ Package directory.+configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory. -> m (Path Abs File)-configCacheFile cabalPkgVersion dir = do+configCacheFile dir = do liftM (</> $(mkRelFile "stack-config-cache"))- (distDirFromDir cabalPkgVersion dir)+ (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 = do+ liftM+ (</> $(mkRelFile "stack-cabal-mod"))+ (distDirFromDir dir)+ -- | Package's build artifacts directory.-distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> Path Abs Dir+distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => Path Abs Dir -> m (Path Abs Dir)-distDirFromDir cabalPkgVersion fp =- liftM (fp </>) (distRelativeDir cabalPkgVersion)+distDirFromDir fp =+ liftM (fp </>) distRelativeDir -- | Relative location of build artifacts.-distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env)- => PackageIdentifier -- ^ Cabal version- -> m (Path Rel Dir)-distRelativeDir cabalPkgVer = do+distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => m (Path Rel Dir)+distRelativeDir = do+ cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) platform <- platformRelDir- cabal <- parseRelDir $ "Cabal-" ++- versionString (packageIdentifierVersion cabalPkgVer)- return $ $(mkRelDir "dist-stack/") </> platform </> cabal---- pkgIndexDir :: Config -> Path Abs Dir--- pkgIndexDir config =--- configStackRoot config </>--- $(mkRelDir "package-index")---- pkgIndexFile :: Config -> Path Abs File--- pkgIndexFile config =--- pkgIndexDir config </>--- $(mkRelFile "00-index.tar")+ cabal <-+ parseRelDir $+ packageIdentifierString+ (PackageIdentifier cabalPackageName cabalPkgVer)+ return $+ workDirRel </>+ $(mkRelDir "dist") </>+ platform </>+ cabal -- | Get a URL for a raw file on Github rawGithubUrl :: Text -- ^ user/org name@@ -174,7 +179,7 @@ -- | Docker sandbox from project root. projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir-projectDockerSandboxDir projectRoot = projectRoot </> $(mkRelDir ".docker-sandbox/")+projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir "docker/") -- | Name of the 'stack' program. stackProgName :: String@@ -187,3 +192,25 @@ -- | 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 :: [PackageName]+wiredInPackages = fromMaybe (error "Parse error in wiredInPackages") mparsed+ where+ mparsed = sequence $ map parsePackageName+ [ "ghc-prim"+ , "integer-gmp"+ , "integer-simple"+ , "base"+ , "rts"+ , "template-haskell"+ , "dph-seq"+ , "dph-par"+ , "ghc"+ , "interactive"+ ]++-- | Just to avoid repetition and magic strings.+cabalPackageName :: PackageName+cabalPackageName =+ $(mkPackageName "Cabal")
src/Stack/Docker.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, NamedFieldPuns, OverloadedStrings, RankNTypes,- RecordWildCards, TemplateHaskell, TupleSections #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,+ OverloadedStrings, RankNTypes, RecordWildCards, TemplateHaskell, TupleSections #-} -- | Run commands in Docker containers module Stack.Docker- (checkVersions- ,cleanup+ (cleanup ,CleanupOpts(..) ,CleanupAction(..) ,dockerCleanupCmdName@@ -21,13 +20,14 @@ ) where import Control.Applicative-import Control.Exception+import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) import Control.Monad.Writer (execWriter,runWriter,tell)-import Data.Aeson (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)+import Control.Monad.Trans.Control (MonadBaseControl)+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@@ -47,7 +47,6 @@ import Options.Applicative (Parser,str,option,help,auto,metavar,long,value,hidden,internal,idm) import Path import Path.IO (getWorkingDir,listDirectory)-import Paths_stack (version) import Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar) import Stack.Types import Stack.Docker.GlobalDB@@ -61,6 +60,7 @@ import qualified System.Process as Proc import System.Process.PagerEditor (editByteString) import System.Process.Read+import System.Process.Run import Text.Printf (printf) #ifndef mingw32_HOST_OS@@ -69,28 +69,27 @@ -- | If Docker is enabled, re-runs the currently running OS command in a Docker container. -- Otherwise, runs the inner action.-rerunWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m)+rerunWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) => Config -> Maybe (Path Abs Dir) -> IO () -> m ()-rerunWithOptionalContainer config mprojectRoot inner =- rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs inner- where- getCmdArgs =- do args <- getArgs- if arch == "x86_64" && os == "linux"- then do exePath <- getExecutablePath- let mountDir = concat ["/tmp/host-",stackProgName]- mountPath = concat [mountDir,"/",takeBaseName exePath]- return (mountPath- ,args- ,config{configDocker=docker{dockerMount=Mount exePath mountPath :- dockerMount docker}})- else do progName <- getProgName- return (takeBaseName progName,args,config)- docker = configDocker config+rerunWithOptionalContainer config mprojectRoot =+ rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs+ where+ getCmdArgs =+ do args <- getArgs+ if arch == "x86_64" && os == "linux"+ then do exePath <- getExecutablePath+ let mountPath = concat ["/opt/host/bin/",takeBaseName exePath]+ return (mountPath+ ,args+ ,config{configDocker=docker{dockerMount=Mount exePath mountPath :+ dockerMount docker}})+ else do progName <- getProgName+ return (takeBaseName progName,args,config)+ docker = configDocker config -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.-rerunCmdWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m)+rerunCmdWithOptionalContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) => Config -> Maybe (Path Abs Dir) -> IO (FilePath,[String],Config)@@ -105,7 +104,7 @@ -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.-rerunCmdWithRequiredContainer :: (MonadLogger m,MonadIO m,MonadThrow m)+rerunCmdWithRequiredContainer :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) => Config -> Maybe (Path Abs Dir) -> IO (FilePath,[String],Config)@@ -127,13 +126,13 @@ -- | 'True' if we are currently running inside a Docker container. getInContainer :: (MonadIO m) => m Bool getInContainer =- do maybeEnvVar <- liftIO (lookupEnv sandboxIDEnvVar)+ do maybeEnvVar <- liftIO (lookupEnv inContainerEnvVar) case maybeEnvVar of Nothing -> return False Just _ -> return True -- | Run a command in a new Docker container, then exit the process.-runContainerAndExit :: (MonadLogger m,MonadIO m,MonadThrow m)+runContainerAndExit :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) => Config -> Maybe (Path Abs Dir) -> FilePath@@ -169,7 +168,7 @@ Just ii -> return ii Nothing | dockerAutoPull docker ->- do pullImage pwd envOverride docker image+ do pullImage envOverride docker image mii2 <- inspect envOverride image case mii2 of Just ii2 -> return ii2@@ -195,7 +194,7 @@ sandboxIDDir <- parseRelDir (sandboxID ++ "/") let stackRoot = configStackRoot config sandboxDir = projectDockerSandboxDir projectRoot- sandboxSandboxDir = sandboxDir </> $(mkRelDir ".sandbox/") </> sandboxIDDir+ sandboxSandboxDir = sandboxDir </> $(mkRelDir "_sandbox/") </> sandboxIDDir sandboxHomeDir = sandboxDir </> homeDirName sandboxRepoDir = sandboxDir </> sandboxIDDir sandboxSubdirs = map (\d -> sandboxRepoDir </> d)@@ -212,14 +211,13 @@ (concat [["run" ,"--net=host"+ ,"-e",inContainerEnvVar ++ "=1" ,"-e",stackRootEnvVar ++ "=" ++ trimTrailingPathSep stackRoot ,"-e","WORK_UID=" ++ uid ,"-e","WORK_GID=" ++ gid ,"-e","WORK_WD=" ++ trimTrailingPathSep pwd ,"-e","WORK_HOME=" ++ trimTrailingPathSep sandboxRepoDir ,"-e","WORK_ROOT=" ++ trimTrailingPathSep projectRoot- ,"-e",hostVersionEnvVar ++ "=" ++ versionString stackVersion- ,"-e",requireVersionEnvVar ++ "=" ++ versionString requireContainerVersion ,"-v",trimTrailingPathSep stackRoot ++ ":" ++ trimTrailingPathSep stackRoot ,"-v",trimTrailingPathSep projectRoot ++ ":" ++ trimTrailingPathSep projectRoot ,"-v",trimTrailingPathSep sandboxSandboxDir ++ ":" ++ trimTrailingPathSep sandboxDir@@ -274,11 +272,12 @@ docker = configDocker config -- | Clean-up old docker images and containers.-cleanup :: (MonadLogger m,MonadIO m,MonadThrow m) => Config -> CleanupOpts -> m ()+cleanup :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+ => Config -> CleanupOpts -> m () cleanup config opts = do envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride- let runDocker = readProcessStdout Nothing 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"]@@ -337,11 +336,11 @@ do $logInfo (concatT ["Removing container: '",v,"'"]) return ["rm","-f",v] | otherwise -> throwM (InvalidCleanupCommandException line)- e <- liftIO (try (callProcess Nothing envOverride "docker" args))+ e <- try (readDockerProcess envOverride args) case e of Left (ProcessExitedUnsuccessfully _ _) -> $logError (concatT ["Could not remove: '",v,"'"])- Right () -> return ()+ Right _ -> return () _ -> throwM (InvalidCleanupCommandException line) parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8 where parseImageRepo :: String -> (String, [String])@@ -497,7 +496,8 @@ containerStr = "container" -- | Inspect Docker image or container.-inspect :: (MonadIO m,MonadThrow m) => EnvOverride -> String -> m (Maybe Inspect)+inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)+ => EnvOverride -> String -> m (Maybe Inspect) inspect envOverride image = do results <- inspects envOverride [image] case Map.toList results of@@ -506,10 +506,12 @@ _ -> throwM (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers.-inspects :: (MonadIO m,MonadThrow m) => EnvOverride -> [String] -> m (Map String Inspect)+inspects :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)+ => EnvOverride -> [String] -> m (Map String Inspect) inspects _ [] = return Map.empty inspects envOverride images =- do maybeInspectOut <- tryProcessStdout Nothing envOverride "docker" ("inspect" : 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@@ -519,43 +521,42 @@ Left (ProcessExitedUnsuccessfully _ _) -> return Map.empty -- | Pull latest version of configured Docker image from registry.-pull :: (MonadLogger m,MonadIO m,MonadThrow m) => Config -> m ()+pull :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+ => Config -> m () pull config = do envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride- pwd <- getWorkingDir- pullImage pwd envOverride docker (dockerImage docker)+ pullImage envOverride docker (dockerImage docker) where docker = configDocker config -- | Pull Docker image from registry. pullImage :: (MonadLogger m,MonadIO m,MonadThrow m)- => Path Abs Dir -> EnvOverride -> DockerOpts -> String -> m ()-pullImage pwd envOverride docker image =+ => 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."- runIn- pwd- "docker"+ callProcess+ Nothing envOverride+ "docker" (concat [["login"] ,maybe [] (\u -> ["--username=" ++ u]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)- ,[takeWhile (/= '/') image]])- Nothing)+ ,[takeWhile (/= '/') image]])) e <- liftIO (try (callProcess Nothing envOverride "docker" ["pull",image])) case e of Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image) Right () -> return () -- | Check docker version (throws exception if incorrect)-checkDockerVersion :: (MonadIO m,MonadThrow m) => EnvOverride -> m ()+checkDockerVersion :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m)+ => EnvOverride -> m () checkDockerVersion envOverride = do dockerExists <- doesExecutableExist envOverride "docker"- when (not dockerExists)- (throwM DockerNotInstalledException)- dockerVersionOut <- readProcessStdout Nothing envOverride "docker" ["--version"]+ unless dockerExists (throwM DockerNotInstalledException)+ dockerVersionOut <- readDockerProcess envOverride ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> case parseVersionFromString (dropWhileEnd (== ',') v) of@@ -611,6 +612,16 @@ (\f -> unless (filename f `elem` excludeFiles) (removeFile (toFilePath f)))) +-- | Produce a strict 'S.ByteString' from the stdout of a+-- process. Throws a 'ProcessExitedUnsuccessfully' exception if the+-- process fails. Logs process's stderr using @$logError@.+readDockerProcess :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)+ => EnvOverride+ -> [String]+ -> m BS.ByteString+readDockerProcess envOverride args =+ readProcessStdoutLogStderr "docker: " Nothing envOverride "docker" args+ -- | Subdirectories of the home directory to sandbox between GHC/Stackage versions. sandboxedHomeSubdirectories :: [Path Rel Dir] sandboxedHomeSubdirectories =@@ -618,37 +629,9 @@ ,$(mkRelDir ".cabal/") ,$(mkRelDir ".ghcjs/")] --- | Name of home directory within @.docker-sandbox@.+-- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir-homeDirName = $(mkRelDir ".home/")---- | Check host 'stack' version-checkHostStackVersion :: (MonadIO m,MonadThrow m) => Version -> m ()-checkHostStackVersion minVersion =- do maybeHostVer <- liftIO (lookupEnv hostVersionEnvVar)- case parseVersionFromString =<< maybeHostVer of- Just hostVer- | hostVer < minVersion -> throwM (HostStackTooOldException minVersion (Just hostVer))- | otherwise -> return ()- Nothing ->- do inContainer <- getInContainer- if inContainer- then throwM (HostStackTooOldException minVersion Nothing)- else return ()----- | Check host and container 'stack' versions are compatible.-checkVersions :: (MonadIO m,MonadThrow m) => m ()-checkVersions =- do inContainer <- getInContainer- when inContainer- (do checkHostStackVersion requireHostVersion- maybeReqVer <- liftIO (lookupEnv requireVersionEnvVar)- case parseVersionFromString =<< maybeReqVer of- Just reqVer- | stackVersion < reqVer -> throwM (ContainerStackTooOldException reqVer stackVersion)- | otherwise -> return ()- _ -> return ())+homeDirName = $(mkRelDir "_home/") -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid@@ -726,10 +709,10 @@ Nothing -> "" Just proj -> case projectResolver proj of- ResolverSnapshot n@(LTS _ _) -> ":" ++ (T.unpack (renderSnapName n))+ ResolverSnapshot n@(LTS _ _) -> ":" ++ T.unpack (renderSnapName n) _ -> throw (ResolverNotSupportedException (projectResolver proj)) in case dockerMonoidRepoOrImage of- Nothing -> "fpco/dev" ++ defaultTag+ Nothing -> "fpco/stack-build" ++ defaultTag Just (DockerMonoidImage image) -> image Just (DockerMonoidRepo repo) -> case find (`elem` (":@" :: String)) repo of@@ -770,18 +753,14 @@ fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) --- | Environment variable to the host's stack version.-hostVersionEnvVar :: String-hostVersionEnvVar = "STACK_DOCKER_HOST_VERSION"---- | Environment variable to pass required container stack version.-requireVersionEnvVar :: String-requireVersionEnvVar = "STACK_DOCKER_REQUIRE_VERSION"- -- | Environment variable that contains the sandbox ID. sandboxIDEnvVar :: String sandboxIDEnvVar = "DOCKER_SANDBOX_ID" +-- | Environment variable used to indicate stack is running in container.+inContainerEnvVar :: String+inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"]+ -- | Command-line argument for "docker" dockerCmdName :: String dockerCmdName = "docker"@@ -794,18 +773,6 @@ dockerCleanupCmdName :: String dockerCleanupCmdName = "cleanup" --- | Version of 'stack' required to be installed in container.-requireContainerVersion :: Version-requireContainerVersion = $(mkVersion "0.0.0")---- | Version of 'stack' required to be installed on the host.-requireHostVersion :: Version-requireHostVersion = $(mkVersion "0.0.0")---- | Stack cabal package version-stackVersion :: Version-stackVersion = fromCabalVersion version- -- | Options for 'cleanup'. data CleanupOpts = CleanupOpts { dcAction :: !CleanupAction@@ -883,7 +850,7 @@ | ResolverNotSupportedException Resolver -- ^ Only LTS resolvers are supported for default image tag. | CannotDetermineProjectRootException- -- ^ Can't determine the project root (where to put @.docker-sandbox@).+ -- ^ Can't determine the project root (where to put docker sandbox). | DockerNotInstalledException -- ^ @docker --version@ failed. | InvalidDatabasePathException SomeException
src/Stack/Fetch.hs view
@@ -25,6 +25,7 @@ import Codec.Compression.GZip (decompress) import Control.Applicative import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.MVar.Lifted (newMVar, modifyMVar) import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar, readTVarIO, writeTVar)@@ -38,11 +39,11 @@ import Crypto.Hash (SHA512(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as C8 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.Map (Map) import qualified Data.Map as Map@@ -52,7 +53,6 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8)-import qualified Data.Text.IO as T import Data.Typeable (Typeable) import Data.Word (Word64) import Network.HTTP.Download@@ -232,23 +232,55 @@ -- | 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)+ :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m) => EnvOverride -> ((PackageIdentifier -> IO ByteString) -> m a) -> m a withCabalLoader menv inner = do- caches <- getPackageCaches menv+ 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- inner $ \ident ->- case Map.lookup ident caches of- Nothing -> throwM $ UnknownPackageIdentifiers $ Set.singleton ident- Just (index, cache) -> do- [bs] <- flip runReaderT env- $ withCabalFiles (indexName index) [(ident, cache, ())]- $ \_ _ bs -> return bs- return bs+ let doLookup ident = do+ eres <- doLookup' ident+ case eres of+ Right bs -> return bs+ -- Update the cache and try again+ Left e -> join $ modifyMVar updateRef $ \toUpdate ->+ if toUpdate+ then do+ runInBase $ do+ $logInfo $ T.concat+ [ "Didn't see "+ , T.pack $ packageIdentifierString ident+ , " in your package indices, updating and trying again"+ ]+ updateAllIndices menv+ caches <- getPackageCaches menv+ liftIO $ writeIORef icaches caches+ return (False, doLookup ident)+ else return (toUpdate, throwM e) + doLookup' ident = do+ caches <- liftIO $ readIORef icaches+ case Map.lookup ident caches of+ Nothing ->+ return $ Left $ UnknownPackageIdentifiers $ Set.singleton ident+ Just (index, cache) -> do+ [bs] <- flip runReaderT env+ $ withCabalFiles (indexName index) [(ident, cache, ())]+ $ \_ _ bs -> return bs+ return $ Right bs++ inner doLookup+ -- | Figure out where to fetch from. getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) => Path Abs Dir -- ^ directory to unpack into@@ -311,69 +343,34 @@ connCount <- asks $ configConnectionCount . getConfig outputVar <- liftIO $ newTVarIO Map.empty + runInBase <- liftBaseWith $ \run -> return (void . run) parMapM_ connCount- (go outputVar)+ (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 (ident, toFetch) = do+ go outputVar runInBase (ident, toFetch) = do req <- parseUrl $ T.unpack $ tfUrl toFetch let destpath = tfTarball toFetch - let toHashCheck bs = HashCheck SHA512 (C8.unpack bs)+ let toHashCheck bs = HashCheck SHA512 (CheckHexDigestByteString bs) let downloadReq = DownloadRequest { drRequest = req , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch) , drLengthCheck = fmap fromIntegral $ tfSize toFetch } let progressSink = do- -- TODO: logInfo- liftIO $ T.putStrLn $ packageIdentifierText ident <> ": downloading"+ liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": downloading" _ <- verifiedDownload downloadReq destpath progressSink let fp = toFilePath destpath- --unlessM (liftIO (doesFileExist fp)) $ do- -- $logInfo $ "Downloading " <> packageIdentifierText ident- -- liftIO $ createDirectoryIfMissing True $ takeDirectory fp- -- req <- parseUrl $ T.unpack $ tfUrl toFetch- -- -- FIXME switch to using verifiedDownload- -- liftIO $ withResponse req man $ \res -> do- -- let tmp = fp <.> "tmp"- -- withBinaryFile tmp WriteMode $ \h -> do- -- let loop total ctx = do- -- bs <- brRead $ responseBody res- -- if S.null bs- -- then- -- case tfSize toFetch of- -- Nothing -> return ()- -- Just expected- -- | expected /= total ->- -- throwM InvalidDownloadSize- -- { _idsUrl = tfUrl toFetch- -- , _idsExpected = expected- -- , _idsTotalDownloaded = total- -- }- -- | otherwise -> validHash (tfUrl toFetch) (tfSHA512 toFetch) ctx- -- else do- -- S.hPut h bs- -- let total' = total + fromIntegral (S.length bs)- -- case tfSize toFetch of- -- Just expected | expected < total' ->- -- throwM InvalidDownloadSize- -- { _idsUrl = tfUrl toFetch- -- , _idsExpected = expected- -- , _idsTotalDownloaded = total'- -- }- -- _ -> loop total' $! hashUpdate ctx bs- -- loop 0 hashInit- -- renameFile tmp fp- let dest = toFilePath $ parent $ tfDestDir toFetch innerDest = toFilePath $ tfDestDir toFetch @@ -400,7 +397,14 @@ newDist = inner FP.</> toFilePath distDir exists <- doesDirectoryExist oldDist when exists $ do- createDirectoryIfMissing True $ FP.takeDirectory newDist+ -- 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+ newDist' <- parseAbsDir newDist+ createDirectoryIfMissing True+ $ toFilePath $ parent newDist' renameDirectory oldDist newDist let cabalFP =@@ -410,18 +414,6 @@ S.writeFile cabalFP $ tfCabal toFetch atomically $ modifyTVar outputVar $ Map.insert ident $ tfDestDir toFetch----validHash :: T.Text -> Maybe S.ByteString -> Context SHA512 -> IO ()---validHash _ Nothing _ = return ()---validHash url (Just sha512) ctx--- | sha512 == digestToHexByteString dig = return ()--- | otherwise = throwIO InvalidHash--- { _ihUrl = url--- , _ihExpected = sha512--- , _ihActual = dig--- }--- where--- dig = hashFinalize ctx parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m) => Int
src/Stack/GhcPkg.hs view
@@ -24,13 +24,14 @@ import Data.Either import Data.List import Data.Maybe-import Data.Monoid ((<>)) import Data.Streaming.Process import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.Time.Clock import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) import Prelude hiding (FilePath) import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId))+import Stack.Constants import Stack.Types import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath) import System.Process.Read@@ -59,14 +60,20 @@ -> [String] -> m (Either ProcessExitedUnsuccessfully S8.ByteString) ghcPkg menv pkgDbs args = do- $logDebug $ "Calling ghc-pkg with: " <> T.pack (show args')+ start <- liftIO getCurrentTime eres <- go r <- case eres of Left _ -> do mapM_ (createDatabase menv) pkgDbs go Right _ -> return eres- $logDebug $ "Done calling ghc-pkg with: " <> T.pack (show args')+ end <- liftIO getCurrentTime+ $logDebug $ T.concat+ [ "ghc-pkg ("+ , T.pack $ show $ diffUTCTime end start+ , "s) with args "+ , T.pack $ show args'+ ] return r where go = tryProcessStdout Nothing menv "ghc-pkg" args'@@ -137,16 +144,13 @@ -- | Get the version of Cabal from the global package database. getCabalPkgVer :: (MonadThrow m,MonadIO m,MonadLogger m)- => EnvOverride -> m PackageIdentifier+ => EnvOverride -> m Version getCabalPkgVer menv = do db <- getGlobalDB menv -- FIXME shouldn't be necessary, just tell ghc-pkg to look in the global DB findGhcPkgId menv [db]- cabalName >>=+ cabalPackageName >>= maybe- (throwM $ Couldn'tFindPkgId cabalName)- (return . ghcPkgIdPackageIdentifier)- where- cabalName =- $(mkPackageName "Cabal")+ (throwM $ Couldn'tFindPkgId cabalPackageName)+ (return . packageIdentifierVersion . ghcPkgIdPackageIdentifier)
src/Stack/Package.hs view
@@ -115,6 +115,8 @@ ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package. ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza? ,packageTests :: !(Set Text) -- ^ names of test suites+ ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks+ ,packageExes :: !(Set Text) -- ^ names of executables } deriving (Show,Typeable) @@ -222,7 +224,9 @@ , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps) , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg)- , packageTests = S.fromList $ map (T.pack . fst) $ condTestSuites gpkg -- FIXME need to test if it's buildable+ , packageTests = S.fromList $ [ T.pack (testName 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)] } where@@ -405,16 +409,13 @@ desc {library = fmap (resolveConditions rc updateLibDeps) mlib ,executables =- map (resolveConditions rc updateExeDeps .- snd)+ map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n}) exes ,testSuites =- map (resolveConditions rc updateTestDeps .- snd)+ map (\(n,v) -> (resolveConditions rc updateTestDeps v){testName=n}) tests ,benchmarks =- map (resolveConditions rc updateBenchmarkDeps .- snd)+ map (\(n,v) -> (resolveConditions rc updateBenchmarkDeps v){benchmarkName=n}) benches} where flags = M.union (packageConfigFlags packageConfig)
src/Stack/PackageDump.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}@@ -18,33 +19,38 @@ , pruneDeps ) where -import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile)-import Path-import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger)-import System.Process.Read-import Data.Map (Map)-import Data.IORef-import Control.Monad.Catch (MonadThrow, Exception, throwM)-import qualified Data.Foldable as F-import Control.Monad (when, liftM)-import Stack.Types-import Data.ByteString (ByteString)+import Control.Applicative+import Control.Monad (when, liftM)+import Control.Monad.Catch (MonadThrow, Exception, throwM)+import Control.Monad.IO.Class+import Control.Monad.Logger (MonadLogger, logDebug)+import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile)+import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8-import Data.Conduit-import Data.Typeable (Typeable)-import qualified Data.Conduit.List as CL+import Data.Conduit import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Either (partitionEithers)+import qualified Data.Foldable as F+import Data.IORef+import Data.Map (Map) import qualified Data.Map as Map-import Data.Either (partitionEithers)+import Data.Maybe (catMaybes)+ import qualified Data.Set as Set-import Control.Applicative-import Data.Maybe (catMaybes)-import System.Directory (createDirectoryIfMissing, getDirectoryContents)-import Stack.GhcPkg-import Prelude -- Fix AMP warning+import qualified Data.Text as T ++import Data.Time.Clock+import Data.Typeable (Typeable)+import Path+import Prelude -- Fix AMP warning+import Stack.GhcPkg+import Stack.Types+import System.Directory (createDirectoryIfMissing, getDirectoryContents)+import System.Process.Read+ -- | Cached information on whether a package has profiling libraries newtype ProfilingCache = ProfilingCache (IORef (Map GhcPkgId Bool)) @@ -57,7 +63,16 @@ -> m a ghcPkgDump menv mpkgDb sink = do F.mapM_ (createDatabase menv) mpkgDb -- TODO maybe use some retry logic instead?- sinkProcessStdout Nothing menv "ghc-pkg" args sink+ start <- liftIO getCurrentTime+ a <- sinkProcessStdout Nothing menv "ghc-pkg" args sink+ end <- liftIO getCurrentTime+ $logDebug $ T.concat+ [ "ghc-pkg ("+ , T.pack $ show $ diffUTCTime end start+ , "s) with args "+ , T.pack $ show args+ ]+ return a where args = concat [ case mpkgDb of
src/Stack/PackageIndex.hs view
@@ -33,7 +33,7 @@ logInfo, logWarn) import Control.Monad.Reader (asks) -import Data.Aeson+import Data.Aeson.Extended import qualified Data.Binary as Binary import Data.Binary.VersionTagged (taggedDecodeOrLoad) import Data.ByteString (ByteString)@@ -69,11 +69,12 @@ (</>)) import Prelude -- Fix AMP warning import Stack.Types+import Stack.Types.StackT import System.Directory import System.FilePath (takeBaseName, (<.>)) import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile)-import System.Process.Read (runIn, EnvOverride, doesExecutableExist)+import System.Process.Read (readInNull, EnvOverride, doesExecutableExist) -- | A cabal file with name and version parsed from the filepath, and the -- package description itself ready to be parsed. It's left in unparsed form@@ -197,15 +198,15 @@ -> PackageIndex -> m () updateIndex menv index =- do $logInfo $ "Updating package index " <> indexNameText (indexName index) <> " ..."+ do let name = indexName index+ logUpdate mirror = $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> mirror <> ") ..." git <- isGitInstalled menv- let name = indexName index case (git, indexLocation index) of- (True, ILGit url) -> updateIndexGit menv name index url- (True, ILGitHttp url _) -> updateIndexGit menv name index url- (_, ILHttp url) -> updateIndexHTTP name index url- (False, ILGitHttp _ url) -> updateIndexHTTP name index url- (False, ILGit _) -> throwM $ GitNotAvailable name+ (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)@@ -236,34 +237,34 @@ repoExists <- liftIO (doesDirectoryExist (toFilePath acfDir)) unless repoExists- (do $logInfo ("Cloning package index ... ")- $logDebug ("Cloning Git repo from " <> gitUrl)- runIn suDir "git" menv cloneArgs Nothing)- runIn acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing+ (readInNull suDir "git" menv cloneArgs Nothing)+ $logSticky "Fetching package index ..."+ readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing+ $logStickyDone "Fetched package index." _ <- (liftIO . tryIO) (removeFile (toFilePath tarFile)) when (indexGpgVerify index)- (do runIn 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"])))+ (do 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'- runIn acfDir- "git"- menv- ["archive"- ,"--format=tar"- ,"-o"- ,toFilePath tarFile- ,"current-hackage"]- Nothing+ readInNull acfDir+ "git"+ menv+ ["archive"+ ,"--format=tar"+ ,"-o"+ ,toFilePath tarFile+ ,"current-hackage"]+ Nothing -- | Update the index tarball via HTTP updateIndexHTTP :: (MonadIO m,MonadLogger m@@ -357,7 +358,7 @@ -> PackageIndex -> m (Map PackageIdentifier PackageCache) populateCache menv index = do- $logInfo "Populating index cache, may take a moment ..."+ $logSticky "Populating index cache ..." let toIdent (Left ucf) = Just ( PackageIdentifier (ucfName ucf) (ucfVersion ucf) , PackageCache@@ -385,7 +386,7 @@ | indexRequireHashes index -> throwM $ MissingRequiredHashes (indexName index) ident | otherwise -> return (ident, pc) - $logInfo "Done populating index cache."+ $logStickyDone "Populated index cache." return pis'
src/Stack/Setup.hs view
@@ -16,15 +16,20 @@ import Control.Applicative import Control.Exception (Exception)-import Control.Monad (liftM, when)+import Control.Monad (liftM, when, join, void) import Control.Monad.Catch (MonadThrow, throwM, MonadMask) 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 Data.Aeson+import Data.Aeson.Extended+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8-import Data.Conduit (($$))+import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)+import Data.Conduit.Lift (evalStateC)+import Data.Conduit.Process (ProcessExitedUnsuccessfully) import qualified Data.Conduit.List as CL import Data.IORef import Data.List (intercalate)@@ -36,18 +41,20 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text 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 Network.HTTP.Client.Conduit-import Network.HTTP.Download (download)+import Network.HTTP.Download (verifiedDownload, DownloadRequest(..)) import Path import Path.IO import Prelude -- Fix AMP warning import Stack.Build.Types import Stack.GhcPkg (getGlobalDB) import Stack.Types-import System.Directory+import Stack.Types.StackT+import System.Directory (doesDirectoryExist, createDirectoryIfMissing) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP@@ -62,12 +69,15 @@ , 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 } deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] | UnknownGHCVersion Version (Set MajorVersion) | UnknownOSKey Text+ | GHCSanityCheckCompileFailed ProcessExitedUnsuccessfully (Path Abs File) deriving Typeable instance Exception SetupException instance Show SetupException where@@ -88,21 +98,28 @@ 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/wiki/Downloads\n\n"+ , "for more information. Exception was:\n"+ , show e+ ] -- | 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)- => Bool -- ^ allow system GHC- -> Bool -- ^ install if missing?- -> m BuildConfig-setupEnv useSystem installIfMissing = do+setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, MonadBaseControl IO m)+ => m BuildConfig+setupEnv = do bconfig <- asks getBuildConfig let platform = getPlatform bconfig sopts = SetupOpts- { soptsInstallIfMissing = installIfMissing- , soptsUseSystem = useSystem+ { soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig+ , soptsUseSystem = configSystemGHC $ bcConfig bconfig , soptsExpected = bcGhcVersion bconfig , soptsStackYaml = Just $ bcStackYaml bconfig , soptsForceReinstall = False+ , soptsSanityCheck = False } mghcBin <- ensureGHC sopts menv0 <- getMinimalEnvOverride@@ -128,8 +145,9 @@ -- extra installation bin directories mkDirs <- runReaderT extraBinDirs bconfig let mpath = Map.lookup "PATH" env1- depsPath = mkPath (mkDirs False) mpath- localsPath = mkPath (mkDirs True) mpath+ mkDirs' = map toFilePath . mkDirs+ depsPath = augmentPath (mkDirs' False) mpath+ localsPath = augmentPath (mkDirs' True) mpath deps <- runReaderT packageDatabaseDeps bconfig depsExists <- liftIO $ doesDirectoryExist $ toFilePath deps@@ -171,18 +189,24 @@ !() <- atomicModifyIORef envRef $ \m' -> (Map.insert es eo m', ()) return eo+ return bconfig { bcConfig = (bcConfig bconfig) { configEnvOverride = getEnvOverride' } }- where- mkPath dirs mpath = T.pack $ intercalate [searchPathSeparator]- (map (stripTrailingSlashS . toFilePath) dirs ++ maybe [] (return . T.unpack) mpath) +-- | Augment the PATH environment variable with the given extra paths+augmentPath :: [FilePath] -> Maybe Text -> Text+augmentPath dirs mpath =+ T.pack $ intercalate [searchPathSeparator]+ (map stripTrailingSlashS dirs ++ maybe [] (return . T.unpack) mpath)+ where stripTrailingSlashS = T.unpack . stripTrailingSlashT . T.pack- stripTrailingSlashT t = fromMaybe t $ T.stripSuffix- (T.singleton FP.pathSeparator)- t +stripTrailingSlashT :: Text -> Text+stripTrailingSlashT t = fromMaybe t $ T.stripSuffix+ (T.singleton FP.pathSeparator)+ t+ -- | Ensure GHC is installed and provide the PATHs to add if necessary-ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupOpts -> m (Maybe [FilePath]) ensureGHC sopts = do@@ -202,7 +226,7 @@ expected > system -- If we need to install a GHC, try to do so- if needLocal+ mpaths <- if needLocal then do config <- asks getConfig let tools =@@ -233,6 +257,21 @@ -- TODO: strip the trailing slash for prettier PATH output return $ Just $ map toFilePath $ concat paths else return Nothing++ when (soptsSanityCheck sopts) $ do+ menv <-+ case mpaths of+ Nothing -> return menv0+ Just paths -> do+ config <- asks getConfig+ let m0 = unEnvOverride menv0+ path0 = Map.lookup "PATH" m0+ path = augmentPath paths path0+ m = Map.insert "PATH" path m0+ mkEnvOverride (configPlatform config) m+ sanityCheck menv++ return mpaths where expected = soptsExpected sopts @@ -341,7 +380,7 @@ $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool)) return [] -ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupOpts -> [PackageIdentifier] -- ^ already installed -> m SetupInfo@@ -418,11 +457,10 @@ Platform I386 FreeBSD -> return "freebsd32" Platform X86_64 FreeBSD -> return "freebsd64" Platform I386 Windows -> return "windows32"- -- Note: we always use 32-bit Windows as the 64-bit version has problems- Platform X86_64 Windows -> return "windows32"+ Platform X86_64 Windows -> return "windows64" Platform arch os -> throwM $ UnsupportedSetupCombo os arch -downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadPair -> PackageIdentifier -> m (Path Abs File, ArchiveType)@@ -473,18 +511,18 @@ root <- parseAbsDir root' dir <- liftM (root Path.</>) $ parseRelDir $ packageIdentifierString ident - $logInfo $ "Unpacking GHC ..."+ $logSticky $ "Unpacking GHC ..." $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)- runIn root "tar" menv ["xf", toFilePath archiveFile] Nothing+ readInNull root "tar" menv ["xf", toFilePath archiveFile] Nothing - $logInfo "Configuring GHC ..."- runIn dir (toFilePath $ dir Path.</> $(mkRelFile "configure"))- menv ["--prefix=" ++ toFilePath destDir] Nothing+ $logSticky "Configuring GHC ..."+ readInNull dir (toFilePath $ dir Path.</> $(mkRelFile "configure"))+ menv ["--prefix=" ++ toFilePath destDir] Nothing - $logInfo "Installing GHC ..."- runIn dir "make" menv ["install"] Nothing+ $logSticky "Installing GHC ..."+ readInNull dir "make" menv ["install"] Nothing - $logInfo $ "GHC installed."+ $logStickyDone $ "Installed GHC." $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) where -- | Check if given processes appear to be present, throwing an exception if@@ -502,7 +540,7 @@ exists <- doesExecutableExist menv tool return $ if exists then Nothing else Just tool -installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType@@ -526,7 +564,7 @@ $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) -installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType@@ -545,7 +583,7 @@ -- | 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, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m)+setup7z :: (MonadReader env m, HasHttpManager env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) => SetupInfo -> Config -> m (Path Abs Dir -> Path Abs File -> n ())@@ -566,15 +604,15 @@ exe = dir </> $(mkRelFile "7z.exe") dll = dir </> $(mkRelFile "7z.dll") -chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m)+chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) => Text -> Text -- ^ URL -> Path Abs File -- ^ destination -> m () chattyDownload label url path = do req <- parseUrl $ T.unpack url- $logInfo $ T.concat- [ "Downloading "+ $logSticky $ T.concat+ [ "Preparing to download " , label , " ..." ]@@ -585,7 +623,73 @@ , T.pack $ toFilePath path , " ..." ]- x <- download req path -- TODO add progress indicator++ let dReq = DownloadRequest+ { drRequest = req+ , drHashChecks = []+ , drLengthCheck = Nothing+ }+ runInBase <- liftBaseWith $ \run -> return (void . run)+ x <- verifiedDownload dReq path (chattyDownloadProgress runInBase) if x- then $logInfo ("Downloaded " <> label <> ".")- else $logDebug "Already downloaded."+ then $logStickyDone ("Downloaded " <> label <> ".")+ else $logStickyDone "Already downloaded."+ where+ 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 $+ label <> ": " <> T.pack (show totalSoFar) <> " bytes downloaded..."+++-- 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)+ => EnvOverride+ -> m ()+sanityCheck menv = withSystemTempDirectory "stack-sanity-check" $ \dir -> do+ dir' <- parseAbsDir dir+ let fp = toFilePath $ dir' </> $(mkRelFile "Main.hs")+ liftIO $ writeFile fp $ unlines+ [ "import Distribution.Simple" -- ensure Cabal library is present+ , "main = putStrLn \"Hello World\""+ ]+ ghc <- join $ findExecutable menv "ghc"+ $logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc)+ eres <- tryProcessStdout (Just dir') menv "ghc" [fp]+ case eres of+ Left e -> throwM $ GHCSanityCheckCompileFailed e ghc+ Right _ -> return () -- TODO check that the output of running the command is correct
src/Stack/Types/Config.hs view
@@ -9,13 +9,13 @@ module Stack.Types.Config where -import Control.Applicative ((<|>))+import Control.Applicative ((<|>), (<$>), (<*>), pure) import Control.Exception-import Control.Monad (liftM)+import Control.Monad (liftM, mzero) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)-import Data.Aeson (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object- ,(.=), (.:?), (.!=), (.:))+import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object+ ,(.=), (.:?), (.!=), (.:), Value (String)) import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8@@ -23,13 +23,15 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid-import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Typeable import Distribution.System (Platform) import qualified Distribution.Text+import Distribution.Version (anyVersion, intersectVersionRanges)+import qualified Paths_stack as Meta+import Network.HTTP.Client (parseUrl) import Path import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import Stack.Types.Docker@@ -41,24 +43,24 @@ -- | The top-level Stackage configuration. data Config =- Config {configStackRoot :: !(Path Abs Dir)+ Config {configStackRoot :: !(Path Abs Dir) -- ^ ~/.stack more often than not- ,configDocker :: !DockerOpts- ,configEnvOverride :: !(EnvSettings -> IO EnvOverride)+ ,configDocker :: !DockerOpts+ ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools- ,configLocalPrograms :: !(Path Abs Dir)+ ,configLocalPrograms :: !(Path Abs Dir) -- ^ Path containing local installations (mainly GHC)- ,configConnectionCount :: !Int+ ,configConnectionCount :: !Int -- ^ How many concurrent connections are allowed when downloading- ,configHideTHLoading :: !Bool+ ,configHideTHLoading :: !Bool -- ^ Hide the Template Haskell "Loading package ..." messages from the -- console- ,configPlatform :: !Platform+ ,configPlatform :: !Platform -- ^ The platform we're building for, used in many directory names- ,configLatestSnapshotUrl :: !Text+ ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available.- ,configPackageIndices :: ![PackageIndex]+ ,configPackageIndices :: ![PackageIndex] -- ^ Information on package indices. This is left biased, meaning that -- packages in an earlier index will shadow those in a later index. --@@ -73,6 +75,18 @@ -- 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.+ ,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 } -- | Information on a single package index@@ -150,8 +164,9 @@ , bcGhcVersion :: !Version -- ^ Version of GHC we'll be using for this build, @Nothing@ if no -- preference- , bcPackages :: !(Set (Path Abs Dir))- -- ^ Local packages identified by a path+ , bcPackages :: !(Map (Path Abs Dir) Bool)+ -- ^ Local packages identified by a path, Bool indicates whether it is+ -- allowed to be wanted (see 'peValidWanted') , bcExtraDeps :: !(Map PackageName Version) -- ^ Extra dependencies specified in configuration. --@@ -168,6 +183,20 @@ -- ^ Per-package flag overrides } +-- | Configuration after the environment has been setup.+data EnvConfig = EnvConfig+ {envConfigBuildConfig :: !BuildConfig+ ,envConfigCabalVersion :: !Version}+instance HasBuildConfig EnvConfig where+ getBuildConfig = envConfigBuildConfig+instance HasConfig EnvConfig+instance HasPlatform EnvConfig+instance HasStackRoot EnvConfig+class HasEnvConfig r where+ getEnvConfig :: r -> EnvConfig+instance HasEnvConfig EnvConfig where+ getEnvConfig = id+ -- | Value returned by 'Stack.Config.loadConfig'. data LoadConfig m = LoadConfig { lcConfig :: !Config@@ -184,14 +213,65 @@ | ExecStrategy deriving (Show, Eq, Ord) +data PackageEntry = PackageEntry+ { peValidWanted :: !Bool+ -- ^ Can this package be considered wanted? Useful to disable when simply+ -- modifying an upstream package, see:+ -- https://github.com/commercialhaskell/stack/issues/219+ , peLocation :: !PackageLocation+ , peSubdirs :: ![FilePath]+ }+ deriving Show+instance ToJSON PackageEntry where+ toJSON pe | peValidWanted pe && null (peSubdirs pe) =+ toJSON $ peLocation pe+ toJSON pe = object+ [ "valid-wanted" .= peValidWanted pe+ , "location" .= peLocation pe+ , "subdirs" .= peSubdirs pe+ ]+instance FromJSON PackageEntry where+ parseJSON (String t) = do+ loc <- parseJSON $ String t+ return PackageEntry+ { peValidWanted = True+ , peLocation = loc+ , peSubdirs = []+ }+ parseJSON v = withObject "PackageEntry" (\o -> PackageEntry+ <$> o .:? "valid-wanted" .!= True+ <*> 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@.+ | PLHttpTarball Text+ | PLGit Text Text+ -- ^ URL and commit+ deriving Show+instance ToJSON PackageLocation where+ toJSON (PLFilePath fp) = toJSON fp+ toJSON (PLHttpTarball t) = toJSON t+ toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y]+instance FromJSON PackageLocation where+ parseJSON v = git v <|> withText "PackageLocation" (\t -> http t <|> file t) v+ where+ file t = pure $ PLFilePath $ T.unpack t+ http t =+ case parseUrl $ T.unpack t of+ Left _ -> mzero+ Right _ -> return $ PLHttpTarball t+ git = withObject "PackageGitLocation" $ \o -> PLGit+ <$> o .: "git"+ <*> 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 :: ![FilePath]- -- ^ Components of the package list which refer to local directories- --- -- Note that we use @FilePath@ and not @Path@s. The goal is: first parse- -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.+ { 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@@ -287,16 +367,28 @@ -- Configurations may be "cascaded" using mappend (left-biased). data ConfigMonoid = ConfigMonoid- { configMonoidDockerOpts :: !DockerOptsMonoid+ { configMonoidDockerOpts :: !DockerOptsMonoid -- ^ Docker options.- , configMonoidConnectionCount :: !(Maybe Int)+ , configMonoidConnectionCount :: !(Maybe Int) -- ^ See: 'configConnectionCount'- , configMonoidHideTHLoading :: !(Maybe Bool)+ , configMonoidHideTHLoading :: !(Maybe Bool) -- ^ See: 'configHideTHLoading'- , configMonoidLatestSnapshotUrl :: !(Maybe Text)+ , configMonoidLatestSnapshotUrl :: !(Maybe Text) -- ^ See: 'configLatestSnapshotUrl'- , configMonoidPackageIndices :: !(Maybe [PackageIndex])+ , configMonoidPackageIndices :: !(Maybe [PackageIndex]) -- ^ See: 'configPackageIndices'+ , configMonoidSystemGHC :: !(Maybe Bool)+ -- ^ See: 'configSystemGHC'+ ,configMonoidInstallGHC :: !(Maybe Bool)+ -- ^ See: 'configInstallGHC'+ ,configMonoidRequireStackVersion :: !VersionRange+ -- ^ See: 'configRequireStackVersion'+ ,configMonoidOS :: !(Maybe String)+ -- ^ Used for overriding the platform+ ,configMonoidArch :: !(Maybe String)+ -- ^ Used for overriding the platform+ ,configMonoidJobs :: !(Maybe Int)+ -- ^ See: 'configJobs' } deriving Show @@ -307,6 +399,12 @@ , configMonoidHideTHLoading = Nothing , configMonoidLatestSnapshotUrl = Nothing , configMonoidPackageIndices = Nothing+ , configMonoidSystemGHC = Nothing+ , configMonoidInstallGHC = Nothing+ , configMonoidRequireStackVersion = anyVersion+ , configMonoidOS = Nothing+ , configMonoidArch = Nothing+ , configMonoidJobs = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r@@ -314,6 +412,13 @@ , 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+ , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l)+ (configMonoidRequireStackVersion r)+ , configMonoidOS = configMonoidOS l <|> configMonoidOS r+ , configMonoidArch = configMonoidArch l <|> configMonoidArch r+ , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r } instance FromJSON ConfigMonoid where@@ -325,23 +430,58 @@ configMonoidHideTHLoading <- obj .:? "hide-th-loading" configMonoidLatestSnapshotUrl <- obj .:? "latest-snapshot-url" configMonoidPackageIndices <- obj .:? "package-indices"+ configMonoidSystemGHC <- obj .:? "system-ghc"+ configMonoidInstallGHC <- obj .:? "install-ghc"+ configMonoidRequireStackVersion <- unVersionRangeJSON <$>+ obj .:? "require-stack-version"+ .!= VersionRangeJSON anyVersion+ configMonoidOS <- obj .:? "os"+ configMonoidArch <- obj .:? "arch"+ configMonoidJobs <- obj .:? "jobs" return ConfigMonoid {..} +-- | 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)))+ data ConfigException = ParseResolverException Text | NoProjectConfigFound (Path Abs Dir)+ | UnexpectedTarballContents [Path Abs Dir] [Path Abs File]+ | BadStackVersionException VersionRange deriving Typeable instance Show ConfigException where show (ParseResolverException t) = concat [ "Invalid resolver value: " , T.unpack t- , ". Possible valid values include lts-2.12, nightly-2015-01-01, and ghc-7.10."+ , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, and ghc-7.10. "+ , "See https://www.stackage.org/snapshots for a complete list." ] show (NoProjectConfigFound dir) = concat [ "Unable to find a stack.yaml file in the current directory (" , toFilePath dir , ") or its ancestors" ]+ 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 ("+ , T.unpack (versionRangeText requiredRange)+ , ") specified in stack.yaml." ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig@@ -380,11 +520,14 @@ base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" return (root </> $(mkRelDir "packages") </> name </> ver </> base) +workDirRel :: Path Rel Dir+workDirRel = $(mkRelDir ".stack-work")+ -- | Per-project work dir configProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir) configProjectWorkDir = do bc <- asks getBuildConfig- return (bcRoot bc </> $(mkRelDir ".stack-work"))+ return (bcRoot bc </> workDirRel) -- | File containing the profiling cache, see "Stack.PackageDump" configProfilingCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)
src/Stack/Types/Docker.hs view
@@ -5,7 +5,7 @@ module Stack.Types.Docker where import Control.Applicative-import Data.Aeson+import Data.Aeson.Extended import Data.Monoid import Data.Text (Text) import Path@@ -51,7 +51,7 @@ ,dockerMonoidEnable :: !(Maybe Bool) -- ^ Is using Docker enabled? ,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)- -- ^ Docker repository name (e.g. @fpco/dev@ or @fpco/dev:lts-2.8@)+ -- ^ 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)
src/Stack/Types/FlagName.hs view
@@ -23,7 +23,7 @@ import Control.Applicative import Control.Monad.Catch-import Data.Aeson+import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinators import Data.Binary (Binary)
src/Stack/Types/GhcPkgId.hs view
@@ -14,7 +14,7 @@ import Control.Applicative import Control.Monad.Catch-import Data.Aeson+import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Binary (Binary) import Data.ByteString.Char8 (ByteString)
src/Stack/Types/Internal.hs view
@@ -2,7 +2,9 @@ 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 @@ -10,7 +12,8 @@ data Env config = Env {envConfig :: !config ,envLogLevel :: !LogLevel- ,envManager :: !Manager}+ ,envManager :: !Manager+ ,envSticky :: !Sticky} instance HasStackRoot config => HasStackRoot (Env config) where getStackRoot = getStackRoot . envConfig@@ -20,6 +23,8 @@ 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@@ -32,3 +37,13 @@ instance HasLogLevel LogLevel where getLogLevel = id++newtype Sticky = Sticky+ { unSticky :: Maybe (MVar (Maybe Text))+ }++class HasSticky r where+ getSticky :: r -> Sticky++instance HasSticky (Env config) where+ getSticky = envSticky
src/Stack/Types/PackageIdentifier.hs view
@@ -23,7 +23,7 @@ import Control.DeepSeq import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM)-import Data.Aeson+import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Binary (Binary) import Data.ByteString (ByteString)
src/Stack/Types/PackageName.hs view
@@ -27,7 +27,7 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Catch-import Data.Aeson+import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinators import Data.Binary (Binary)
src/Stack/Types/StackT.hs view
@@ -17,10 +17,14 @@ ,StackLoggingT ,runStackT ,runStackLoggingT- ,newTLSManager)+ ,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@@ -29,13 +33,19 @@ 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.IO as T import Data.Time-import Language.Haskell.TH.Syntax (Loc(..))+import Language.Haskell.TH import Network.HTTP.Client.Conduit (HasHttpManager(..)) import Network.HTTP.Conduit import Prelude -- Fix AMP warning import Stack.Types.Internal+import System.IO import System.Log.FastLogger #ifndef MIN_VERSION_time@@ -67,14 +77,14 @@ -- | Takes the configured log level into account. instance (MonadIO m) => MonadLogger (StackT config m) where- monadLoggerLog = loggerFunc+ monadLoggerLog = stickyLoggerFunc -- | Run a Stack action. runStackT :: (MonadIO m,MonadBaseControl IO m) => Manager -> LogLevel -> config -> StackT config m a -> m a runStackT manager logLevel config m =- runReaderT (unStackT m)- (Env config logLevel manager)+ withSticky (\sticky -> runReaderT (unStackT m)+ (Env config logLevel manager sticky)) -------------------------------------------------------------------------------- -- Logging only StackLoggingT monad transformer@@ -82,8 +92,8 @@ -- | The monad used for logging in the executable @stack@ before -- anything has been initialized. newtype StackLoggingT m a =- StackLoggingT {unStackLoggingT :: ReaderT (LogLevel,Manager) m a}- deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader (LogLevel,Manager),MonadCatch,MonadMask,MonadTrans)+ StackLoggingT {unStackLoggingT :: ReaderT (LogLevel,Manager,Sticky) m a}+ deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader (LogLevel,Manager,Sticky),MonadCatch,MonadMask,MonadTrans) deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m) @@ -93,26 +103,30 @@ restoreM = defaultRestoreM instance MonadTransControl StackLoggingT where- type StT StackLoggingT a = StT (ReaderT (LogLevel,Manager)) a+ type StT StackLoggingT a = StT (ReaderT (LogLevel,Manager,Sticky)) a liftWith = defaultLiftWith StackLoggingT unStackLoggingT restoreT = defaultRestoreT StackLoggingT -- | Takes the configured log level into account. instance (MonadIO m) => MonadLogger (StackLoggingT m) where- monadLoggerLog = loggerFunc+ monadLoggerLog = stickyLoggerFunc -instance HasLogLevel (LogLevel,Manager) where- getLogLevel = fst+instance HasSticky (LogLevel,Manager,Sticky) where+ getSticky (_,_,s) = s -instance HasHttpManager (LogLevel,Manager) where- getHttpManager = snd+instance HasLogLevel (LogLevel,Manager,Sticky) where+ getLogLevel (l,_,_) = l +instance HasHttpManager (LogLevel,Manager,Sticky) where+ getHttpManager (_,m,_) = m+ -- | Run the logging monad. runStackLoggingT :: MonadIO m => Manager -> LogLevel -> StackLoggingT m a -> m a runStackLoggingT manager logLevel m =- runReaderT (unStackLoggingT m)- (logLevel,manager)+ withSticky (\sticky ->+ runReaderT (unStackLoggingT m)+ (logLevel,manager,sticky)) -- | Convenience for getting a 'Manager' newTLSManager :: MonadIO m => m Manager@@ -120,6 +134,65 @@ -------------------------------------------------------------------------------- -- Logging functionality+stickyLoggerFunc :: (HasSticky r, HasLogLevel 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+ newState <-+ case level of+ LevelOther "sticky-done" -> do+ clear+ let text =+ T.decodeUtf8 msgBytes+ liftIO (T.putStrLn text)+ return Nothing+ LevelOther "sticky" -> do+ clear+ let text =+ T.decodeUtf8 msgBytes+ liftIO (T.putStr text)+ return (Just text)+ _+ | level >= maxLogLevel -> do+ clear+ loggerFunc loc src level msg+ case sticky of+ Nothing ->+ return Nothing+ Just line -> do+ liftIO (T.putStr line)+ return sticky+ | otherwise ->+ return sticky+ liftIO (putMVar ref newState)+ where+ msgBytes =+ fromLogStr+ (toLogStr msg) -- | Logging function takes the log level into account. loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)@@ -162,3 +235,40 @@ (char loc) where line = show . fst . loc_start char = show . snd . loc_start++-- | With a sticky state, do the thing.+withSticky :: MonadIO m+ => (Sticky -> m b) -> m b+withSticky m = do+ terminal <- liftIO (hIsTerminalDevice stdout)+ 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"
src/Stack/Types/Version.hs view
@@ -30,7 +30,7 @@ import Control.Applicative import Control.DeepSeq import Control.Monad.Catch-import Data.Aeson+import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Binary (Binary) import Data.ByteString (ByteString)
src/System/Process/Read.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}@@ -8,30 +9,37 @@ -- | Reading from external processes. module System.Process.Read- (callProcess+ (readProcessStdoutLogStderr ,readProcessStdout ,tryProcessStdout+ ,sinkProcessStdoutLogStderr ,sinkProcessStdout- ,runIn+ ,sinkProcessStderrStdout ,EnvOverride ,unEnvOverride ,mkEnvOverride ,envHelper ,doesExecutableExist ,findExecutable- ,getEnvOverride)+ ,getEnvOverride+ ,envSearchPath+ ,preProcess+ ,readProcessNull+ ,readInNull) where import Control.Applicative import Control.Arrow ((***), first) import Control.Concurrent.Async (Concurrently (..)) import Control.Exception-import Control.Monad (join, liftM)+import Control.Monad (join, liftM, void) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logError)+import Control.Monad.Trans.Control (MonadBaseControl,liftBaseWith) import qualified Data.ByteString as S import Data.Conduit+import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL import Data.Conduit.Process hiding (callProcess) import Data.Foldable (forM_)@@ -45,10 +53,10 @@ import Distribution.System (OS (Windows), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) import Prelude -- Fix AMP warning-import System.Directory (createDirectoryIfMissing, doesFileExist, canonicalizePath)-import qualified System.FilePath as FP+import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory) import System.Environment (getEnvironment)-import System.Exit (exitWith)+import System.Exit+import qualified System.FilePath as FP -- | Override the environment received by a child process data EnvOverride = EnvOverride@@ -63,6 +71,10 @@ unEnvOverride :: EnvOverride -> Map Text Text unEnvOverride = eoTextMap +-- | Get the list of directories searched+envSearchPath :: EnvOverride -> [FilePath]+envSearchPath = eoPath+ -- | Create a new @EnvOverride@ mkEnvOverride :: MonadIO m => Platform@@ -94,6 +106,44 @@ envHelper :: EnvOverride -> Maybe [(String, String)] envHelper = Just . eoStringList +-- | Read from the process, ignoring any output.+readProcessNull+ :: (MonadIO m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> 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 :: forall (m :: * -> *).+ (MonadLogger m,MonadIO m)+ => Path Abs Dir -- ^ directory to run in+ -> FilePath -- ^ command to run+ -> EnvOverride+ -> [String] -- ^ command line arguments+ -> Maybe Text+ -> m ()+readInNull wd cmd menv args errMsg = do+ result <- liftIO (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)@@ -118,16 +168,38 @@ sinkProcessStdout wd menv name args CL.consume >>= liftIO . evaluate . S.concat --- | Same as @System.Process.callProcess@, but takes an environment override-callProcess :: (MonadIO m)- => Maybe (Path Abs Dir)- -> EnvOverride- -> String- -> [String]- -> m ()-callProcess wd menv name args = sinkProcessStdout wd menv name args CL.sinkNull+-- | Produce a strict 'S.ByteString' from the stdout of a+-- process. Throws a 'ProcessExitedUnsuccessfully' exception if the+-- process fails. Logs process's stderr using @$logError@.+readProcessStdoutLogStderr :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)+ => Text+ -> Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m S.ByteString+readProcessStdoutLogStderr stderrPrefix wd menv name args = do+ stdout <- sinkProcessStdoutLogStderr stderrPrefix wd menv name args CL.consume+ liftIO (evaluate (S.concat stdout)) -- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer.+-- Logs process's stderr using @$logError@.+sinkProcessStdoutLogStderr :: (MonadIO m,MonadLogger m,MonadBaseControl IO m)+ => Text -- ^ Prefix for any logged stderr message+ -> Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> Sink S.ByteString IO a -- ^ Sink for stdout+ -> m a+sinkProcessStdoutLogStderr stderrPrefix wd menv name args sinkStdout = do+ runInBase <- liftBaseWith $ \run -> return (void . run)+ let logSink = CC.mapM_ (liftIO . runInBase . $logError . T.append stderrPrefix)+ sinkStderr = CC.decodeUtf8 =$= CC.line logSink+ (_,stdout) <- sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout+ return stdout++-- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer. sinkProcessStdout :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride@@ -136,48 +208,54 @@ -> Sink S.ByteString IO a -> m a sinkProcessStdout wd menv name args sink = do- name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name- liftIO (maybe (return ()) (createDirectoryIfMissing True . toFilePath) wd)+ (_,stdout) <- sinkProcessStderrStdout wd menv name args CL.sinkNull sink+ return stdout++-- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.+sinkProcessStderrStdout :: (MonadIO m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> 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+ name' <- preProcess wd menv name liftIO (withCheckedProcess (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd } (\ClosedStream out err -> runConcurrently $- Concurrently (asBSSource err $$ CL.sinkNull) *>- Concurrently (asBSSource out $$ sink)))+ (,) <$>+ Concurrently (asBSSource err $$ sinkStderr) <*>+ Concurrently (asBSSource out $$ sinkStdout))) where asBSSource :: Source m S.ByteString -> Source m S.ByteString asBSSource = id --- | Run the given command in the given directory. If it exits with anything--- but success, throw an exception.-runIn :: forall (m :: * -> *).- (MonadLogger m,MonadIO m)- => Path Abs Dir -- ^ directory to run in- -> FilePath -- ^ command to run- -> EnvOverride- -> [String] -- ^ command line arguments- -> Maybe Text- -> m ()-runIn wd cmd menv args errMsg = do- result <- liftIO (try (callProcess (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 () +-- | Perform pre-call-process tasks. Ensure the working directory exists and find the+-- executable path.+preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath+preProcess wd menv name = do+ name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name+ liftIO (maybe (return ()) (createDirectoryIfMissing True . toFilePath) 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 findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File)) findExecutable eo name = liftIO $ do@@ -191,7 +269,7 @@ exists <- doesFileExist fp if exists then do- fp' <- canonicalizePath fp >>= parseAbsFile+ fp' <- makeAbsolute fp >>= parseAbsFile return $ return fp' else loop dirs epath <- loop $ eoPath eo
+ src/System/Process/Run.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Reading from external processes.++module System.Process.Run+ (runIn+ ,callProcess)+ where++import Control.Exception+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 (Path, Abs, Dir, toFilePath)+import Prelude -- Fix AMP warning+import System.Exit (exitWith, ExitCode (..))+import qualified System.Process+import System.Process.Read++-- | 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.+runIn :: forall (m :: * -> *).+ (MonadLogger m,MonadIO m)+ => Path Abs Dir -- ^ directory to run in+ -> FilePath -- ^ command to run+ -> EnvOverride+ -> [String] -- ^ command line arguments+ -> Maybe Text+ -> m ()+runIn wd cmd menv args errMsg = do+ result <- liftIO (try (callProcess (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 ()++-- | Like as @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)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m ()+callProcess wd menv cmd0 args = do+ cmd <- preProcess wd menv cmd0+ let c = (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)+ liftIO (System.Process.createProcess c >>= action)
src/main/Main.hs view
@@ -13,7 +13,7 @@ import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger-import Control.Monad.Reader (asks)+import Control.Monad.Reader (asks, runReaderT) import Data.Char (toLower) import Data.List import qualified Data.List as List@@ -37,7 +37,7 @@ import Stack.Constants import qualified Stack.Docker as Docker import Stack.Fetch-import Stack.GhcPkg (envHelper)+import Stack.GhcPkg (envHelper,getCabalPkgVer) import qualified Stack.PackageIndex import Stack.Path import Stack.Setup@@ -55,7 +55,6 @@ main = do plugins <- findPlugins (T.pack stackProgName) tryRunPlugin plugins- Docker.checkVersions progName <- getProgName args <- getArgs execExtraHelp args@@ -72,6 +71,10 @@ "Build the project(s) in this directory/configuration" (buildCmd DoNothing) buildOpts+ addCommand "install"+ "Build executables and install to a user path"+ installCmd+ buildOpts addCommand "test" "Build and test the project(s) in this directory/configuration" (buildCmd DoTests)@@ -124,14 +127,6 @@ "Clean the local packages" cleanCmd (pure ())- addCommand "deps"- "Install dependencies"- depsCmd- ((,)- <$> (some (argument readPackageName- (metavar "[PACKAGES]")))- <*> (flag False True (long "dry-run" <>- help "Don't build anything, just prepare to"))) addSubCommands "path" "Print path information for certain things"@@ -247,10 +242,13 @@ return (bcGhcVersion bc, Just $ bcStackYaml bc) mpaths <- runStackT manager globalLogLevel (lcConfig lc) $ ensureGHC SetupOpts { soptsInstallIfMissing = True- , soptsUseSystem = globalSystemGhc && not scoForceReinstall+ , soptsUseSystem =+ (configSystemGHC $ lcConfig lc)+ && not scoForceReinstall , soptsExpected = ghc , soptsStackYaml = mstack , soptsForceReinstall = scoForceReinstall+ , soptsSanityCheck = True } case mpaths of Nothing -> $logInfo "GHC on PATH would be used"@@ -260,7 +258,7 @@ withBuildConfig :: GlobalOpts -> NoBuildConfigStrategy- -> StackT BuildConfig IO ()+ -> StackT EnvConfig IO () -> IO () withBuildConfig go@GlobalOpts{..} strat inner = do (manager, lc) <- loadConfigWithOpts go@@ -268,27 +266,22 @@ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do bconfig1 <- runStackLoggingT manager globalLogLevel $ lcLoadBuildConfig lc strat- bconfig2 <- runStackT manager globalLogLevel bconfig1 $- setupEnv globalSystemGhc globalInstallGhc- runStackT manager globalLogLevel bconfig2 inner+ (bconfig2,cabalVer) <-+ runStackT+ manager globalLogLevel bconfig1+ (do cfg <- setupEnv+ menv <- runReaderT getMinimalEnvOverride cfg+ cabalVer <- getCabalPkgVer menv+ return (cfg,cabalVer))+ runStackT+ manager+ globalLogLevel+ (EnvConfig bconfig2 cabalVer)+ inner cleanCmd :: () -> GlobalOpts -> IO () cleanCmd () go = withBuildConfig go ThrowException clean --- | Install dependencies-depsCmd :: ([PackageName], Bool) -> GlobalOpts -> IO ()-depsCmd (names, dryRun) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $- Stack.Build.build BuildOpts- { boptsTargets = Right names- , boptsLibProfile = False- , boptsExeProfile = False- , boptsEnableOptimizations = Nothing- , boptsFinalAction = DoNothing- , boptsDryrun = dryRun- , boptsGhcOptions = []- , boptsFlags = Map.empty- }- -- | Parser for package names readPackageName :: ReadM PackageName readPackageName = do@@ -323,6 +316,11 @@ buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go CreateConfig $ Stack.Build.build opts { boptsFinalAction = finalAction } +-- | Install+installCmd :: BuildOpts -> GlobalOpts -> IO ()+installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $+ Stack.Build.build opts { boptsInstallExes = True }+ -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go@GlobalOpts{..} = do@@ -394,12 +392,14 @@ -- | Parser for build arguments. buildOpts :: Parser BuildOpts-buildOpts = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>- optimize <*> finalAction <*> dryRun <*> ghcOpts <*> flags+buildOpts =+ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>+ optimize <*> finalAction <*> dryRun <*> ghcOpts <*> flags <*>+ installExes where optimize = maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm target =- fmap (Left . map T.pack)+ fmap (map T.pack) (many (strArgument (metavar "TARGET" <> help "If none specified, use all packages defined in current directory")))@@ -414,10 +414,15 @@ "library profiling for TARGETs and all its dependencies" idm finalAction = pure DoNothing+ installExes = pure False dryRun = flag False True (long "dry-run" <> help "Don't build anything, just prepare to")- ghcOpts =- many (fmap T.pack+ ghcOpts = (++)+ <$> flag [] ["-Wall", "-Werror"]+ ( long "pedantic"+ <> help "Turn on -Wall and -Werror (note: option name may change in the future"+ )+ <*> many (fmap T.pack (strOption (long "ghc-options" <> metavar "OPTION" <> help "Additional options passed to GHC")))@@ -481,14 +486,6 @@ GlobalOpts <$> logLevelOpt <*> configOptsParser False- <*> boolFlags True- "system-ghc"- "using the system installed GHC (on the PATH) if available and a matching version"- idm- <*> boolFlags True- "install-ghc"- "downloading and installing GHC if necessary (can be done manually with stack setup)"- idm -- | Parse for a logging level. logLevelOpt :: Parser LogLevel@@ -499,7 +496,7 @@ help "Verbosity: silent, error, warn, info, debug")) <|> flag defaultLogLevel verboseLevel- (short 'v' <>+ (short 'v' <> long "verbose" <> help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"")) where verboseLevel = LevelDebug showLevel l =@@ -525,8 +522,6 @@ data GlobalOpts = GlobalOpts { globalLogLevel :: LogLevel -- ^ Log level , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'- , globalSystemGhc :: Bool -- ^ Use system GHC if available and correct version?- , globalInstallGhc :: Bool -- ^ Install GHC if missing } deriving (Show) -- | Load the configuration with a manager. Convenience function used
src/test/Stack/PackageDumpSpec.hs view
@@ -149,8 +149,10 @@ , (4, (4, 'a')) ] - prop "invariant holds" $ \prunes ->- checkDepsPresent prunes $ fmap fst $ pruneDeps fst fst snd bestPrune prunes+ 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)])
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.0.1+version: 0.0.2 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@@ -24,7 +24,7 @@ library hs-source-dirs: src/- ghc-options: -Wall -pgmPcpphs -optP--cpp+ ghc-options: -Wall exposed-modules: Options.Applicative.Builder.Extra Stack.BuildPlan Stack.Config@@ -58,6 +58,7 @@ Stack.Build.Types Stack.Build.Doc System.Process.Read+ System.Process.Run Network.HTTP.Download.Verified other-modules: Network.HTTP.Download Control.Concurrent.Execute@@ -65,20 +66,22 @@ Path.IO System.Process.PagerEditor Paths_stack+ Data.Aeson.Extended Data.Attoparsec.Combinators Data.Binary.VersionTagged Data.Set.Monad Data.Maybe.Extra- Control.Monad.Logger.Sticky build-depends: Cabal >= 1.18.1.5 , aeson >= 0.8.0.2 , async >= 2.0.2 , attoparsec >= 0.12.1.5 , base >= 4 && <5+ , base16-bytestring , bifunctors >= 4.2.1 , binary >= 0.7 , base64-bytestring , bytestring+ , conduit-combinators >= 0.3.1 , conduit >= 1.2.4 , conduit-extra >= 1.1.7.1 , containers >= 0.5.5.1@@ -127,7 +130,6 @@ , deepseq if !os(windows) build-depends: unix >= 2.7.0.1- build-tools: cpphs default-language: Haskell2010 executable stack