diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -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 diff --git a/src/Control/Monad/Logger/Sticky.hs b/src/Control/Monad/Logger/Sticky.hs deleted file mode 100644 --- a/src/Control/Monad/Logger/Sticky.hs +++ /dev/null @@ -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 ' ') diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extended.hs @@ -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 (.:?) #-} diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -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. -- diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -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 diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -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 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -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. diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -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 diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -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 diff --git a/src/Stack/Build/Types.hs b/src/Stack/Build/Types.hs --- a/src/Stack/Build/Types.hs +++ b/src/Stack/Build/Types.hs @@ -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) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -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) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -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) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -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") diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -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 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -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 diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -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) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -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) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -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 diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -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' diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -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) diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -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) diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -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) diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -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) diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -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 diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -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) diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -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) diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -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" diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -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) diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -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 diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Run.hs @@ -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) diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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 diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -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)]) diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -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