stack 0.0.0 → 0.0.1
raw patch · 57 files changed
+11932/−26 lines, 57 filesdep +Cabaldep +aesondep +asyncdep ~basenew-uploader
Dependencies added: Cabal, aeson, async, attoparsec, base64-bytestring, bifunctors, binary, bytestring, conduit, conduit-extra, containers, cryptohash, cryptohash-conduit, deepseq, directory, either, enclosed-exceptions, exceptions, fast-logger, filepath, hashable, hspec, http-client, http-client-tls, http-conduit, http-types, lifted-base, monad-control, monad-logger, monad-loops, mtl, old-locale, optparse-applicative, optparse-simple, path, persistent, persistent-sqlite, persistent-template, pretty, process, resourcet, safe, split, stack, stm, streaming-commons, tar, template-haskell, temporary, text, time, transformers, transformers-base, unix, unordered-containers, vector, vector-binary-instances, void, yaml, zlib
Dependency ranges changed: base
Files
- ChangeLog.md +3/−0
- LICENSE +22/−18
- Main.hs +0/−2
- README.md +75/−0
- src/Control/Concurrent/Execute.hs +114/−0
- src/Control/Monad/Logger/Sticky.hs +112/−0
- src/Data/Attoparsec/Combinators.hs +24/−0
- src/Data/Binary/VersionTagged.hs +65/−0
- src/Data/Maybe/Extra.hs +10/−0
- src/Data/Set/Monad.hs +28/−0
- src/Network/HTTP/Download.hs +167/−0
- src/Network/HTTP/Download/Verified.hs +209/−0
- src/Options/Applicative/Builder/Extra.hs +68/−0
- src/Path/Find.hs +70/−0
- src/Path/IO.hs +140/−0
- src/Stack/Build.hs +312/−0
- src/Stack/Build/Cache.hs +238/−0
- src/Stack/Build/ConstructPlan.hs +345/−0
- src/Stack/Build/Doc.hs +89/−0
- src/Stack/Build/Execute.hs +524/−0
- src/Stack/Build/Installed.hs +188/−0
- src/Stack/Build/Source.hs +160/−0
- src/Stack/Build/Types.hs +415/−0
- src/Stack/BuildPlan.hs +599/−0
- src/Stack/Config.hs +375/−0
- src/Stack/Constants.hs +189/−0
- src/Stack/Docker.hs +975/−0
- src/Stack/Docker/GlobalDB.hs +94/−0
- src/Stack/Fetch.hs +449/−0
- src/Stack/GhcPkg.hs +152/−0
- src/Stack/Package.hs +613/−0
- src/Stack/PackageDump.hs +353/−0
- src/Stack/PackageIndex.hs +400/−0
- src/Stack/Path.hs +61/−0
- src/Stack/Setup.hs +591/−0
- src/Stack/Types.hs +14/−0
- src/Stack/Types/BuildPlan.hs +384/−0
- src/Stack/Types/Config.hs +483/−0
- src/Stack/Types/Docker.hs +219/−0
- src/Stack/Types/FlagName.hs +131/−0
- src/Stack/Types/GhcPkgId.hs +84/−0
- src/Stack/Types/Internal.hs +34/−0
- src/Stack/Types/PackageIdentifier.hs +115/−0
- src/Stack/Types/PackageName.hs +152/−0
- src/Stack/Types/StackT.hs +164/−0
- src/Stack/Types/Version.hs +203/−0
- src/System/Process/PagerEditor.hs +129/−0
- src/System/Process/Read.hs +223/−0
- src/main/Main.hs +541/−0
- src/main/Plugins.hs +202/−0
- src/main/Plugins/Commands.hs +27/−0
- src/test/Spec.hs +1/−0
- src/test/Stack/BuildPlanSpec.hs +124/−0
- src/test/Stack/ConfigSpec.hs +108/−0
- src/test/Stack/PackageDumpSpec.hs +172/−0
- src/test/Test.hs +5/−0
- stack.cabal +188/−6
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.0.1++* First public release, beta quality
LICENSE view
@@ -1,20 +1,24 @@-Copyright (c) 2015 Dan Burton--Permission is hereby granted, free of charge, to any person obtaining-a copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:+Copyright (c) 2015, stack+All rights reserved. -The above copyright notice and this permission notice shall be included-in all copies or substantial portions of the Software.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of stackage-common nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− Main.hs
@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "The Haskell Tool Stack"
+ README.md view
@@ -0,0 +1,75 @@+## The Haskell Tool Stack++[](https://travis-ci.org/commercialhaskell/stack)++`stack` is a cross-platform program for developing Haskell+projects. It is aimed at Haskellers both new and experienced.++<img src="http://i.imgur.com/WW69oTj.gif" width="50%" align="right">++It features:++* Installing GHC automatically.+* Installing packages needed for your project.+* Building your project.+* Testing your project.+* Benchmarking your project.++#### How to install++Downloads are available by operating system:++* [Windows](https://github.com/commercialhaskell/stack/wiki/Downloads#windows)+* [OS X](https://github.com/commercialhaskell/stack/wiki/Downloads#os-x)+* [Ubuntu](https://github.com/commercialhaskell/stack/wiki/Downloads#ubuntu)+* [Arch Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#arch-linux)+* [Linux (general)](https://github.com/commercialhaskell/stack/wiki/Downloads#linux)++#### How to use++Go into a Haskell project directory and run `stack build`. This will+do the following:++* Automatically create a stack configuration file in the current+ directory.+* Figure out what Stackage release (LTS or nightly) is appropriate+ for the dependencies.+* Download and install GHC.+* Download the package index.+* Download and install all necessary dependencies for the project.+* Build and install the project.++Run `stack` for a complete list of commands.++#### Architecture++A full description of the architecture+[is available here](https://github.com/commercialhaskell/stack/wiki/Architecture).++#### Frequently Asked Questions++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`.++#### Why stack?++stack is a project of the [Commercial Haskell](http://commercialhaskell.com/)+group, spearheaded by [FP Complete](https://www.fpcomplete.com/). It is+designed to answer the needs of commercial Haskell users, hobbyist Haskellers,+and individuals and companies thinking about starting to use Haskell. It is+intended to be easy to use for newcomers, while providing the customizability+and power experienced developers need.++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+users everywhere.++A large impetus for the work on stack was a [large survey of people interested+in+Haskell](https://www.fpcomplete.com/blog/2015/05/thousand-user-haskell-survey),+which rated build issues as a major concern. The stack team hopes that stack+can address these concerns.
+ src/Control/Concurrent/Execute.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+-- Concurrent execution with dependencies. Types currently hard-coded for needs+-- of stack, but could be generalized easily.+module Control.Concurrent.Execute+ ( ActionType (..)+ , ActionId (..)+ , ActionContext (..)+ , Action (..)+ , runActions+ ) where++import Control.Applicative+import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.STM+import Control.Exception+import Control.Monad (join)+import Data.Foldable (sequenceA_)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable (Typeable)+import Prelude -- Fix AMP warning+import Stack.Types++data ActionType+ = ATBuild+ | ATInstall+ | ATWanted+ deriving (Show, Eq, Ord)+data ActionId = ActionId !PackageIdentifier !ActionType+ deriving (Show, Eq, Ord)+data Action = Action+ { actionId :: !ActionId+ , actionDeps :: !(Set ActionId)+ , actionDo :: !(ActionContext -> IO ())+ }++data ActionContext = ActionContext+ { acRemaining :: !Int+ -- ^ Does not include the current action+ }+ deriving Show++data ExecuteState = ExecuteState+ { esActions :: TVar [Action]+ , esExceptions :: TVar [SomeException]+ , esInAction :: TVar Int+ }++data ExecuteException+ = InconsistentDependencies+ deriving Typeable+instance Exception ExecuteException++instance Show ExecuteException where+ show InconsistentDependencies =+ "Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team."++runActions :: Int -- ^ threads+ -> [Action]+ -> IO [SomeException]+runActions threads actions0 = do+ es <- ExecuteState+ <$> newTVarIO actions0+ <*> newTVarIO []+ <*> newTVarIO 0+ if threads <= 1+ then runActions' es+ else runConcurrently $ sequenceA_ $ replicate threads $ Concurrently $ runActions' es+ readTVarIO $ esExceptions es++runActions' :: ExecuteState -> IO ()+runActions' ExecuteState {..} =+ loop+ where+ breakOnErrs inner = do+ errs <- readTVar esExceptions+ if null errs+ then inner+ else return $ return ()+ withActions inner = do+ as <- readTVar esActions+ if null as+ then return $ return ()+ else inner as+ loop = join $ atomically $ breakOnErrs $ withActions $ \as -> do+ case break (Set.null . actionDeps) as of+ (_, []) -> do+ inAction <- readTVar esInAction+ if inAction == 0+ then do+ modifyTVar esExceptions (toException InconsistentDependencies:)+ return $ return ()+ else retry+ (xs, action:ys) -> do+ let as' = xs ++ ys+ inAction <- readTVar esInAction+ let remaining = length as' + inAction+ writeTVar esActions as'+ modifyTVar esInAction (+ 1)+ return $ mask $ \restore -> do+ eres <- try $ restore $ actionDo action ActionContext+ { acRemaining = remaining+ }+ case eres of+ Left err -> atomically $ do+ modifyTVar esExceptions (err:)+ modifyTVar esInAction (subtract 1)+ Right () -> do+ atomically $ do+ modifyTVar esInAction (subtract 1)+ let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }+ modifyTVar esActions $ map dropDep+ restore loop
+ src/Control/Monad/Logger/Sticky.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Output a sticky line at the end of output.++module Control.Monad.Logger.Sticky+ (StickyLoggingT+ ,runStickyLoggingT+ ,logSticky)+ where++import Control.Applicative+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Class+import Control.Monad.Catch+import Control.Monad.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Monoid+import Language.Haskell.TH+import System.IO+import System.Log.FastLogger++import Prelude -- avoid AMP warnings++data State = State+ { stateCurrentLine :: !(Maybe ByteString)+ , stateMaxColumns :: !Int+ , stateLastWasSticky :: !Bool+ }++newtype StickyLoggingT m a = StickyLoggingT+ { unStickyLoggingT :: ReaderT (MVar State) m a+ } deriving (Functor,Applicative,Monad,MonadIO,MonadTrans,MonadThrow)++runStickyLoggingT :: MonadIO m => StickyLoggingT m a -> m a+runStickyLoggingT m = do+ state <- liftIO (newMVar (State Nothing 0 False))+ originalMode <- liftIO (hGetBuffering stdout)+ liftIO (hSetBuffering stdout NoBuffering)+ a <- runReaderT (unStickyLoggingT m) state+ state' <- liftIO (takeMVar state)+ liftIO (when (stateLastWasSticky state') (S8.putStr "\n"))+ liftIO (hSetBuffering stdout originalMode)+ return a++logSticky :: Q Exp+logSticky =+ logOther "sticky"++instance (MonadLogger m, MonadIO m) => MonadLogger (StickyLoggingT m) where+ monadLoggerLog loc src level msg = do+ ref <- StickyLoggingT ask+ state <- liftIO (takeMVar ref) -- TODO: make exception-safe.+ case level of+ LevelOther "sticky" ->+ liftIO $+ do S8.putStr+ ("\r" <>+ pad (stateMaxColumns state) msgBytes)+ putMVar+ ref+ (state+ { stateLastWasSticky = True+ , stateMaxColumns = max+ (stateMaxColumns state)+ (S8.length msgBytes)+ , stateCurrentLine = Just msgBytes+ })+ _ -> do+ liftIO+ (S8.putStr+ ("\r" <>+ S8.replicate+ (stateMaxColumns state)+ ' ' <>+ "\r"))+ lift (monadLoggerLog loc src level msg)+ liftIO+ (case stateCurrentLine state of+ Nothing ->+ putMVar+ ref+ (state+ { stateLastWasSticky = False+ , stateMaxColumns = max+ (stateMaxColumns state)+ (S8.length msgBytes)+ })+ Just line -> do+ S8.putStr line+ putMVar+ ref+ (state+ { stateLastWasSticky = True+ , stateMaxColumns = max+ (stateMaxColumns state)+ (S8.length msgBytes)+ }))+ where+ msgBytes =+ fromLogStr+ (toLogStr msg)+ pad width s =+ S8.take+ (max width (S8.length s))+ (s <>+ S8.replicate width ' ')
+ src/Data/Attoparsec/Combinators.hs view
@@ -0,0 +1,24 @@+-- | More readable combinators for writing parsers.++module Data.Attoparsec.Combinators where++import Control.Applicative+import Data.Monoid++-- | Concatenate two parsers.+appending :: (Applicative f,Monoid a)+ => f a -> f a -> f a+appending a b = (<>) <$> a <*> b++-- | Alternative parsers.+alternating :: Alternative f+ => f a -> f a -> f a+alternating a b = a <|> b++-- | Pure something.+pured :: (Applicative g,Applicative f) => g a -> g (f a)+pured = fmap pure++-- | Concatting the result of an action.+concating :: (Monoid m,Applicative f) => f [m] -> f m+concating = fmap mconcat
+ src/Data/Binary/VersionTagged.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Tag a Binary instance with the stack version number to ensure we're+-- reading a compatible format.+module Data.Binary.VersionTagged+ ( taggedDecodeOrLoad+ , taggedEncodeFile+ ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)+import Control.Exception.Enclosed (tryIO)+import qualified Paths_stack+import Stack.Types.Version (Version, fromCabalVersion)+import System.FilePath (takeDirectory)+import System.Directory (createDirectoryIfMissing)+import qualified Data.ByteString as S+import Data.ByteString (ByteString)+import Control.Monad (forM_, when)++tag :: Version+tag = fromCabalVersion Paths_stack.version++magic :: ByteString+magic = "STACK"++newtype WithTag a = WithTag a+instance Binary a => Binary (WithTag a) where+ get = do+ forM_ (S.unpack magic) $ \w -> do+ w' <- getWord8+ when (w /= w')+ $ fail "Mismatched magic string, forcing a recompute"+ tag' <- get+ if tag == tag'+ then fmap WithTag get+ else fail "Mismatched tags, forcing a recompute"+ put (WithTag x) = do+ mapM_ putWord8 $ S.unpack magic+ put tag+ put x++-- | Write to the given file, with a version tag.+taggedEncodeFile :: (Binary a, MonadIO m)+ => FilePath+ -> a+ -> m ()+taggedEncodeFile fp x = liftIO $ do+ createDirectoryIfMissing True $ takeDirectory fp+ encodeFile fp $ WithTag x++-- | Read from the given file. If the read fails, run the given action and+-- write that back to the file. Always starts the file off with the version+-- tag.+taggedDecodeOrLoad :: (Binary a, MonadIO m)+ => FilePath+ -> m a+ -> m a+taggedDecodeOrLoad fp mx = do+ eres <- liftIO $ tryIO $ decodeFileOrFail fp+ case eres of+ Right (Right (WithTag x)) -> return x+ _ -> do+ x <- mx+ taggedEncodeFile fp x+ return x
+ src/Data/Maybe/Extra.hs view
@@ -0,0 +1,10 @@+-- | Extra Maybe utilities.++module Data.Maybe.Extra where++import Control.Monad+import Data.Maybe++-- | Monadic 'mapMaybe'.+mapMaybeM :: Monad f => (a -> f (Maybe b)) -> [a] -> f [b]+mapMaybeM f = liftM catMaybes . mapM f
+ src/Data/Set/Monad.hs view
@@ -0,0 +1,28 @@+-- | Monadic operations for 'Set'.++module Data.Set.Monad+ (mapM+ ,mapM_+ ,filterM)+ where++import Control.Monad (liftM)+import qualified Control.Monad as L+import Data.Set (Set)+import qualified Data.Set as S+import Prelude hiding (mapM,mapM_)++-- | Map over a 'Set' in a monad.+mapM :: (Ord a,Ord b,Monad m)+ => (a -> m b) -> Set a -> m (Set b)+mapM f = liftM S.fromList . L.mapM f . S.toList++-- | Map over a 'Set' in a monad, discarding the result.+mapM_ :: (Ord a,Ord b,Monad m)+ => (a -> m b) -> Set a -> m ()+mapM_ f = L.mapM_ f . S.toList++-- | Map over a 'Set' in a monad.+filterM :: (Ord a,Monad m)+ => (a -> m Bool) -> Set a -> m (Set a)+filterM f = liftM S.fromList . L.filterM f . S.toList
+ src/Network/HTTP/Download.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.Download+ ( verifiedDownload+ , DownloadRequest(..)+ , HashCheck(..)+ , LengthCheck+ , VerifiedDownloadException(..)++ , download+ , redownload+ , downloadJSON+ , parseUrl+ , liftHTTP+ , ask+ , getHttpManager+ , MonadReader+ , HasHttpManager+ ) where++import Control.Exception (Exception)+import Control.Exception.Enclosed (handleIO)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ReaderT, ask,+ runReaderT)+import Data.Aeson (FromJSON, parseJSON)+import Data.Aeson.Parser (json')+import Data.Aeson.Types (parseEither)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Conduit (($$))+import Data.Conduit.Attoparsec (sinkParser)+import Data.Conduit.Binary (sinkHandle, sourceHandle)+import qualified Data.Conduit.Binary as CB+import Data.Foldable (forM_)+import Data.Typeable (Typeable)+import Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,+ Response, checkStatus,+ getHttpManager, parseUrl,+ requestHeaders, responseBody,+ responseHeaders, responseStatus,+ withResponse)+import Network.HTTP.Download.Verified+import Network.HTTP.Types (status200, status304)+import Path (Abs, File, Path, toFilePath)+import System.Directory (createDirectoryIfMissing,+ removeFile,+ renameFile)+import System.FilePath (takeDirectory, (<.>))+import System.IO (IOMode (ReadMode))+import System.IO (IOMode (WriteMode),+ withBinaryFile)++-- | Download the given URL to the given location. If the file already exists,+-- no download is performed. Otherwise, creates the parent directory, downloads+-- to a temporary file, and on file download completion moves to the+-- appropriate destination.+--+-- Throws an exception if things go wrong+download :: (MonadReader env m, HasHttpManager env, MonadIO m)+ => Request+ -> Path Abs File -- ^ destination+ -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?+download req destpath = do+ let downloadReq = DownloadRequest+ { drRequest = req+ , drHashChecks = []+ , drLengthCheck = Nothing+ }+ 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.+--+-- Returns 'True' if the file was downloaded, 'False' otherwise+redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)+ => Request+ -> Path Abs File -- ^ destination+ -> m Bool+redownload req0 dest = do+ let destFilePath = toFilePath dest+ etagFilePath = destFilePath <.> "etag"++ metag <- liftIO $ handleIO (const $ return Nothing) $ fmap Just $+ withBinaryFile etagFilePath ReadMode $ \h ->+ sourceHandle h $$ CB.take 512++ let req1 =+ case metag of+ Nothing -> req0+ Just etag -> req0+ { requestHeaders =+ requestHeaders req0 +++ [("If-None-Match", L.toStrict etag)]+ }+ req2 = req1 { checkStatus = \_ _ _ -> Nothing }+ env <- ask+ liftIO $ flip runReaderT env $ withResponse req2 $ \res -> case () of+ ()+ | responseStatus res == status200 -> liftIO $ do+ createDirectoryIfMissing True $ takeDirectory destFilePath++ -- Order here is important: first delete the etag, then write the+ -- file, then write the etag. That way, if any step fails, it will+ -- force the download to happen again.+ handleIO (const $ return ()) $ removeFile etagFilePath++ let destFilePathTmp = destFilePath <.> "tmp"+ withBinaryFile destFilePathTmp WriteMode $ \h ->+ responseBody res $$ sinkHandle h+ renameFile destFilePathTmp destFilePath++ forM_ (lookup "ETag" (responseHeaders res)) $ \e -> do+ let tmp = etagFilePath <.> "tmp"+ S.writeFile tmp e+ renameFile tmp etagFilePath++ return True+ | responseStatus res == status304 -> return False+ | otherwise -> throwM $ RedownloadFailed req2 dest $ fmap (const ()) res++-- | Download a JSON value and parse it using a 'FromJSON' instance.+downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadThrow m)+ => Request+ -> m a+downloadJSON req = do+ val <- liftHTTP $ withResponse req $ \res ->+ responseBody res $$ sinkParser json'+ case parseEither parseJSON val of+ Left e -> throwM $ DownloadJSONException req e+ Right x -> return x++data DownloadException+ = DownloadJSONException Request String+ | RedownloadFailed Request (Path Abs File) (Response ())+ deriving (Show, Typeable)+instance Exception DownloadException++-- | A convenience method for asking for the environment and then running an+-- action with its 'Manager'. Useful for avoiding a 'MonadBaseControl'+-- constraint.+liftHTTP :: (MonadIO m, MonadReader env m, HasHttpManager env)+ => ReaderT Manager IO a+ -> m a+liftHTTP inner = do+ env <- ask+ liftIO $ runReaderT inner $ getHttpManager env
+ src/Network/HTTP/Download/Verified.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+module Network.HTTP.Download.Verified+ ( verifiedDownload+ , DownloadRequest(..)+ , HashCheck(..)+ , LengthCheck+ , VerifiedDownloadException(..)+ ) where++import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BC+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Applicative+import Crypto.Hash+import Crypto.Hash.Conduit (sinkHash)+import Data.ByteString (ByteString)+import Data.Conduit+import Data.Conduit.Binary (sourceHandle, sinkHandle)+import Data.Foldable (traverse_)+import Data.Monoid+import Data.Typeable (Typeable)+import Network.HTTP.Client.Conduit+import Network.HTTP.Types.Header (hContentLength, hContentMD5)+import Path+import Prelude -- Fix AMP warning+import System.FilePath((<.>))+import System.Directory+import System.IO++-- | A request together with some checks to perform.+data DownloadRequest = DownloadRequest+ { drRequest :: Request+ , drHashChecks :: [HashCheck]+ , drLengthCheck :: Maybe LengthCheck+ }+ deriving Show++data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck+ { hashCheckAlgorithm :: a+ , hashCheckHexDigest :: String+ }+deriving instance Show HashCheck++type LengthCheck = Int++-- | An exception regarding verification of a download.+data VerifiedDownloadException+ = WrongContentLength+ Int -- expected+ ByteString -- actual (as listed in the header)+ | WrongStreamLength+ Int -- expected+ Int -- actual+ | WrongDigest+ String -- algorithm+ String -- expected+ String -- actual+ deriving (Show, Typeable)+instance Exception VerifiedDownloadException++data VerifyFileException+ = WrongFileSize+ Int -- expected+ Integer -- actual (as listed by hFileSize)+ deriving (Show, Typeable)+instance Exception VerifyFileException++-- | Make sure that the hash digest for a finite stream of bytes+-- is as expected.+--+-- Throws WrongDigest (VerifiedDownloadException)+sinkCheckHash :: MonadThrow m+ => HashCheck+ -> Consumer ByteString m ()+sinkCheckHash HashCheck{..} = do+ digest <- sinkHashUsing hashCheckAlgorithm+ let actualDigestString = show digest+ when (actualDigestString /= hashCheckHexDigest) $+ throwM $ WrongDigest (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString++assertLengthSink :: MonadThrow m+ => LengthCheck+ -> ZipSink ByteString m ()+assertLengthSink expectedStreamLength = ZipSink $ do+ Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length)+ when (actualStreamLength /= expectedStreamLength) $+ throwM $ WrongStreamLength expectedStreamLength actualStreamLength++-- | A more explicitly type-guided sinkHash.+sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a)+sinkHashUsing _ = sinkHash++-- | Turns a list of hash checks into a ZipSink that checks all of them.+hashChecksToZipSink :: MonadThrow m => [HashCheck] -> ZipSink ByteString m ()+hashChecksToZipSink = traverse_ (ZipSink . sinkCheckHash)++-- | Copied and extended version of Network.HTTP.Download.download.+--+-- Has the following additional features:+-- * Verifies that response content-length header (if present)+-- matches expected length+-- * Limits the download to (close to) the expected # of bytes+-- * Verifies that the expected # bytes were downloaded (not too few)+-- * Verifies md5 if response includes content-md5 header+-- * Verifies the expected hashes+--+-- Throws VerifiedDownloadException, and whatever else "download" throws.+verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)+ => DownloadRequest+ -> Path Abs File -- ^ destination+ -> Sink ByteString (ReaderT env IO) () -- ^ custom hook to observe progress+ -> m Bool -- ^ Whether a download was performed+verifiedDownload DownloadRequest{..} destpath progressSink = do+ let req = drRequest+ env <- ask+ liftIO $ whenM' getShouldDownload $ do+ createDirectoryIfMissing True dir+ withBinaryFile fptmp WriteMode $ \h ->+ flip runReaderT env $+ withResponse req (go h)+ renameFile fptmp fp+ where+ whenM' mp m = do+ p <- mp+ if p then m >> return True else return False++ fp = toFilePath destpath+ fptmp = fp <.> "tmp"+ dir = toFilePath $ parent destpath++ getShouldDownload = do+ fileExists <- doesFileExist fp+ if fileExists+ -- only download if file does not match expectations+ then not <$> fileMatchesExpectations+ -- or if it doesn't exist yet+ else return True++ -- precondition: file exists+ -- TODO: add logging+ fileMatchesExpectations =+ (checkExpectations >> return True)+ `catch` \(_ :: VerifyFileException) -> return False+ `catch` \(_ :: VerifiedDownloadException) -> return False++ whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+ whenJust (Just a) f = f a+ whenJust _ _ = return ()++ checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do+ whenJust drLengthCheck $ checkFileSizeExpectations h+ sourceHandle h $$ getZipSink (hashChecksToZipSink drHashChecks)++ -- doesn't move the handle+ checkFileSizeExpectations h expectedFileSize = do+ fileSizeInteger <- hFileSize h+ when (fileSizeInteger > toInteger (maxBound :: Int)) $+ throwM $ WrongFileSize expectedFileSize fileSizeInteger+ let fileSize = fromInteger fileSizeInteger+ when (fileSize /= expectedFileSize) $+ throwM $ WrongFileSize expectedFileSize fileSizeInteger++ checkContentLengthHeader headers expectedContentLength = do+ case List.lookup hContentLength headers of+ Just lengthBS -> do+ let lengthText = Text.strip $ Text.decodeUtf8 lengthBS+ lengthStr = Text.unpack lengthText+ when (lengthStr /= show expectedContentLength) $+ throwM $ WrongContentLength expectedContentLength lengthBS+ _ -> return ()++ go h res = do+ let headers = responseHeaders res+ 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+ }+ ]+ Nothing -> []+ ) ++ drHashChecks++ responseBody res+ $= maybe (awaitForever yield) CB.isolate drLengthCheck+ $$ getZipSink+ ( hashChecksToZipSink hashChecks+ *> maybe (pure ()) assertLengthSink drLengthCheck+ *> ZipSink (sinkHandle h)+ *> ZipSink progressSink)
+ src/Options/Applicative/Builder/Extra.hs view
@@ -0,0 +1,68 @@+-- | Extra functions for optparse-applicative.++module Options.Applicative.Builder.Extra+ (boolFlags+ ,maybeBoolFlags+ ,enableDisableFlags+ ,extraHelpOption+ ,execExtraHelp)+ where++import Control.Monad (when)+import Options.Applicative+import System.Environment (withArgs)+import System.FilePath (takeBaseName)++-- | Enable/disable flags for a @Bool@.+boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool+boolFlags defaultValue = enableDisableFlags defaultValue True False++-- | Enable/disable flags for a @(Maybe Bool)@.+maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool)+maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)++-- | Enable/disable flags for any type.+enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a+enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =+ flag' enabledValue+ (long name <>+ help ("Enable " ++ helpSuffix) <>+ mods) <|>+ flag' enabledValue+ (internal <>+ long ("enable-" ++ name) <>+ help ("Enable " ++ helpSuffix) <>+ mods) <|>+ flag' disabledValue+ (long ("no-" ++ name) <>+ help ("Disable " ++ helpSuffix) <>+ mods) <|>+ flag' disabledValue+ (internal <>+ long ("disable-" ++ name) <>+ help ("Disable " ++ helpSuffix) <>+ mods) <|>+ pure defaultValue++-- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).+-- To actually show have that help appear, use 'execExtraHelp' before executing the main parser.+extraHelpOption :: String -> String -> String -> Parser (a -> a)+extraHelpOption progName fakeName helpName =+ infoOption (optDesc ++ ".") (long helpName <> hidden <> internal) <*>+ infoOption (optDesc ++ ".") (long fakeName <> help optDesc)+ where optDesc = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"]++-- | Display extra help if extea help option passed in arguments.+-- Since optparse-applicative doesn't allow an arbirary IO action for an 'abortOption', this+-- was the best way I found that doesn't require manually formatting the help.+execExtraHelp :: [String] -> String -> Parser a -> String -> IO ()+execExtraHelp args helpOpt parser pd = do+ when (args == ["--" ++ helpOpt]) $+ withArgs ["--help"] $ do+ _ <- execParser (info (hiddenHelper <*>+ ((,) <$>+ parser <*>+ some (strArgument (metavar "OTHER ARGUMENTS"))))+ (fullDesc <> progDesc pd))+ return ()+ where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal)
+ src/Path/Find.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Finding files.++module Path.Find+ (findFileUp+ ,findDirUp+ ,findFiles)+ where++import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.List+import Path+import Path.IO++-- | Find the location of a file matching the given predicate.+findFileUp :: (MonadIO m,MonadThrow m)+ => Path Abs Dir -- ^ Start here.+ -> (Path Abs File -> Bool) -- ^ Predicate to match the file.+ -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.+ -> m (Maybe (Path Abs File)) -- ^ Absolute file path.+findFileUp s p d = findPathUp snd s p d++-- | Find the location of a directory matching the given predicate.+findDirUp :: (MonadIO m,MonadThrow m)+ => Path Abs Dir -- ^ Start here.+ -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory.+ -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.+ -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path.+findDirUp s p d = findPathUp fst s p d++-- | Find the location of a path matching the given predicate.+findPathUp :: (MonadIO m,MonadThrow m)+ => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t])+ -- ^ Choose path type from pair.+ -> Path Abs Dir -- ^ Start here.+ -> (Path Abs t -> Bool) -- ^ Predicate to match the path.+ -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.+ -> m (Maybe (Path Abs t)) -- ^ Absolute path.+findPathUp pathType dir p upperBound =+ do entries <- listDirectory dir+ case find p (pathType entries) of+ Just path -> return (Just path)+ Nothing ->+ if Just dir == upperBound+ then return Nothing+ else if parent dir == dir+ then return Nothing+ else findPathUp pathType+ (parent dir)+ p+ upperBound++-- | Find files matching predicate below a root directory.+findFiles :: Path Abs Dir -- ^ Root directory to begin with.+ -> (Path Abs File -> Bool) -- ^ Predicate to match files.+ -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse.+ -> IO [Path Abs File] -- ^ List of matching files.+findFiles dir p traversep =+ do (dirs,files) <- listDirectory dir+ subResults <-+ forM dirs+ (\entry ->+ if traversep entry+ then findFiles entry p traversep+ else return [])+ return (concat (filter p files : subResults))
+ src/Path/IO.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | IO actions that might be put in a package at some point.++module Path.IO+ (getWorkingDir+ ,listDirectory+ ,resolveDir+ ,resolveFile+ ,resolveDirMaybe+ ,resolveFileMaybe+ ,ResolveException(..)+ ,removeFileIfExists+ ,removeTree+ ,removeTreeIfExists)+ where++import Control.Exception hiding (catch)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Either+import Data.Maybe+import Data.Typeable+import Path+import System.Directory+import qualified System.FilePath as FP+import System.IO.Error++data ResolveException+ = ResolveDirFailed (Path Abs Dir) FilePath FilePath+ | ResolveFileFailed (Path Abs Dir) FilePath FilePath+ deriving Typeable+instance Exception ResolveException++instance Show ResolveException where+ show (ResolveDirFailed _ _ z) = "Could not resolve directory " ++ z+ show (ResolveFileFailed _ _ z) = "Could not resolve file " ++ z++-- | Get the current working directory.+getWorkingDir :: (MonadIO m) => m (Path Abs Dir)+getWorkingDir = liftIO (canonicalizePath "." >>= parseAbsDir)++-- | Appends a stringly-typed relative path to an absolute path, and then+-- canonicalizes it.+resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)+resolveDir x y =+ do result <- resolveDirMaybe x y+ case result of+ Nothing ->+ throwM $ ResolveDirFailed x y fp+ where fp = toFilePath x FP.</> y+ Just fp -> return fp++-- | Appends a stringly-typed relative path to an absolute path, and then+-- canonicalizes it.+resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs File)+resolveFile x y =+ do result <- resolveFileMaybe x y+ case result of+ Nothing ->+ throwM $+ ResolveFileFailed x y fp+ where fp = toFilePath x FP.</> y+ Just fp -> return fp++-- | Appends a stringly-typed relative path to an absolute path, and then+-- canonicalizes it. If the path doesn't exist (and therefore cannot+-- be canonicalized, 'Nothing' is returned).+resolveDirMaybe :: (MonadIO m,MonadThrow m)+ => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))+resolveDirMaybe x y = do+ let fp = toFilePath x FP.</> y+ exists <- liftIO $ doesDirectoryExist fp+ if exists+ then do+ dir <- liftIO $ canonicalizePath fp+ liftM Just (parseAbsDir dir)+ else return Nothing++-- | Appends a stringly-typed relative path to an absolute path, and then+-- canonicalizes it. If the path doesn't exist (and therefore cannot+-- be canonicalized, 'Nothing' is returned).+resolveFileMaybe :: (MonadIO m,MonadThrow m)+ => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))+resolveFileMaybe x y = do+ let fp = toFilePath x FP.</> y+ exists <- liftIO $ doesFileExist fp+ if exists+ then do+ file <- liftIO $ canonicalizePath fp+ liftM Just (parseAbsFile file)+ else return Nothing++-- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted.+listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])+listDirectory dir =+ do entriesFP <- liftIO (getDirectoryContents dirFP)+ maybeEntries <-+ forM (map (dirFP ++) entriesFP)+ (\entryFP ->+ do isDir <- liftIO (doesDirectoryExist entryFP)+ if isDir+ then case parseAbsDir entryFP of+ Nothing -> return Nothing+ Just entryDir ->+ if dir `isParentOf` entryDir+ then return (Just (Left entryDir))+ else return Nothing+ else case parseAbsFile entryFP of+ Nothing -> return Nothing+ Just entryFile -> return (Just (Right entryFile)))+ let entries = catMaybes maybeEntries+ return (lefts entries,rights entries)+ where dirFP = toFilePath dir++-- | Remove the given file. Optimistically assumes it exists. If it+-- doesn't, doesn't complain.+removeFileIfExists :: MonadIO m => Path b File -> m ()+removeFileIfExists fp =+ liftIO (catch+ (removeFile+ (toFilePath fp))+ (\e ->+ if isDoesNotExistError e+ then return ()+ else throwIO e))++-- | Remove the given tree. Bails out if the directory doesn't exist.+removeTree :: MonadIO m => Path b Dir -> m ()+removeTree =+ liftIO . removeDirectoryRecursive . toFilePath++-- | Remove tree, don't complain about non-existent directories.+removeTreeIfExists :: MonadIO m => Path b Dir -> m ()+removeTreeIfExists fp = do+ liftIO (catch (removeTree fp)+ (\e -> if isDoesNotExistError e+ then return ()+ else throwIO e))
+ src/Stack/Build.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-- | Build project(s).++module Stack.Build+ (build+ ,clean)+ where++import Control.Monad+import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource+import Data.Either+import Data.Function+import Data.Map.Strict (Map)+import qualified Data.Set as S+import Network.HTTP.Client.Conduit (HasHttpManager)+import Path.IO+import Prelude hiding (FilePath, writeFile)+import Stack.Build.ConstructPlan+import Stack.Build.Execute+import Stack.Build.Installed+import Stack.Build.Source+import Stack.Build.Types+import Stack.Constants+import Stack.Fetch as Fetch+import Stack.GhcPkg+import Stack.Package+import Stack.Types+import Stack.Types.Internal++{- EKB TODO: doc generation for stack-doc-server+#ifndef mingw32_HOST_OS+import System.Posix.Files (createSymbolicLink,removeLink)+#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)++-- | Build+build :: M env m => BuildOpts -> m ()+build bopts = do+ menv <- getMinimalEnvOverride+ cabalPkgVer <- getCabalPkgVer menv++ (mbp, locals, 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+ where+ profiling = boptsLibProfile bopts || boptsExeProfile bopts++-- | Get the @BaseConfigOpts@ necessary for constructing configure options+mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m)+ => BuildOpts -> m BaseConfigOpts+mkBaseConfigOpts bopts = do+ snapDBPath <- packageDatabaseDeps+ localDBPath <- packageDatabaseLocal+ snapInstallRoot <- installationRootDeps+ localInstallRoot <- installationRootLocal+ return BaseConfigOpts+ { bcoSnapDB = snapDBPath+ , bcoLocalDB = localDBPath+ , bcoSnapInstallRoot = snapInstallRoot+ , bcoLocalInstallRoot = localInstallRoot+ , bcoBuildOpts = bopts+ }++-- | Provide a function for loading package information from the package index+withLoadPackage :: M env m+ => EnvOverride+ -> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)+ -> m a+withLoadPackage menv inner = do+ bconfig <- asks getBuildConfig+ withCabalLoader menv $ \cabalLoader ->+ inner $ \name version flags -> do+ bs <- cabalLoader $ PackageIdentifier name version -- TODO automatically update index the first time this fails+ readPackageBS (depPackageConfig bconfig flags) bs+ where+ -- | Package config to be used for dependencies+ depPackageConfig :: BuildConfig -> Map FlagName Bool -> PackageConfig+ depPackageConfig bconfig flags = PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False+ , packageConfigFlags = flags+ , packageConfigGhcVersion = bcGhcVersion bconfig+ , packageConfigPlatform = configPlatform (getConfig bconfig)+ }++-- | Reset the build (remove Shake database and .gen files).+clean :: (M env m) => m ()+clean = do+ bconfig <- asks getBuildConfig+ menv <- getMinimalEnvOverride+ cabalPkgVer <- getCabalPkgVer menv+ forM_+ (S.toList (bcPackages bconfig))+ (distDirFromDir cabalPkgVer >=> removeTreeIfExists)++----------------------------------------------------------+-- DEAD CODE BELOW HERE+----------------------------------------------------------++{- EKB TODO: doc generation for stack-doc-server+ (boptsFinalAction bopts == DoHaddock)+ (buildDocIndex+ (wanted pwd)+ docLoc+ packages+ mgr+ logLevel)+ -}++{- EKB TODO: doc generation for stack-doc-server+-- | Build the haddock documentation index and contents.+buildDocIndex :: (Package -> Wanted)+ -> Path Abs Dir+ -> Set Package+ -> Manager+ -> LogLevel+ -> Rules ()+buildDocIndex wanted docLoc packages mgr logLevel =+ do runHaddock "--gen-contents" $(mkRelFile "index.html")+ runHaddock "--gen-index" $(mkRelFile "doc-index.html")+ combineHoogle+ where+ runWithLogging = runStackLoggingT mgr logLevel+ runHaddock genOpt destFilename =+ do let destPath = toFilePath (docLoc </> destFilename)+ want [destPath]+ destPath %> \_ ->+ runWithLogging+ (do needDeps+ ifcOpts <- liftIO (fmap concat (mapM toInterfaceOpt (S.toList packages)))+ runIn docLoc+ "haddock"+ mempty+ (genOpt:ifcOpts)+ Nothing)+ toInterfaceOpt package =+ do let pv = joinPkgVer (packageName package,packageVersion package)+ srcPath = (toFilePath docLoc) ++ "/" +++ pv ++ "/" +++ packageNameString (packageName package) ++ "." +++ haddockExtension+ exists <- doesFileExist srcPath+ return (if exists+ then ["-i"+ ,"../" +++ pv +++ "," +++ srcPath]+ else [])+ combineHoogle =+ do let destHoogleDbLoc = hoogleDatabaseFile docLoc+ destPath = toFilePath destHoogleDbLoc+ want [destPath]+ destPath %> \_ ->+ runWithLogging+ (do needDeps+ srcHoogleDbs <- liftIO (fmap concat (mapM toSrcHoogleDb (S.toList packages)))+ callProcess+ "hoogle"+ ("combine" :+ "-o" :+ toFilePath destHoogleDbLoc :+ srcHoogleDbs))+ toSrcHoogleDb package =+ do let srcPath = toFilePath docLoc ++ "/" +++ joinPkgVer (packageName package,packageVersion package) ++ "/" +++ packageNameString (packageName package) ++ "." +++ hoogleDbExtension+ exists <- doesFileExist srcPath+ return (if exists+ then [srcPath]+ else [])+ needDeps =+ need (concatMap (\package -> if wanted package == Wanted+ then let dir = packageDir package+ in [toFilePath (builtFileFromDir dir)]+ else [])+ (S.toList packages))++#ifndef mingw32_HOST_OS+-- | Remove existing links docs for package from @~/.shake/doc@.+removeDocLinks :: Path Abs Dir -> Package -> IO ()+removeDocLinks docLoc package =+ do createDirectoryIfMissing True+ (toFilePath docLoc)+ userDocLs <-+ fmap (map (toFilePath docLoc ++))+ (getDirectoryContents (toFilePath docLoc))+ forM_ userDocLs $+ \docPath ->+ do isDir <- doesDirectoryExist docPath+ when isDir+ (case breakPkgVer (FilePath.takeFileName docPath) of+ Just (p,_) ->+ when (p == packageName package)+ (removeLink docPath)+ Nothing -> return ())++-- | Add link for package to @~/.shake/doc@.+createDocLinks :: Path Abs Dir -> Package -> IO ()+createDocLinks docLoc package =+ do let pkgVer =+ joinPkgVer (packageName package,(packageVersion package))+ pkgVerLoc <- liftIO (parseRelDir pkgVer)+ let pkgDestDocLoc = docLoc </> pkgVerLoc+ pkgDestDocPath =+ FilePath.dropTrailingPathSeparator (toFilePath pkgDestDocLoc)+ cabalDocLoc = parent docLoc </>+ $(mkRelDir "share/doc/")+ haddockLocs <-+ do cabalDocExists <- doesDirectoryExist (toFilePath cabalDocLoc)+ if cabalDocExists+ then findFiles cabalDocLoc+ (\fileLoc ->+ FilePath.takeExtensions (toFilePath fileLoc) ==+ "." ++ haddockExtension &&+ dirname (parent fileLoc) ==+ $(mkRelDir "html/") &&+ toFilePath (dirname (parent (parent fileLoc))) ==+ (pkgVer ++ "/"))+ (\dirLoc ->+ not (isHiddenDir dirLoc) &&+ dirname (parent (parent dirLoc)) /=+ $(mkRelDir "html/"))+ else return []+ case haddockLocs of+ [haddockLoc] ->+ case stripDir (parent docLoc)+ haddockLoc of+ Just relHaddockPath ->+ do let srcRelPathCollapsed =+ FilePath.takeDirectory (FilePath.dropTrailingPathSeparator (toFilePath relHaddockPath))+ {-srcRelPath = "../" ++ srcRelPathCollapsed-}+ createSymbolicLink (FilePath.dropTrailingPathSeparator srcRelPathCollapsed)+ pkgDestDocPath+ Nothing -> return ()+ _ -> return ()+#endif /* not defined(mingw32_HOST_OS) */++-- | Get @-i@ arguments for haddock for dependencies.+haddockInterfaceOpts :: Path Abs Dir -> Package -> Set Package -> IO [String]+haddockInterfaceOpts userDocLoc package packages =+ do mglobalDocLoc <- getGlobalDocPath+ globalPkgVers <-+ case mglobalDocLoc of+ Nothing -> return M.empty+ Just globalDocLoc -> getDocPackages globalDocLoc+ let toInterfaceOpt pn =+ case find (\dpi -> packageName dpi == pn) (S.toList packages) of+ Nothing ->+ return (case (M.lookup pn globalPkgVers,mglobalDocLoc) of+ (Just (v:_),Just globalDocLoc) ->+ ["-i"+ ,"../" ++ joinPkgVer (pn,v) +++ "," +++ toFilePath globalDocLoc ++ "/" +++ joinPkgVer (pn,v) ++ "/" +++ packageNameString pn ++ "." +++ haddockExtension]+ _ -> [])+ Just dpi ->+ do let destPath = (toFilePath userDocLoc ++ "/" +++ joinPkgVer (pn,packageVersion dpi) ++ "/" +++ packageNameString pn ++ "." +++ haddockExtension)+ exists <- doesFileExist destPath+ return (if exists+ then ["-i"+ ,"../" +++ joinPkgVer (pn,packageVersion dpi) +++ "," +++ destPath]+ else [])+ --TODO: use not only direct dependencies, but dependencies of dependencies etc.+ --(e.g. redis-fp doesn't include @text@ in its dependencies which means the 'Text'+ --datatype isn't linked in its haddocks)+ fmap concat (mapM toInterfaceOpt (S.toList (packageAllDeps package)))++--------------------------------------------------------------------------------+-- Paths++{- EKB TODO: doc generation for stack-doc-server+-- | Returns true for paths whose last directory component begins with ".".+isHiddenDir :: Path b Dir -> Bool+isHiddenDir = isPrefixOf "." . toFilePath . dirname+ -}+--}
+ src/Stack/Build/Cache.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+-- | Cache information about previous builds+module Stack.Build.Cache+ ( tryGetBuildCache+ , tryGetConfigCache+ , getPackageFileModTimes+ , getInstalledExes+ , buildCacheTimes+ , tryGetFlagCache+ , deleteCaches+ , markExeInstalled+ , writeFlagCache+ , writeBuildCache+ , writeConfigCache+ ) 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 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)++-- | Directory containing files to mark an executable as installed+exeInstalledDir :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => Location -> m (Path Abs Dir)+exeInstalledDir Snap = (</> $(mkRelDir "installed-packages")) `liftM` installationRootDeps+exeInstalledDir Local = (</> $(mkRelDir "installed-packages")) `liftM` installationRootLocal++-- | Get all of the installed executables+getInstalledExes :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadThrow m)+ => Location -> m [PackageIdentifier]+getInstalledExes loc = do+ dir <- exeInstalledDir loc+ files <- liftIO $ handleIO (const $ return []) $ getDirectoryContents $ toFilePath dir+ return $ mapMaybe parsePackageIdentifierFromString files++-- | Mark the given executable as installed+markExeInstalled :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadThrow m)+ => Location -> PackageIdentifier -> m ()+markExeInstalled loc ident = do+ dir <- exeInstalledDir loc+ liftIO $ createDirectoryIfMissing True $ toFilePath dir+ ident' <- parseRelFile $ packageIdentifierString ident+ let fp = toFilePath $ dir </> ident'+ -- TODO consideration for the future: list all of the executables+ -- installed, and invalidate this file in getInstalledExes if they no+ -- longer exist+ liftIO $ writeFile fp "Installed"++-- | Stored on disk to know whether the flags have changed or any+-- files have changed.+data BuildCache = BuildCache+ { buildCacheTimes :: !(Map FilePath ModTime)+ -- ^ Modification times of files.+ }+ 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)+ => 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)+ => Path Abs Dir -> m (Maybe ConfigCache)+tryGetConfigCache = tryGetCache configCacheFile++-- | 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))+ -> Path Abs Dir+ -> m (Maybe a)+tryGetCache get' dir = do+ menv <- getMinimalEnvOverride+ cabalPkgVer <- getCabalPkgVer menv+ fp <- get' cabalPkgVer dir+ liftIO+ (catch+ (fmap (decodeMaybe . L.fromStrict) (S.readFile (toFilePath fp)))+ (\e -> if isDoesNotExistError e+ then return Nothing+ else throwM e))+ where decodeMaybe =+ either (const Nothing) (Just . thd) . Binary.decodeOrFail+ 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)+ => Path Abs Dir -> Map FilePath ModTime -> m ()+writeBuildCache dir times =+ writeCache+ dir+ buildCacheFile+ (BuildCache+ { buildCacheTimes = times+ })++-- | Write the dirtiness cache for this package's configuration.+writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+ => Path Abs Dir+ -> [Text]+ -> Set GhcPkgId -- ^ dependencies+ -> m ()+writeConfigCache dir opts deps =+ writeCache+ dir+ configCacheFile+ (ConfigCache+ { configCacheOpts = map encodeUtf8 opts+ , configCacheDeps = deps+ })++-- | Delete the caches for the project.+deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m)+ => Path Abs Dir -> m ()+deleteCaches dir = do+ menv <- getMinimalEnvOverride+ cabalPkgVer <- getCabalPkgVer menv+ bfp <- buildCacheFile cabalPkgVer dir+ removeFileIfExists bfp+ cfp <- configCacheFile cabalPkgVer dir+ removeFileIfExists cfp++-- | Write to a cache.+writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)+ => Path Abs Dir+ -> (PackageIdentifier -> Path Abs Dir -> m (Path Abs File))+ -> a+ -> m ()+writeCache dir get' content = do+ menv <- getMinimalEnvOverride+ cabalPkgVer <- getCabalPkgVer menv+ fp <- get' cabalPkgVer dir+ liftIO+ (L.writeFile+ (toFilePath fp)+ (Binary.encode content))++flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasBuildConfig env)+ => GhcPkgId+ -> m (Path Abs File)+flagCacheFile gid = do+ rel <- parseRelFile $ ghcPkgIdString gid+ 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+ -> m (Maybe ConfigCache)+tryGetFlagCache gid = do+ file <- flagCacheFile gid+ eres <- liftIO $ tryIO $ Binary.decodeFileOrFail $ toFilePath file+ case eres of+ Right (Right x) -> return $ Just x+ _ -> return Nothing++writeFlagCache :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m)+ => GhcPkgId+ -> [ByteString]+ -> Set GhcPkgId+ -> m ()+writeFlagCache gid flags deps = do+ file <- flagCacheFile gid+ liftIO $ do+ createDirectoryIfMissing True $ toFilePath $ parent file+ Binary.encodeFile (toFilePath file) ConfigCache+ { configCacheOpts = flags+ , configCacheDeps = deps+ }++-- | Get the modified times of all known files in the package,+-- including the package's cabal file itself.+getPackageFileModTimes :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+ => Package+ -> Path Abs File -- ^ cabal file+ -> m (Map FilePath ModTime)+getPackageFileModTimes pkg cabalfp = do+ files <- getPackageFiles (packageFiles pkg) cabalfp+ liftM (Map.fromList . catMaybes)+ $ mapM getModTimeMaybe+ $ Set.toList files+ where+ getModTimeMaybe fp =+ liftIO+ (catch+ (liftM+ (Just . (toFilePath fp,) . modTime)+ (getModificationTime (toFilePath fp)))+ (\e ->+ if isDoesNotExistError e+ then return Nothing+ else throwM e))
+ src/Stack/Build/ConstructPlan.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+-- | Construct a @Plan@ for how to build+module Stack.Build.ConstructPlan+ ( constructPlan+ ) where++import Control.Exception.Lifted+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.RWS.Strict+import Control.Monad.Trans.Resource+import qualified Data.ByteString.Char8 as S8+import Data.Either+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text.Encoding (encodeUtf8)+import Distribution.Package (Dependency (..))+import Distribution.Version (anyVersion,+ intersectVersionRanges)+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++data PackageInfo+ = PIOnlyInstalled Version Location Installed+ | PIOnlySource PackageSource+ | PIBoth PackageSource Installed++combineSourceInstalled :: PackageSource+ -> (Version, Location, Installed)+ -> PackageInfo+combineSourceInstalled ps (version, location, installed) =+ assert (piiVersion ps == version) $+ assert (piiLocation ps == location) $+ case location of+ -- Always trust something in the snapshot+ Snap -> PIOnlyInstalled version location installed+ Local -> PIBoth ps installed++type CombinedMap = Map PackageName PackageInfo++combineMap :: SourceMap -> InstalledMap -> CombinedMap+combineMap = Map.mergeWithKey+ (\_ s i -> Just $ combineSourceInstalled s i)+ (fmap PIOnlySource)+ (fmap (\(v, l, i) -> PIOnlyInstalled v l i))++data AddDepRes+ = ADRToInstall Task+ | ADRFound Version Installed+ deriving Show++type M = RWST+ Ctx+ (Map PackageName Task) -- JustFinal+ (Map PackageName (Either ConstructPlanException AddDepRes))+ IO++data Ctx = Ctx+ { mbp :: !MiniBuildPlan+ , baseConfigOpts :: !BaseConfigOpts+ , loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)+ , combinedMap :: !CombinedMap+ , toolToPackages :: !(Dependency -> Map PackageName VersionRange)+ , ctxBuildConfig :: !BuildConfig+ , callStack :: ![PackageName]+ }++instance HasStackRoot Ctx+instance HasPlatform Ctx+instance HasConfig Ctx+instance HasBuildConfig Ctx where+ getBuildConfig = ctxBuildConfig++constructPlan :: forall env m.+ (MonadThrow m, MonadReader env m, HasBuildConfig env, MonadIO m)+ => MiniBuildPlan+ -> BaseConfigOpts+ -> [LocalPackage]+ -> [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+ bconfig <- asks getBuildConfig+ let inner = mapM_ addDep $ Set.toList allTargets+ ((), m, justFinals) <- 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+ let toTask (_, ADRFound _ _) = Nothing+ toTask (name, ADRToInstall task) = Just (name, task)+ tasks = M.fromList $ mapMaybe toTask adrs+ return Plan+ { planTasks = Map.union tasks justFinals+ , planUnregisterLocal = mkUnregisterLocal tasks locallyRegistered+ }+ (errs, _) -> 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+ , ctxBuildConfig = bconfig+ , callStack = []+ }+ toolMap = getToolMap mbp0++-- | Determine which packages to unregister based on the given tasks and+-- already registered local packages+mkUnregisterLocal :: Map PackageName Task -> Set GhcPkgId -> Set GhcPkgId+mkUnregisterLocal tasks locallyRegistered =+ Set.filter toUnregister locallyRegistered+ where+ toUnregister gid =+ case M.lookup name tasks of+ Nothing -> False+ Just task ->+ case taskType task of+ TTLocal _ JustFinal -> False+ _ -> True+ where+ ident = ghcPkgIdPackageIdentifier gid+ name = packageIdentifierName ident++addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)+addDep name = do+ m <- get+ case Map.lookup name m of+ Just res -> return res+ Nothing -> do+ res <- addDep' name+ modify $ Map.insert name res+ return res++addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)+addDep' name = do+ ctx <- ask+ if name `elem` callStack ctx+ then return $ Left $ DependencyCycleDetected $ name : callStack ctx+ else local+ (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do+ (addDep'' name)++addDep'' :: PackageName -> M (Either ConstructPlanException AddDepRes)+addDep'' name = do+ ctx <- ask+ case Map.lookup name $ combinedMap ctx of+ -- TODO look up in the package index and see if there's a+ -- recommendation available+ Nothing -> return $ Left $ UnknownPackage name+ Just (PIOnlyInstalled version _ installed) ->+ return $ Right $ ADRFound version installed+ Just (PIOnlySource ps) -> installPackage Nothing 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++-- 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+ ctx <- ask+ package <- psPackage name ps+ depsRes <- addPackageDeps package+ case depsRes of+ Left e -> return $ Left e+ Right (missing, present) -> do+ return $ Right $ ADRToInstall Task+ { taskProvides = PackageIdentifier+ (packageName package)+ (packageVersion package)+ , taskConfigOpts = TaskConfigOpts missing $ \missing' ->+ let allDeps = Set.union present missing'+ in configureOpts+ (baseConfigOpts ctx)+ allDeps+ (psWanted ps)+ (piiLocation ps)+ (packageFlags package)+ , taskPresent = present+ , 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+ package <- psPackage name ps+ depsRes <- addPackageDeps package+ case depsRes of+ Left _e -> return $ Just AllSteps -- installPackage will find the error again+ Right (missing, present)+ | Set.null missing -> checkDirtiness ps installed package present+ | otherwise -> return $ Just AllSteps++addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId))+addPackageDeps package = do+ deps' <- packageDepsWithTools package+ deps <- forM (Map.toList deps') $ \(depname, range) -> do+ eres <- addDep depname+ case eres of+ Left e ->+ let bd =+ case e of+ UnknownPackage _ -> NotInBuildPlan+ _ -> Couldn'tResolveItsDependencies+ in return $ Left (depname, (range, bd))+ Right adr | not $ adrVersion adr `withinRange` range ->+ return $ Left (depname, (range, DependencyMismatch $ adrVersion adr))+ Right (ADRToInstall task) -> return $ Right+ (Set.singleton $ taskProvides task, Set.empty)+ 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)+ where+ adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task+ adrVersion (ADRFound v _) = v++checkDirtiness :: PackageSource+ -> Installed+ -> Package+ -> Set GhcPkgId+ -> M (Maybe NeededSteps)+checkDirtiness _ Executable _ _ = return Nothing -- TODO reinstall executables in the future+checkDirtiness ps (Library installed) package present = do+ ctx <- ask+ let configOpts = configureOpts+ (baseConfigOpts ctx)+ present+ (psWanted ps)+ (piiLocation ps) -- should be Local always+ (packageFlags package)+ configCache = ConfigCache+ { configCacheOpts = map encodeUtf8 configOpts+ , configCacheDeps = present+ }+ moldOpts <- psOldOpts ps 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++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+psWanted (PSUpstream _ _ _) = False++psPackage :: PackageName -> PackageSource -> M Package+psPackage _ (PSLocal lp) = return $ lpPackage lp+psPackage name (PSUpstream version _ flags) = do+ ctx <- ask+ liftIO $ loadPackage ctx name version flags++-- | Get all of the dependencies for a given package, including guessed build+-- tool dependencies.+packageDepsWithTools :: Package -> M (Map PackageName VersionRange)+packageDepsWithTools p = do+ ctx <- ask+ return $ Map.unionsWith intersectVersionRanges+ $ packageDeps p+ : map (toolToPackages ctx) (packageTools p)
+ src/Stack/Build/Doc.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Utilities for built documentation, shared between @stack@ and @stack-doc-server@.+module Stack.Build.Doc where++import Control.Monad+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Text as T+import Path+import Stack.Types+import Stack.Constants+import System.Directory+import System.Environment (lookupEnv)+import System.FilePath (takeFileName)++-- | Get all packages included in documentation from directory.+getDocPackages :: Path Abs Dir -> IO (Map PackageName [Version])+getDocPackages loc =+ do ls <- fmap (map (toFilePath loc ++)) (getDirectoryContents (toFilePath loc))+ mdirs <- forM ls (\e -> do isDir <- doesDirectoryExist e+ return $ if isDir then (Just e) else Nothing)+ let sorted = -- Sort by package name ascending, version descending+ sortBy (\(pa,va) (pb,vb) ->+ case compare pa pb of+ EQ -> compare vb va+ o -> o)+ (mapMaybe breakPkgVer (catMaybes mdirs))+ return (M.fromAscListWith (++) (map (\(k,v) -> (k,[v])) sorted))++-- | Split a documentation directory name into package name and version.+breakPkgVer :: FilePath -> Maybe (PackageName,Version)+breakPkgVer pkgPath =+ case T.breakOnEnd "-"+ (T.pack (takeFileName pkgPath)) of+ ("",_) -> Nothing+ (pkgD,verT) ->+ let pkgstr = T.dropEnd 1 pkgD+ in case parseVersionFromString (T.unpack verT) of+ Just v+ | Just pkg <-+ parsePackageNameFromString (T.unpack pkgstr) ->+ Just (pkg,v)+ _ -> Nothing++-- | Construct a documentation directory name from package name and version.+joinPkgVer :: (PackageName,Version) -> FilePath+joinPkgVer (pkg,ver) = (packageNameString pkg ++ "-" ++ versionString ver)++--EKB TODO: doc generation for stack-doc-server+-- | Get location of user-generated documentation if it exists.+getExistingUserDocPath :: Config -> IO (Maybe (Path Abs Dir))+getExistingUserDocPath config = do+ let docPath = userDocsDir config+ docExists <- doesDirectoryExist (toFilePath docPath)+ if docExists+ then return (Just docPath)+ else return Nothing++--EKB TODO: doc generation for stack-doc-server+-- | Get location of global package docs.+getGlobalDocPath :: IO (Maybe (Path Abs Dir))+getGlobalDocPath = do+ --EKB TODO: move this location into Config+ maybeRootEnv <- lookupEnv "STACK_DOC_ROOT"+ case maybeRootEnv of+ Nothing -> return Nothing+ Just rootEnv -> do+ pkgDocPath <- parseAbsDir rootEnv+ pkgDocExists <- doesDirectoryExist (toFilePath pkgDocPath)+ return (if pkgDocExists then Just pkgDocPath else Nothing)++--EKB TODO: doc generation for stack-doc-server+-- | Get location of GHC docs.+getGhcDocPath :: IO (Maybe (Path Abs Dir))+getGhcDocPath = do+ maybeGhcPathS <- findExecutable "ghc"+ case maybeGhcPathS of+ Nothing -> return Nothing+ Just ghcPathS -> do+ ghcPath <- parseAbsFile ghcPathS+ let ghcDocPath = parent (parent ghcPath) </> $(mkRelDir "share/doc/ghc/html/")+ ghcDocExists <- doesDirectoryExist (toFilePath ghcDocPath)+ return (if ghcDocExists then Just ghcDocPath else Nothing)
+ src/Stack/Build/Execute.hs view
@@ -0,0 +1,524 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+-- Perform a build+module Stack.Build.Execute+ ( printPlan+ , executePlan+ ) where++import Control.Concurrent (forkIO, getNumCapabilities)+import Control.Concurrent.Execute+import Control.Concurrent.MVar.Lifted+import Control.Concurrent.STM+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Control (liftBaseWith)+import Control.Monad.Trans.Resource+import Control.Monad.Writer+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import qualified Data.Map.Strict as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.Streaming.Process hiding (callProcess, env)+import qualified Data.Streaming.Process as Process+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Distribution.System (OS (Windows),+ Platform (Platform))+import Network.HTTP.Client.Conduit (HasHttpManager)+import Path+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.Types+import Stack.Types.Internal+import System.Directory hiding (findExecutable,+ findFiles)+import System.Exit (ExitCode (ExitSuccess))+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)++printPlan :: M env m => Plan -> m ()+printPlan plan = do+ case Set.toList $ planUnregisterLocal plan of+ [] -> $logInfo "Nothing to unregister"+ xs -> do+ $logInfo "Would unregister locally:"+ mapM_ ($logInfo . T.pack . ghcPkgIdString) xs++ $logInfo ""++ case Map.elems $ planTasks plan of+ [] -> $logInfo "Nothing to build"+ xs -> do+ $logInfo "Would build:"+ mapM_ ($logInfo . displayTask) xs++-- | For a dry run+displayTask :: Task -> Text+displayTask task = T.pack $ concat+ [ packageIdentifierString $ taskProvides task+ , ": database="+ , case taskLocation task of+ Snap -> "snapshot"+ Local -> "local"+ , ", source="+ , case taskType task of+ TTLocal lp steps -> concat+ [ toFilePath $ lpDir lp+ , case steps of+ AllSteps -> " (configure)"+ SkipConfig -> " (build)"+ JustFinal -> " (already built)"+ ]+ TTUpstream _ _ -> "package index"+ , if Set.null missing+ then ""+ else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)+ ]+ where+ missing = tcoMissing $ taskConfigOpts task++data ExecuteEnv = ExecuteEnv+ { eeEnvOverride :: !EnvOverride+ , eeConfigureLock :: !(MVar ())+ , eeInstallLock :: !(MVar ())+ , eeBuildOpts :: !BuildOpts+ , eeBaseConfigOpts :: !BaseConfigOpts+ , eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed))+ , eeTempDir :: !(Path Abs Dir)+ , eeSetupHs :: !(Path Abs File)+ , eeCabalPkgVer :: !PackageIdentifier+ , eeTotalWanted :: !Int+ }++-- | Perform the actual plan+executePlan :: M env m+ => EnvOverride+ -> BuildOpts+ -> BaseConfigOpts+ -> PackageIdentifier -- ^ cabal version+ -> [LocalPackage]+ -> Plan+ -> m ()+executePlan menv bopts baseConfigOpts cabalPkgVer locals plan =+ withSystemTempDirectory stackProgName $ \tmpdir -> do+ tmpdir' <- parseAbsDir tmpdir+ configLock <- newMVar ()+ installLock <- newMVar ()+ idMap <- liftIO $ newTVarIO M.empty+ let setupHs = tmpdir' </> $(mkRelFile "Setup.hs")+ liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"+ executePlan' plan ExecuteEnv+ { eeEnvOverride = menv+ , eeBuildOpts = bopts+ -- Uncertain as to why we cannot run configures in parallel. This appears+ -- to be a Cabal library bug. Original issue:+ -- https://github.com/fpco/stack/issues/84. Ideally we'd be able to remove+ -- this.+ , eeConfigureLock = configLock+ , eeInstallLock = installLock+ , eeBaseConfigOpts = baseConfigOpts+ , eeGhcPkgIds = idMap+ , eeTempDir = tmpdir'+ , eeSetupHs = setupHs+ , eeCabalPkgVer = cabalPkgVer+ , eeTotalWanted = length $ filter lpWanted locals+ }++-- | Perform the actual plan (internal)+executePlan' :: M env m+ => Plan+ -> ExecuteEnv+ -> m ()+executePlan' plan ee = do+ case Set.toList $ planUnregisterLocal plan of+ [] -> return ()+ ids -> do+ localDB <- packageDatabaseLocal+ forM_ ids $ \id' -> do+ $logInfo $ T.concat+ [ T.pack $ ghcPkgIdString id'+ , ": unregistering"+ ]+ unregisterGhcPkgId (eeEnvOverride ee) localDB id'++ -- Yes, we're explicitly discarding result values, which in general would+ -- be bad. monad-unlift does this all properly at the type system level,+ -- but I don't want to pull it in for this one use case, when we know that+ -- stack always using transformer stacks that are safe for this use case.+ runInBase <- liftBaseWith $ \run -> return (void . run)++ let actions = concatMap (toActions runInBase ee) $ Map.elems $ planTasks plan+ threads <- liftIO getNumCapabilities -- TODO make a build opt to override this+ errs <- liftIO $ runActions threads actions+ unless (null errs) $ throwM $ ExecutionFailure errs++toActions :: M env m+ => (m () -> IO ())+ -> ExecuteEnv+ -> Task+ -> [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++ [ Action+ { actionId = ActionId taskProvides ATBuild+ , actionDeps =+ (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))+ , actionDo = \ac -> runInBase $ singleBuild ac ee task+ }+ ]++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++ fileModTimes <- getPackageFileModTimes package cabalfp+ writeBuildCache pkgDir fileModTimes++ unless justFinal $ do+ announce "build"+ config <- asks getConfig+ cabal (console && configHideTHLoading config) ["build"]++ 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++-- | 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 ()++ unless justFinal $ withMVar eeInstallLock $ \_ -> do+ announce "install"+ cabal False ["install"]++ -- 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'+ where+ announce x = $logInfo $ T.concat+ [ T.pack $ packageIdentifierString taskProvides+ , ": "+ , 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+ TTUpstream _ _ -> False++ console = wanted && acRemaining == 0 && eeTotalWanted == 1++ withPackage inner =+ case taskType of+ TTLocal lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)+ TTUpstream package _ -> do+ mdist <- liftM Just $ distRelativeDir eeCabalPkgVer+ m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides+ case M.toList m of+ [(ident, dir)]+ | ident == taskProvides -> do+ let name = packageIdentifierName taskProvides+ cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"+ let cabalfp = dir </> cabalfpRel+ inner package cabalfp dir+ _ -> error $ "withPackage: invariant violated: " ++ show m++ withLogFile package inner+ | console = inner Nothing+ | otherwise = do+ logPath <- buildLogPath package+ liftIO $ createDirectoryIfMissing True $ toFilePath $ parent logPath+ let fp = toFilePath logPath+ bracket+ (liftIO $ openBinaryFile fp WriteMode)+ (liftIO . hClose)+ $ \h -> inner (Just (logPath, h))++ withCabal pkgDir mlogFile inner = do+ config <- asks getConfig+ menv <- liftIO $ configEnvOverride config EnvSettings+ { esIncludeLocals = taskLocation task == Local+ , esIncludeGhcPackagePath = False+ }+ exeName <- liftIO $ join $ findExecutable menv "runhaskell"+ distRelativeDir' <- distRelativeDir eeCabalPkgVer+ msetuphs <- liftIO $ getSetupHs pkgDir+ let setuphs = fromMaybe eeSetupHs msetuphs+ inner $ \stripTHLoading args -> do+ let fullArgs =+ ("-package=" ++ packageIdentifierString eeCabalPkgVer)+ : "-clear-package-db"+ : "-global-package-db"+ -- TODO: Perhaps we want to include the snapshot package database here+ -- as well+ : toFilePath setuphs+ : ("--builddir=" ++ toFilePath distRelativeDir')+ : args+ cp0 = proc (toFilePath exeName) fullArgs+ cp = cp0+ { cwd = Just $ toFilePath pkgDir+ , Process.env = envHelper menv+ , std_in = CreatePipe+ , std_out =+ if stripTHLoading+ then CreatePipe+ else case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ , std_err =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ }+ $logDebug $ "Running: " <> T.pack (show $ toFilePath exeName : fullArgs)++ -- Use createProcess_ to avoid the log file being closed afterwards+ (Just inH, moutH, Nothing, ph) <- liftIO $ createProcess_ "singleBuild" cp+ liftIO $ hClose inH+ case moutH of+ Just outH -> assert stripTHLoading $ printWithoutTHLoading outH+ Nothing -> return ()+ ec <- liftIO $ waitForProcess ph+ case ec of+ ExitSuccess -> return ()+ _ -> do+ bs <- liftIO $+ case mlogFile of+ Nothing -> return ""+ Just (logFile, h) -> do+ hClose h+ S.readFile $ toFilePath logFile+ throwM $ CabalExitedUnsuccessfully+ ec+ taskProvides+ exeName+ fullArgs+ (fmap fst mlogFile)+ bs++ runTests package pkgDir mlogFile = do+ bconfig <- asks getBuildConfig+ distRelativeDir' <- distRelativeDir eeCabalPkgVer+ let buildDir = pkgDir </> distRelativeDir'+ let exeExtension =+ case configPlatform $ getConfig bconfig of+ Platform _ Windows -> ".exe"+ _ -> ""++ errs <- liftM Map.unions $ forM (Set.toList $ packageTests package) $ \testName -> do+ nameDir <- liftIO $ parseRelDir $ T.unpack testName+ 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+ }+ if exists+ then do+ announce $ "test " <> testName+ let cp = (proc (toFilePath exeName) [])+ { cwd = Just $ toFilePath pkgDir+ , Process.env = envHelper menv+ , std_in = CreatePipe+ , std_out =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ , std_err =+ case mlogFile of+ Nothing -> Inherit+ Just (_, h) -> UseHandle h+ }++ -- Use createProcess_ to avoid the log file being closed afterwards+ (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp+ liftIO $ hClose inH+ ec <- liftIO $ waitForProcess ph+ return $ case ec of+ ExitSuccess -> M.empty+ _ -> M.singleton testName $ Just ec+ else do+ $logError $ T.concat+ [ "Test suite "+ , testName+ , " executable not found for "+ , T.pack $ packageNameString $ packageName package+ ]+ return $ Map.singleton testName Nothing+ unless (Map.null errs) $ throwM $ TestSuiteFailure taskProvides errs (fmap fst mlogFile)++-- | 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+ $$ CB.lines+ =$ CL.filter (not . isTHLoading)+ =$ CL.mapM_ S8.putStrLn+ where+ -- | Is this line a Template Haskell "Loading package" line+ -- ByteString+ isTHLoading :: S8.ByteString -> Bool+ isTHLoading bs =+ "Loading package " `S8.isPrefixOf` bs &&+ ("done." `S8.isSuffixOf` bs || "done.\r" `S8.isSuffixOf` bs)++taskLocation :: Task -> Location+taskLocation task =+ case taskType task of+ TTLocal _ _ -> Local+ TTUpstream _ loc -> loc++-- | Ensure Setup.hs exists in the given directory. Returns an action+-- to remove it later.+getSetupHs :: Path Abs Dir -- ^ project directory+ -> IO (Maybe (Path Abs File))+getSetupHs dir = do+ exists1 <- doesFileExist (toFilePath fp1)+ if exists1+ then return $ Just fp1+ else do+ exists2 <- doesFileExist (toFilePath fp2)+ if exists2+ then return $ Just fp2+ else return Nothing+ where+ fp1 = dir </> $(mkRelFile "Setup.hs")+ fp2 = dir </> $(mkRelFile "Setup.lhs")
+ src/Stack/Build/Installed.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+-- Determine which packages are already installed+module Stack.Build.Installed+ ( InstalledMap+ , Installed (..)+ , getInstalled+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Network.HTTP.Client.Conduit (HasHttpManager)+import Path+import Prelude hiding (FilePath, writeFile)+import Stack.Build.Cache+import Stack.Build.Types+import Stack.GhcPkg+import Stack.PackageDump+import Stack.Types+import Stack.Types.Internal++type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)++data LoadHelper = LoadHelper+ { lhId :: !GhcPkgId+ , lhDeps :: ![GhcPkgId]+ , lhPair :: !(PackageName, (Version, Location, Installed))+ }+ deriving Show++type InstalledMap = Map PackageName (Version, Location, Installed)+data Installed = Library GhcPkgId | Executable+ deriving (Show, Eq, Ord)++-- | Returns the new InstalledMap and all of the locally registered packages.+getInstalled :: (M env m, PackageInstallInfo pii)+ => EnvOverride+ -> Bool -- ^ profiling?+ -> Map PackageName pii -- ^ does not contain any installed information+ -> m (InstalledMap, Set GhcPkgId)+getInstalled menv profiling sourceMap = do+ snapDBPath <- packageDatabaseDeps+ localDBPath <- packageDatabaseLocal++ bconfig <- asks getBuildConfig++ mpcache <-+ if profiling+ then liftM Just $ loadProfilingCache $ configProfilingCache bconfig+ else return Nothing++ let loadDatabase' = loadDatabase menv mpcache sourceMap+ (installedLibs', localInstalled) <-+ loadDatabase' Nothing [] >>=+ loadDatabase' (Just (Snap, snapDBPath)) . fst >>=+ loadDatabase' (Just (Local, localDBPath)) . fst+ let installedLibs = M.fromList $ map lhPair installedLibs'++ case mpcache of+ Nothing -> return ()+ Just pcache -> saveProfilingCache (configProfilingCache bconfig) pcache++ -- Add in the executables that are installed, making sure to only trust a+ -- listed installation under the right circumstances (see below)+ let exesToSM loc = Map.unions . map (exeToSM loc)+ exeToSM loc (PackageIdentifier name version) =+ case Map.lookup name sourceMap of+ -- Doesn't conflict with anything, so that's OK+ Nothing -> m+ Just pii+ -- Not the version we want, ignore it+ | version /= piiVersion pii -> Map.empty+ | otherwise -> case pii of+ {- FIXME revisit this logic+ -- Never mark locals as installed, instead do dirty+ -- checking+ PSLocal _ -> Map.empty++ -- FIXME start recording build flags for installed+ -- executables, and only count as installed if it+ -- matches++ PSUpstream loc' _flags | loc == loc' -> Map.empty+ -}++ -- Passed all the tests, mark this as installed!+ _ -> m+ where+ m = Map.singleton name (version, loc, Executable)+ exesSnap <- getInstalledExes Snap+ exesLocal <- getInstalledExes Local+ let installedMap = Map.unions+ [ exesToSM Local exesLocal+ , exesToSM Snap exesSnap+ , installedLibs+ ]++ return (installedMap, localInstalled)++-- | Outputs both the modified InstalledMap and the Set of all installed packages in this database+--+-- The goal is to ascertain that the dependencies for a package are present,+-- that it has profiling if necessary, and that it matches the version and+-- location needed by the SourceMap+loadDatabase :: (M env m, PackageInstallInfo pii)+ => EnvOverride+ -> Maybe ProfilingCache -- ^ if Just, profiling is required+ -> Map PackageName pii -- ^ to determine which installed things we should include+ -> Maybe (Location, Path Abs Dir) -- ^ package database, Nothing for global+ -> [LoadHelper] -- ^ from parent databases+ -> m ([LoadHelper], Set GhcPkgId)+loadDatabase menv mpcache sourceMap mdb lhs0 = do+ (lhs1, gids) <- ghcPkgDump menv (fmap snd mdb)+ $ conduitDumpPackage =$ sink+ let lhs = pruneDeps+ (packageIdentifierName . ghcPkgIdPackageIdentifier)+ lhId+ lhDeps+ const+ (lhs0 ++ lhs1)+ return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, Set.fromList gids)+ where+ conduitCache =+ case mpcache of+ Just pcache -> addProfiling pcache+ -- Just an optimization to avoid calculating the profiling+ -- values when they aren't necessary+ Nothing -> CL.map (\dp -> dp { dpProfiling = False })+ sinkDP = conduitCache+ =$ CL.mapMaybe (isAllowed mpcache sourceMap (fmap fst mdb))+ =$ CL.consume+ sinkGIDs = CL.map dpGhcPkgId =$ CL.consume+ sink = getZipSink $ (,)+ <$> ZipSink sinkDP+ <*> ZipSink sinkGIDs++-- | Check if a can be included in the set of installed packages or not, based+-- on the package selections made by the user. This does not perform any+-- dirtiness or flag change checks.+isAllowed :: PackageInstallInfo pii+ => Maybe ProfilingCache+ -> Map PackageName pii+ -> Maybe Location+ -> DumpPackage Bool+ -> Maybe LoadHelper+isAllowed mpcache sourceMap mloc dp+ -- Check that it can do profiling if necessary+ | isJust mpcache && not (dpProfiling dp) = Nothing+ | toInclude = Just LoadHelper+ { lhId = gid+ , lhDeps = dpDepends dp+ , lhPair = (name, (version, fromMaybe Snap mloc, Library gid))+ }+ | otherwise = Nothing+ where+ toInclude =+ case Map.lookup name sourceMap of+ -- The sourceMap has nothing to say about this package, so we can use it+ Nothing -> True++ Just pii ->+ version == piiVersion pii -- only accept the desired version+ && checkLocation (piiLocation pii)++ -- Ensure that the installed location matches where the sourceMap says it+ -- should be installed+ checkLocation Snap = mloc /= Just Local -- we can allow either global or snap+ checkLocation Local = mloc == Just Local++ gid = dpGhcPkgId dp+ PackageIdentifier name version = ghcPkgIdPackageIdentifier gid
+ src/Stack/Build/Source.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+-- Load information on package sources+module Stack.Build.Source+ ( loadSourceMap+ , SourceMap+ , PackageSource (..)+ ) where++import Network.HTTP.Client.Conduit (HasHttpManager)+import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource+import Data.Either+import Data.Function+import Data.List+import qualified Data.Map as Map+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.Set as Set+import qualified Data.Text as T+import Path+import Prelude hiding (FilePath, writeFile)+import Stack.Build.Cache+import Stack.Build.Types+import Stack.BuildPlan (loadMiniBuildPlan,+ shadowMiniBuildPlan)+import Stack.Package+import Stack.Types+import System.Directory hiding (findExecutable, findFiles)++type SourceMap = Map PackageName PackageSource+data PackageSource+ = PSLocal LocalPackage+ | PSUpstream Version Location (Map FlagName Bool)+instance PackageInstallInfo PackageSource where+ piiVersion (PSLocal lp) = packageVersion $ lpPackage lp+ piiVersion (PSUpstream v _ _) = v++ piiLocation (PSLocal _) = Local+ piiLocation (PSUpstream _ loc _) = loc++loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m)+ => BuildOpts+ -> m (MiniBuildPlan, [LocalPackage], SourceMap)+loadSourceMap bopts = do+ bconfig <- asks getBuildConfig+ mbp0 <- case bcResolver bconfig of+ ResolverSnapshot snapName -> do+ $logDebug $ "Checking resolver: " <> renderSnapName snapName+ mbp <- loadMiniBuildPlan snapName+ return mbp+ ResolverGhc ghc -> return MiniBuildPlan+ { mbpGhcVersion = fromMajorVersion ghc+ , mbpPackages = Map.empty+ }++ locals <- loadLocals bopts++ let shadowed = Set.fromList (map (packageName . lpPackage) locals)+ <> Map.keysSet (bcExtraDeps bconfig)+ (mbp, extraDeps0) = 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)++ -- Overwrite any flag settings with those from the config file+ extraDeps2 = Map.mapWithKey+ (\n (v, f) -> PSUpstream v Local $ fromMaybe f $ Map.lookup n $ bcFlags bconfig)+ extraDeps1++ let sourceMap = Map.unions+ [ Map.fromList $ flip map locals $ \lp ->+ let p = lpPackage lp+ in (packageName p, PSLocal lp)+ , extraDeps2+ , flip fmap (mbpPackages mbp) $ \mpi ->+ (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi))+ ]++ return (mbp, locals, sourceMap)++loadLocals :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+ => BuildOpts+ -> m [LocalPackage]+loadLocals bopts = do+ targets <- mapM parseTarget $+ case boptsTargets bopts of+ Left [] -> ["."]+ Left x -> x+ Right _ -> []+ (dirs, names0) <- case partitionEithers targets of+ ([], targets') -> return $ partitionEithers targets'+ (bad, _) -> throwM $ Couldn'tParseTargets bad+ let names = Set.fromList names0++ bconfig <- asks getBuildConfig+ lps <- forM (Set.toList $ bcPackages bconfig) $ \dir -> 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+ , packageConfigFlags = localFlags bopts bconfig name+ , packageConfigGhcVersion = bcGhcVersion bconfig+ , packageConfigPlatform = configPlatform $ getConfig bconfig+ }+ cabalfp+ when (packageName pkg /= name) $ throwM+ $ MismatchedCabalName cabalfp (packageName pkg)+ mbuildCache <- tryGetBuildCache dir+ mconfigCache <- tryGetConfigCache dir+ fileModTimes <- getPackageFileModTimes pkg cabalfp+ return LocalPackage+ { lpPackage = pkg+ , lpWanted = wanted+ , lpLastConfigOpts = mconfigCache+ , lpDirtyFiles =+ maybe True+ ((/= fileModTimes) . buildCacheTimes)+ mbuildCache+ , lpCabalFile = cabalfp+ , lpDir = dir+ }++ let known = Set.fromList $ map (packageName . lpPackage) lps+ unknown = Set.difference names known+ unless (Set.null unknown) $ throwM $ UnknownTargets $ Set.toList unknown++ return lps+ where+ parseTarget t = do+ let s = T.unpack t+ isDir <- liftIO $ doesDirectoryExist s+ if isDir+ then liftM (Right . Left) $ liftIO (canonicalizePath s) >>= parseAbsDir+ else return $ case parsePackageNameFromString s of+ Left _ -> Left t+ Right pname -> Right $ Right pname+ isWanted dirs names dir name =+ name `Set.member` names ||+ any (`isParentOf` dir) dirs ||+ any (== dir) dirs++-- | All flags for a local package+localFlags :: BuildOpts -> BuildConfig -> PackageName -> Map FlagName Bool+localFlags bopts bconfig name = Map.union+ (fromMaybe Map.empty $ Map.lookup name $ boptsFlags bopts)+ (fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig)
+ src/Stack/Build/Types.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}++-- | All data types.++module Stack.Build.Types where++import Control.DeepSeq+import Control.Exception+import Data.Aeson+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 qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import 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+data StackBuildException+ = Couldn'tFindPkgId PackageName+ | GHCVersionMismatch (Maybe Version) Version (Maybe (Path Abs File))+ -- ^ Path to the stack.yaml file+ | Couldn'tParseTargets [Text]+ | UnknownTargets [PackageName]+ | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File))+ | ConstructPlanExceptions [ConstructPlanException]+ | CabalExitedUnsuccessfully+ ExitCode+ PackageIdentifier+ (Path Abs File) -- cabal Executable+ [String] -- cabal arguments+ (Maybe (Path Abs File)) -- logfiles location+ S.ByteString -- log contents+ | ExecutionFailure [SomeException]+ deriving Typeable++instance Show StackBuildException where+ show (Couldn'tFindPkgId name) =+ ("After installing " <> packageNameString name <>+ ", the package id couldn't be found " <> "(via ghc-pkg describe " <>+ packageNameString name <> "). This shouldn't happen, " <>+ "please report as a bug")+ show (GHCVersionMismatch mactual expected mstack) = concat+ [ case mactual of+ Nothing -> "No GHC found, expected version "+ Just actual ->+ "GHC version mismatched, found " +++ versionString actual +++ ", but expected version "+ , versionString expected+ , " (based on "+ , case mstack of+ Nothing -> "command line arguments"+ Just stack -> "resolver setting in " ++ toFilePath stack+ , "). Try running stack setup"+ ]+ show (Couldn'tParseTargets targets) = unlines+ $ "The following targets could not be parsed as package names or directories:"+ : map T.unpack targets+ show (UnknownTargets targets) =+ "The following target packages were not found: " +++ intercalate ", " (map packageNameString targets)+ show (TestSuiteFailure ident codes mlogFile) = unlines $ concat+ [ ["Test suite failure for package " ++ packageIdentifierString ident]+ , flip map (Map.toList codes) $ \(name, mcode) -> concat+ [ " "+ , T.unpack name+ , ": "+ , case mcode of+ Nothing -> " executable not found"+ Just ec -> " exited with: " ++ show ec+ ]+ , return $ case mlogFile of+ Nothing -> "Logs printed to console"+ -- TODO Should we load up the full error output and print it here?+ Just logFile -> "Full log available at " ++ toFilePath logFile+ ]+ show (ConstructPlanExceptions exceptions) =+ "While constructing the BuildPlan the following exceptions were encountered:" +++ appendExceptions (removeDuplicates exceptions)+ where+ appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""+ removeDuplicates = nub+ -- Supressing duplicate output+ show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =+ let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))+ logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ show fp) logFiles+ in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" +++ " " ++ fullCmd ++ "\n" +++ " Process exited with code: " ++ show exitCode +++ logLocations +++ (if S.null bs+ then ""+ else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))+ where+ -- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ dropQuotes = filter ('\"' /=)+ doubleIndent = indent . indent+ show (ExecutionFailure es) = intercalate "\n\n" $ map show es++instance Exception StackBuildException++data ConstructPlanException+ = DependencyCycleDetected [PackageName]+ | DependencyPlanFailures PackageName (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)++-- | Reason why a dependency was not used+data BadDependency+ = NotInBuildPlan -- TODO add recommended version so it can be added to extra-deps+ | Couldn'tResolveItsDependencies+ | DependencyMismatch Version+ deriving (Typeable, Eq)++instance Show ConstructPlanException where+ show e =+ let details = case e of+ (DependencyCycleDetected pNames) ->+ "While checking call stack,\n" +++ " dependency cycle detected in packages:" ++ indent (appendLines pNames)+ (DependencyPlanFailures pName (Map.toList -> pDeps)) ->+ "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" +++ " needed for package: " ++ show pName+ (UnknownPackage pName) ->+ "While attempting to add dependency,\n" +++ " Could not find package " ++ show pName ++ " in known packages"+ in indent details+ where+ appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ doubleIndent = indent . indent+ appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""+ showDep (name, (range, badDep)) = concat+ [ show name+ , ": needed ("+ , display range+ , "), but "+ , case badDep of+ NotInBuildPlan -> "not present in build plan"+ Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"+ DependencyMismatch version -> versionString version ++ " found"+ ]+ {- TODO Perhaps change the showDep function to look more like this:+ dropQuotes = filter ((/=) '\"')+ (VersionOutsideRange pName pIdentifier versionRange) ->+ "Exception: Stack.Build.VersionOutsideRange\n" +++ " While adding dependency for package " ++ show pName ++ ",\n" +++ " " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" +++ " Allowed version range is " ++ display versionRange ++ ",\n" +++ " should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"+ -}+++----------------------------------------------++-- | Configuration for building.+data BuildOpts =+ BuildOpts {boptsTargets :: !(Either [Text] [PackageName])+ -- ^ Right value indicates that we're only installing+ -- dependencies, no local packages+ ,boptsLibProfile :: !Bool+ ,boptsExeProfile :: !Bool+ ,boptsEnableOptimizations :: !(Maybe Bool)+ ,boptsFinalAction :: !FinalAction+ ,boptsDryrun :: !Bool+ ,boptsGhcOptions :: ![Text]+ ,boptsFlags :: !(Map PackageName (Map FlagName Bool))+ }+ deriving (Show)++-- | Configuration for testing.+data TestConfig =+ TestConfig {tconfigTargets :: ![Text]+ }+ deriving (Show)++-- | Configuration for haddocking.+data HaddockConfig =+ HaddockConfig {hconfigTargets :: ![Text]+ }+ deriving (Show)++-- | Configuration for benchmarking.+data BenchmarkConfig =+ BenchmarkConfig {benchTargets :: ![Text]+ ,benchInDocker :: !Bool}+ deriving (Show)++-- | Generated config for a package build.+data GenConfig =+ GenConfig {gconfigOptimize :: !Bool+ ,gconfigLibProfiling :: !Bool+ ,gconfigExeProfiling :: !Bool+ ,gconfigGhcOptions :: ![Text]+ ,gconfigFlags :: !(Map FlagName Bool)+ ,gconfigPkgId :: Maybe GhcPkgId}+ deriving (Generic,Show)++instance FromJSON GenConfig+instance ToJSON GenConfig++defaultGenConfig :: GenConfig+defaultGenConfig =+ GenConfig {gconfigOptimize = False+ ,gconfigLibProfiling = False+ ,gconfigExeProfiling = False+ ,gconfigGhcOptions = []+ ,gconfigFlags = mempty+ ,gconfigPkgId = Nothing}++-- | Run a Setup.hs action after building a package, before installing.+data FinalAction+ = DoTests+ | DoBenchmarks+ | DoHaddock+ | DoNothing+ deriving (Eq,Bounded,Enum,Show)++data Dependencies =+ Dependencies {depsLibraries :: [PackageName]+ ,depsTools :: [PackageName]}+ deriving (Show,Typeable,Data)++-- | Used for mutex locking on the install step. Beats magic ().+data InstallLock = InstallLock++-- | Mutex for reading/writing .config files in dist/ of+-- packages. Shake works in parallel, without this there are race+-- conditions.+data ConfigLock = ConfigLock++-- | Package dependency oracle.+newtype PkgDepsOracle =+ PkgDeps PackageName+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)++-- | A location to install a package into, either snapshot or local+data Location = Snap | Local+ deriving (Show, Eq)++-- | Datatype which tells how which version of a package to install and where+-- to install it into+class PackageInstallInfo a where+ piiVersion :: a -> Version+ piiLocation :: a -> Location++-- | Information on a locally available package of source code+data LocalPackage = LocalPackage+ { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags+ , 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++-- | Stored on disk to know whether the flags have changed or any+-- files have changed.+data ConfigCache = ConfigCache+ { configCacheOpts :: ![S.ByteString]+ -- ^ All options used for this package.+ , configCacheDeps :: !(Set GhcPkgId)+ -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take+ -- the complete GhcPkgId (only a PackageIdentifier) in the configure+ -- options, just using the previous value is insufficient to know if+ -- dependencies have changed.+ }+ deriving (Generic,Eq,Show)+instance Binary ConfigCache++-- | A task to perform when building+data Task = Task+ { taskProvides :: !PackageIdentifier -- ^ the package/version to be built+ , taskType :: !TaskType -- ^ the task type, telling us how to build this+ , taskConfigOpts :: !TaskConfigOpts+ , taskPresent :: !(Set GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies+ }+ deriving Show++-- | Given the IDs of any missing packages, produce the configure options+data TaskConfigOpts = TaskConfigOpts+ { tcoMissing :: !(Set PackageIdentifier)+ -- ^ Dependencies for which we don't yet have an GhcPkgId+ , tcoOpts :: !(Set GhcPkgId -> [Text])+ -- ^ Produce the list of options given the missing @GhcPkgId@s+ }+instance Show TaskConfigOpts where+ show (TaskConfigOpts missing f) = concat+ [ "Missing: "+ , show missing+ , ". Without those: "+ , show $ f Set.empty+ ]++-- | The type of a task, either building local code or something from the+-- package index (upstream)+data TaskType = TTLocal LocalPackage NeededSteps+ | 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)+ , planUnregisterLocal :: !(Set GhcPkgId)+ }++-- | Basic information used to calculate what the configure options are+data BaseConfigOpts = BaseConfigOpts+ { bcoSnapDB :: !(Path Abs Dir)+ , bcoLocalDB :: !(Path Abs Dir)+ , bcoSnapInstallRoot :: !(Path Abs Dir)+ , bcoLocalInstallRoot :: !(Path Abs Dir)+ , bcoBuildOpts :: !BuildOpts+ }++-- | Render a @BaseConfigOpts@ to an actual list of options+configureOpts :: BaseConfigOpts+ -> Set GhcPkgId -- ^ dependencies+ -> Bool -- ^ wanted?+ -> Location+ -> Map FlagName Bool+ -> [Text]+configureOpts bco deps wanted loc flags = map T.pack $ concat+ [ ["--user", "--package-db=clear", "--package-db=global"]+ , map (("--package-db=" ++) . toFilePath) $ case loc of+ Snap -> [bcoSnapDB bco]+ Local -> [bcoSnapDB bco, bcoLocalDB bco]+ , depOptions+ , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "lib"))+ , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot </> bindirSuffix)+ , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "share"))+ , "--docdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "doc"))+ ]+ , ["--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+ then ""+ else "-") <>+ flagNameString name)+ (Map.toList flags)+ -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig]+ , if wanted+ then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)+ else []+ ]+ where+ bopts = bcoBuildOpts bco+ toFilePathNoTrailingSlash =+ loop . toFilePath+ where+ loop [] = []+ loop [c]+ | c == pathSeparator = []+ | otherwise = [c]+ loop (c:cs) = c : loop cs+ installRoot =+ case loc of+ Snap -> bcoSnapInstallRoot bco+ Local -> bcoLocalInstallRoot bco++ depOptions = map toDepOption $ Set.toList deps++ {- TODO does this work with some versions of Cabal?+ toDepOption gid = T.pack $ concat+ [ "--dependency="+ , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid+ , "="+ , ghcPkgIdString gid+ ]+ -}+ toDepOption gid = concat+ [ "--constraint="+ , packageNameString name+ , "=="+ , versionString version+ ]+ where+ PackageIdentifier name version = ghcPkgIdPackageIdentifier gid
+ src/Stack/BuildPlan.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+++-- | Resolving a build plan for a set of packages in a given Stackage+-- snapshot.++module Stack.BuildPlan+ ( BuildPlanException (..)+ , MiniBuildPlan(..)+ , MiniPackageInfo(..)+ , Snapshots (..)+ , getSnapshots+ , loadMiniBuildPlan+ , resolveBuildPlan+ , findBuildPlan+ , ToolMap+ , getToolMap+ , shadowMiniBuildPlan+ ) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Exception (assert)+import Control.Exception.Enclosed (handleIO)+import Control.Monad (liftM, forM)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (asks)+import Control.Monad.State.Strict (State, execState, get, modify,+ put)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Aeson (FromJSON (..))+import Data.Aeson (withObject, withText, (.:))+import Data.Binary.VersionTagged (taggedDecodeOrLoad)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Either (partitionEithers)+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.List (intercalate, sort)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (Day)+import qualified Data.Traversable as Tr+import Data.Typeable (Typeable)+import Data.Yaml (decodeFileEither)+import Distribution.PackageDescription (GenericPackageDescription,+ flagDefault, flagManual,+ flagName, genPackageFlags,+ executables, exeName, library, libBuildInfo, buildable)+import Network.HTTP.Download+import Path+import Prelude -- Fix AMP warning+import Stack.Constants+import Stack.Fetch+import Stack.GhcPkg+import Stack.Package+import Stack.PackageIndex+import Stack.Types+import System.Directory (createDirectoryIfMissing, getDirectoryContents)+import System.FilePath (takeDirectory)++data BuildPlanException+ = UnknownPackages+ (Path Abs File) -- stack.yaml file+ (Map PackageName (Maybe Version, (Set PackageName))) -- truly unknown+ (Map PackageName (Set PackageIdentifier)) -- shadowed+ deriving (Typeable)+instance Exception BuildPlanException+instance Show BuildPlanException where+ show (UnknownPackages stackYaml unknown shadowed) =+ unlines $ unknown' ++ shadowed'+ where+ unknown' :: [String]+ unknown'+ | Map.null unknown = []+ | otherwise = concat+ [ ["The following packages do not exist in the build plan:"]+ , map go (Map.toList unknown)+ , case mapMaybe goRecommend $ Map.toList unknown of+ [] -> []+ rec ->+ ("Recommended action: modify the extra-deps field of " +++ toFilePath stackYaml +++ " to include the following:")+ : (rec+ ++ ["Note: further dependencies may need to be added"])+ , case mapMaybe getNoKnown $ Map.toList unknown of+ [] -> []+ noKnown ->+ [ "There are no known versions of the following packages:"+ , intercalate ", " $ map packageNameString noKnown+ ]+ ]+ where+ go (dep, (_, users)) | Set.null users = packageNameString dep+ go (dep, (_, users)) = concat+ [ packageNameString dep+ , " (used by "+ , intercalate ", " $ map packageNameString $ Set.toList users+ , ")"+ ]++ goRecommend (name, (Just version, _)) =+ Just $ "- " ++ packageIdentifierString (PackageIdentifier name version)+ goRecommend (_, (Nothing, _)) = Nothing++ getNoKnown (name, (Nothing, _)) = Just name+ getNoKnown (_, (Just _, _)) = Nothing++ shadowed' :: [String]+ shadowed'+ | Map.null shadowed = []+ | otherwise = concat+ [ ["The following packages are shadowed by local packages:"]+ , map go (Map.toList shadowed)+ , ["Recommended action: modify the extra-deps field of " +++ toFilePath stackYaml +++ " to include the following:"]+ , extraDeps+ , ["Note: further dependencies may need to be added"]+ ]+ where+ go (dep, users) | Set.null users = concat+ [ packageNameString dep+ , " (internal stack error: this should never be null)"+ ]+ go (dep, users) = concat+ [ packageNameString dep+ , " (used by "+ , intercalate ", "+ $ map (packageNameString . packageIdentifierName)+ $ Set.toList users+ , ")"+ ]++ extraDeps = map (\ident -> "- " ++ packageIdentifierString ident)+ $ Set.toList+ $ Set.unions+ $ Map.elems shadowed++-- | Determine the necessary packages to install to have the given set of+-- packages available.+--+-- This function will not provide test suite and benchmark dependencies.+--+-- This may fail if a target package is not present in the @BuildPlan@.+resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env)+ => EnvOverride+ -> MiniBuildPlan+ -> (PackageName -> Bool) -- ^ is it shadowed by a local package?+ -> Map PackageName (Set PackageName) -- ^ required packages, and users of it+ -> m ( Map PackageName (Version, Map FlagName Bool)+ , Map PackageName (Set PackageName)+ )+resolveBuildPlan menv mbp isShadowed packages+ | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs)+ | otherwise = do+ cache <- getPackageCaches menv+ let maxVer = Map.fromListWith max $ map toTuple $ Map.keys cache+ unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x ->+ (Map.lookup ident maxVer, x)+ bconfig <- asks getBuildConfig+ throwM $ UnknownPackages+ (bcStackYaml bconfig)+ unknown+ (rsShadowed rs)+ where+ rs = getDeps mbp isShadowed packages++data ResolveState = ResolveState+ { rsVisited :: Map PackageName (Set PackageName) -- ^ set of shadowed dependencies+ , rsUnknown :: Map PackageName (Set PackageName)+ , rsShadowed :: Map PackageName (Set PackageIdentifier)+ , rsToInstall :: Map PackageName (Version, Map FlagName Bool)+ , rsUsedBy :: Map PackageName (Set PackageName)+ }++toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)+ => BuildPlan -> m MiniBuildPlan+toMiniBuildPlan bp = do+ extras <- addDeps ghcVersion $ fmap goPP $ bpPackages bp+ return MiniBuildPlan+ { mbpGhcVersion = ghcVersion+ , mbpPackages = Map.union cores extras+ }+ where+ ghcVersion = siGhcVersion $ bpSystemInfo bp+ cores = fmap (\v -> MiniPackageInfo+ { mpiVersion = v+ , mpiFlags = Map.empty+ , mpiPackageDeps = Set.empty+ , mpiToolDeps = Set.empty+ , mpiExes = Set.empty+ , mpiHasLibrary = True+ }) $ siCorePackages $ bpSystemInfo bp++ goPP pp =+ ( ppVersion pp+ , pcFlagOverrides $ ppConstraints pp+ )++-- | Add in the resolved dependencies from the package index+addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)+ => Version -- ^ GHC version+ -> Map PackageName (Version, Map FlagName Bool)+ -> m (Map PackageName MiniPackageInfo)+addDeps ghcVersion toCalc = do+ menv <- getMinimalEnvOverride+ platform <- asks $ configPlatform . getConfig+ resolvedMap <- resolvePackages menv (Map.keysSet idents0) Set.empty+ let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap)+ $ \(ident, rp) ->+ (indexName $ rpIndex rp,+ [( ident+ , rpCache rp+ , maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc+ )])+ res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs+ $ \ident flags cabalBS -> do+ gpd <- readPackageUnresolvedBS Nothing cabalBS+ let packageConfig = PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False+ , packageConfigFlags = flags+ , packageConfigGhcVersion = ghcVersion+ , packageConfigPlatform = platform+ }+ name = packageIdentifierName ident+ pd = resolvePackageDescription packageConfig gpd+ exes = Set.fromList $ map (ExeName . S8.pack . exeName) $ executables pd+ notMe = Set.filter (/= name) . Map.keysSet+ return (name, MiniPackageInfo+ { mpiVersion = packageIdentifierVersion ident+ , mpiFlags = flags+ , mpiPackageDeps = notMe $ packageDependencies pd+ , mpiToolDeps = Map.keysSet $ packageToolDependencies pd+ , mpiExes = exes+ , mpiHasLibrary = maybe+ False+ (buildable . libBuildInfo)+ (library pd)+ })+ return $ Map.fromList $ concat res+ where+ idents0 = Map.fromList+ $ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f))+ $ Map.toList toCalc++-- | Resolve all packages necessary to install for+getDeps :: MiniBuildPlan+ -> (PackageName -> Bool) -- ^ is it shadowed by a local package?+ -> Map PackageName (Set PackageName)+ -> ResolveState+getDeps mbp isShadowed packages =+ execState (mapM_ (uncurry goName) $ Map.toList packages) ResolveState+ { rsVisited = Map.empty+ , rsUnknown = Map.empty+ , rsShadowed = Map.empty+ , rsToInstall = Map.empty+ , rsUsedBy = Map.empty+ }+ where+ toolMap = getToolMap mbp++ -- | Returns a set of shadowed packages we depend on.+ goName :: PackageName -> Set PackageName -> State ResolveState (Set PackageName)+ goName name users = do+ -- Even though we could check rsVisited first and short-circuit things+ -- earlier, lookup in mbpPackages first so that we can produce more+ -- usable error information on missing dependencies+ rs <- get+ put rs+ { rsUsedBy = Map.insertWith Set.union name users $ rsUsedBy rs+ }+ case Map.lookup name $ mbpPackages mbp of+ Nothing -> do+ modify $ \rs' -> rs'+ { rsUnknown = Map.insertWith Set.union name users $ rsUnknown rs'+ }+ return Set.empty+ Just mpi -> case Map.lookup name (rsVisited rs) of+ Just shadowed -> return shadowed+ Nothing -> do+ put rs { rsVisited = Map.insert name Set.empty $ rsVisited rs }+ let depsForTools = Set.unions $ mapMaybe (flip Map.lookup toolMap) (Set.toList $ mpiToolDeps mpi)+ let deps = Set.filter (/= name) (mpiPackageDeps mpi <> depsForTools)+ shadowed <- fmap F.fold $ Tr.forM (Set.toList deps) $ \dep ->+ if isShadowed dep+ then do+ modify $ \rs' -> rs'+ { rsShadowed = Map.insertWith+ Set.union+ dep+ (Set.singleton $ PackageIdentifier name (mpiVersion mpi))+ (rsShadowed rs')+ }+ return $ Set.singleton dep+ else do+ shadowed <- goName dep (Set.singleton name)+ let m = Map.fromList $ map (\x -> (x, Set.singleton $ PackageIdentifier name (mpiVersion mpi)))+ $ Set.toList shadowed+ modify $ \rs' -> rs'+ { rsShadowed = Map.unionWith Set.union m $ rsShadowed rs'+ }+ return shadowed+ modify $ \rs' -> rs'+ { rsToInstall = Map.insert name (mpiVersion mpi, mpiFlags mpi) $ rsToInstall rs'+ , rsVisited = Map.insert name shadowed $ rsVisited rs'+ }+ return shadowed++-- | Look up with packages provide which tools.+type ToolMap = Map ByteString (Set PackageName)++-- | Map from tool name to package providing it+getToolMap :: MiniBuildPlan -> Map ByteString (Set PackageName)+getToolMap mbp = Map.unionsWith Set.union+ -- First grab all of the package names, for times where a build tool is+ -- identified by package name+ $ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps))+ -- And then get all of the explicit executable names+ : concatMap goPair (Map.toList ps)+ where+ ps = mbpPackages mbp++ goPair (pname, mpi) =+ map (flip Map.singleton (Set.singleton pname) . unExeName)+ $ Set.toList+ $ mpiExes mpi++-- | Download the 'Snapshots' value from stackage.org.+getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)+ => m Snapshots+getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON++-- | Most recent Nightly and newest LTS version per major release.+data Snapshots = Snapshots+ { snapshotsNightly :: !Day+ , snapshotsLts :: !(IntMap Int)+ }+ deriving Show+instance FromJSON Snapshots where+ parseJSON = withObject "Snapshots" $ \o -> Snapshots+ <$> (o .: "nightly" >>= parseNightly)+ <*> (fmap IntMap.unions+ $ mapM parseLTS+ $ map snd+ $ filter (isLTS . fst)+ $ HM.toList o)+ where+ parseNightly t =+ case parseSnapName t of+ Left e -> fail $ show e+ Right (LTS _ _) -> fail "Unexpected LTS value"+ Right (Nightly d) -> return d++ isLTS = ("lts-" `T.isPrefixOf`)++ parseLTS = withText "LTS" $ \t ->+ case parseSnapName t of+ Left e -> fail $ show e+ Right (LTS x y) -> return $ IntMap.singleton x y+ Right (Nightly _) -> fail "Unexpected nightly value"++-- | Load up a 'MiniBuildPlan', preferably from cache+loadMiniBuildPlan+ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)+ => SnapName+ -> m MiniBuildPlan+loadMiniBuildPlan name = do+ path <- configMiniBuildPlanCache name+ let fp = toFilePath path+ taggedDecodeOrLoad fp $ liftM buildPlanFixes $+ loadBuildPlan name >>= toMiniBuildPlan++-- | Some hard-coded fixes for build plans, hopefully to be irrelevant over+-- time.+buildPlanFixes :: MiniBuildPlan -> MiniBuildPlan+buildPlanFixes mbp = mbp+ { mbpPackages = Map.fromList $ map go $ Map.toList $ mbpPackages mbp+ }+ where+ go (name, mpi) =+ (name, mpi+ { mpiFlags = goF (packageNameString name) (mpiFlags mpi)+ })++ goF "persistent-sqlite" = Map.insert $(mkFlagName "systemlib") False+ goF "yaml" = Map.insert $(mkFlagName "system-libyaml") False+ goF _ = id++-- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy+-- if available, otherwise downloading from Github.+loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env)+ => SnapName+ -> m BuildPlan+loadBuildPlan name = do+ env <- ask+ let stackage = getStackRoot env+ file' <- parseRelFile $ T.unpack file+ let fp = stackage </> $(mkRelDir "build-plan") </> file'+ $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)+ eres <- liftIO $ decodeFileEither $ toFilePath fp+ case eres of+ Right bp -> return bp+ Left e -> do+ $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)+ liftIO $ createDirectoryIfMissing True $ takeDirectory $ toFilePath fp+ req <- parseUrl $ T.unpack url+ $logInfo $ "Downloading " <> renderSnapName name <> " build plan ..."+ $logDebug $ "Downloading build plan from: " <> url+ _ <- download req fp+ $logInfo $ "Downloaded " <> renderSnapName name <> " build plan."+ liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return++ where+ file = renderSnapName name <> ".yaml"+ reponame =+ case name of+ LTS _ _ -> "lts-haskell"+ Nightly _ -> "stackage-nightly"+ url = rawGithubUrl "fpco" reponame "master" file++-- | Find the set of @FlagName@s necessary to get the given+-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will+-- only modify non-manual flags, and will prefer default values for flags.+-- Returns @Nothing@ if no combination exists.+checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)+ => SnapName -- ^ used only for debugging purposes+ -> MiniBuildPlan+ -> GenericPackageDescription+ -> m (Maybe (Map FlagName Bool))+checkBuildPlan name mbp gpd = do+ $logInfo $ "Checking against build plan " <> renderSnapName name+ platform <- asks (configPlatform . getConfig)+ loop platform flagOptions+ where+ loop _ [] = return Nothing+ loop platform (flags:rest) = do+ passes <- checkDeps flags (packageDeps pkg) (mbpPackages mbp)+ if passes+ then return $ Just flags+ else loop platform rest+ where+ pkg = resolvePackage pkgConfig gpd+ pkgConfig = PackageConfig+ { packageConfigEnableTests = True+ , packageConfigEnableBenchmarks = True+ , packageConfigFlags = flags+ , packageConfigGhcVersion = ghcVersion+ , packageConfigPlatform = platform+ }++ ghcVersion = mbpGhcVersion mbp++ flagName' = fromCabalFlagName . flagName++ flagOptions = map Map.fromList $ mapM getOptions $ genPackageFlags gpd+ getOptions f+ | flagManual f = [(flagName' f, flagDefault f)]+ | flagDefault f =+ [ (flagName' f, True)+ , (flagName' f, False)+ ]+ | otherwise =+ [ (flagName' f, False)+ , (flagName' f, True)+ ]++-- | Checks if the given package dependencies can be satisfied by the given set+-- of packages. Will fail if a package is either missing or has a version+-- outside of the version range.+checkDeps :: MonadLogger m+ => Map FlagName Bool -- ^ used only for debugging purposes+ -> Map PackageName VersionRange+ -> Map PackageName MiniPackageInfo+ -> m Bool+checkDeps flags deps packages = do+ let errs = mapMaybe go $ Map.toList deps+ if null errs+ then return True+ else do+ $logDebug $ "Checked against following flags: " <> T.pack (show flags)+ mapM_ $logDebug errs+ return False+ where+ go :: (PackageName, VersionRange) -> Maybe Text+ go (name, range) =+ case fmap mpiVersion $ Map.lookup name packages of+ Nothing -> Just $ "Package not present: " <> packageNameText name+ Just v+ | withinRange v range -> Nothing+ | otherwise -> Just $ T.concat+ [ packageNameText name+ , " version available: "+ , versionText v+ , " does not match "+ , versionRangeText range+ ]++-- | Find a snapshot and set of flags that is compatible with the given+-- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.+findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)+ => GenericPackageDescription+ -> m (Maybe (SnapName, Map FlagName Bool))+findBuildPlan gpd = do+ -- Get the most recent LTS and Nightly in the snapshots directory and+ -- prefer them over anything else, since odds are high that something+ -- already exists for them.+ existing <-+ liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $+ snapshotsDir >>=+ liftIO . handleIO (const $ return [])+ . getDirectoryContents . toFilePath+ let isLTS LTS{} = True+ isLTS Nightly{} = False+ isNightly Nightly{} = True+ isNightly LTS{} = False++ snapshots <- getSnapshots+ let names = nubOrd $ concat+ [ take 2 $ filter isLTS existing+ , take 2 $ filter isNightly existing+ , map (uncurry LTS)+ (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)+ , [Nightly $ snapshotsNightly snapshots]+ ]+ loop [] = return Nothing+ loop (name:names') = do+ mbp <- loadMiniBuildPlan name+ mflags <- checkBuildPlan name mbp gpd+ case mflags of+ Nothing -> loop names'+ Just flags -> return $ Just (name, flags)+ loop names++-- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.+nubOrd :: Ord a => [a] -> [a]+nubOrd =+ go Set.empty+ where+ go _ [] = []+ go s (x:xs)+ | x `Set.member` s = go s xs+ | otherwise = x : go (Set.insert x s) xs++shadowMiniBuildPlan :: MiniBuildPlan+ -> Set PackageName+ -> (MiniBuildPlan, Map PackageName MiniPackageInfo)+shadowMiniBuildPlan (MiniBuildPlan ghc pkgs0) shadowed =+ (MiniBuildPlan ghc $ Map.fromList met, Map.fromList unmet)+ where+ pkgs1 = Map.difference pkgs0 $ Map.fromList $ map (, ()) $ Set.toList shadowed++ depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1)++ check visited name+ | name `Set.member` visited =+ error $ "shadowMiniBuildPlan: cycle detected, your MiniBuildPlan is broken: " ++ show (visited, name)+ | otherwise = do+ m <- get+ case Map.lookup name m of+ Just x -> return x+ Nothing ->+ case Map.lookup name pkgs1 of+ Nothing -> assert (name `Set.member` shadowed) (return False)+ Just mpi -> do+ let visited' = Set.insert name visited+ ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi)+ let res = and ress+ modify $ \m' -> Map.insert name res m'+ return res++ (met, unmet) = partitionEithers $ map toEither $ Map.toList pkgs1++ toEither pair@(name, _) =+ wrapper pair+ where+ wrapper =+ case Map.lookup name depsMet of+ Just True -> Left+ Just False -> Right+ Nothing -> assert False Right
+ src/Stack/Config.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}++-- | The general Stack configuration that starts everything off. This should+-- be smart to falback if there is no stack.yaml, instead relying on+-- whatever files are available.+--+-- If there is no stack.yaml, and there is a cabal.config, we+-- read in those constraints, and if there's a cabal.sandbox.config,+-- we read any constraints from there and also find the package+-- database from there, etc. And if there's nothing, we should+-- probably default to behaving like cabal, possibly with spitting out+-- a warning that "you should run `stk init` to make things better".+module Stack.Config+ ( configOptsParser+ , loadConfig+ ) where++import Control.Applicative+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 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 Data.Maybe+import Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+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 Path+import Path.IO+import Stack.BuildPlan+import Stack.Types.Config+import Stack.Constants+import qualified Stack.Docker as Docker+import Stack.Package+import Stack.Types+import System.Directory+import System.Environment+import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride)++-- | 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)+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)+ Nothing -> do+ s <- getSnapshots+ let snap = case IntMap.maxViewWithKey (snapshotsLts s) of+ Just ((x, y), _) -> LTS x y+ Nothing -> Nightly $ snapshotsNightly s+ return (ResolverSnapshot snap, Map.empty, cabalFileExists)++data ProjectAndConfigMonoid+ = ProjectAndConfigMonoid !Project !ConfigMonoid++instance FromJSON ProjectAndConfigMonoid where+ parseJSON = withObject "Project, ConfigMonoid" $ \o -> do+ dirs <- o .:? "packages" .!= ["."]+ extraDeps' <- o .:? "extra-deps" .!= []+ extraDeps <-+ case partitionEithers $ goDeps extraDeps' of+ ([], x) -> return $ Map.fromList x+ (errs, _) -> fail $ unlines errs++ flags <- o .:? "flags" .!= mempty+ resolver <- o .: "resolver"+ config <- parseJSON $ Object o+ let project = Project+ { projectPackages = dirs+ , projectExtraDeps = extraDeps+ , projectFlags = flags+ , projectResolver = resolver+ }+ return $ ProjectAndConfigMonoid project config+ where+ goDeps =+ map toSingle . Map.toList . Map.unionsWith S.union . map toMap+ where+ toMap i = Map.singleton+ (packageIdentifierName i)+ (S.singleton (packageIdentifierVersion i))++ toSingle (k, s) =+ case S.toList s of+ [x] -> Right (k, x)+ xs -> Left $ concat+ [ "Multiple versions for package "+ , packageNameString k+ , ": "+ , unwords $ map versionString xs+ ]++-- | Note that this will be @Nothing@ on Windows, which is by design.+defaultStackGlobalConfig :: Maybe (Path Abs File)+defaultStackGlobalConfig = parseAbsFile "/etc/stack/config"++-- Interprets ConfigMonoid options.+configFromConfigMonoid+ :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)+ => Path Abs Dir -- ^ stack root, e.g. ~/.stack+ -> Maybe Project+ -> ConfigMonoid+ -> m Config+configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do+ let configDocker = Docker.dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts+ configConnectionCount = fromMaybe 8 configMonoidConnectionCount+ configHideTHLoading = fromMaybe True configMonoidHideTHLoading+ configLatestSnapshotUrl = fromMaybe+ "https://www.stackage.org/download/snapshots.json"+ configMonoidLatestSnapshotUrl+ configPackageIndices = fromMaybe+ [PackageIndex+ { indexName = IndexName "hackage.haskell.org"+ , indexLocation = ILGitHttp+ "https://github.com/commercialhaskell/all-cabal-hashes.git"+ "https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz"+ , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"+ , indexGpgVerify = False+ , indexRequireHashes = False+ }]+ configMonoidPackageIndices++ -- Only place in the codebase where platform is hard-coded. In theory+ -- in the future, allow it to be configured.+ configPlatform = buildPlatform++ origEnv <- getEnvOverride configPlatform+ let configEnvOverride _ = return origEnv++ platform <- runReaderT platformRelDir configPlatform++ configLocalPrograms <-+ case configPlatform of+ Platform _ Windows -> do+ progsDir <- getWindowsProgsDir configStackRoot origEnv+ return $ progsDir </> $(mkRelDir stackProgName) </> platform+ _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform++ return Config {..}++-- | Command-line arguments parser for configuration.+configOptsParser :: Bool -> Parser ConfigMonoid+configOptsParser docker =+ (\opts -> mempty { configMonoidDockerOpts = opts })+ <$> Docker.dockerOptsParser docker++-- | Get the directory on Windows where we should install extra programs. For+-- more information, see discussion at:+-- https://github.com/fpco/minghc/issues/43#issuecomment-99737383+getWindowsProgsDir :: MonadThrow m+ => Path Abs Dir+ -> EnvOverride+ -> m (Path Abs Dir)+getWindowsProgsDir stackRoot m =+ case Map.lookup "LOCALAPPDATA" $ unEnvOverride m of+ Just t -> do+ lad <- parseAbsDir $ T.unpack t+ return $ lad </> $(mkRelDir "Programs")+ Nothing -> return $ stackRoot </> $(mkRelDir "Programs")++data MiniConfig = MiniConfig Manager Config+instance HasConfig MiniConfig where+ getConfig (MiniConfig _ c) = c+instance HasStackRoot MiniConfig+instance HasHttpManager MiniConfig where+ getHttpManager (MiniConfig man _) = man+instance HasPlatform MiniConfig++-- | 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)+ => ConfigMonoid+ -- ^ Config monoid from parsed command-line arguments+ -> m (LoadConfig m)+loadConfig configArgs = do+ stackRoot <- determineStackRoot+ extraConfigs <- getExtraConfigs stackRoot >>= mapM loadYaml+ mproject <- loadProjectConfig+ config <- configFromConfigMonoid stackRoot (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $+ case mproject of+ Nothing -> configArgs : extraConfigs+ Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs+ return $ LoadConfig+ { lcConfig = config+ , lcLoadBuildConfig = loadBuildConfig mproject config+ , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject+ }++-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.+-- values.+loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)+ => Maybe (Project, Path Abs File, ConfigMonoid)+ -> Config+ -> NoBuildConfigStrategy+ -> m BuildConfig+loadBuildConfig mproject config noConfigStrat = do+ env <- ask+ let miniConfig = MiniConfig (getHttpManager env) config+ (project, stackYamlFP) <- case mproject of+ Just (project, fp, _) -> return (project, fp)+ Nothing -> case noConfigStrat of+ ThrowException -> do+ currDir <- getWorkingDir+ throwM $ NoProjectConfigFound currDir+ ExecStrategy ->+ 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+ 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 []+ , projectExtraDeps = Map.empty+ , projectFlags = flags+ , projectResolver = r+ }+ liftIO $ Yaml.encodeFile dest' p+ return (p, dest)++ ghcVersion <-+ case projectResolver project of+ ResolverSnapshot snapName -> do+ mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig+ return $ mbpGhcVersion mbp+ ResolverGhc m -> return $ fromMajorVersion m++ let root = parent stackYamlFP+ packages' <- mapM (resolveDir root) (projectPackages project)+ let packages = S.fromList packages'++ return BuildConfig+ { bcConfig = config+ , bcResolver = projectResolver project+ , bcGhcVersion = ghcVersion+ , bcPackages = packages+ , bcExtraDeps = projectExtraDeps project+ , bcRoot = root+ , bcStackYaml = stackYamlFP+ , bcFlags = projectFlags project+ }++-- | Get the stack root, e.g. ~/.stack+determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)+determineStackRoot = do+ env <- liftIO getEnvironment+ case lookup stackRootEnvVar env of+ Nothing -> do+ x <- liftIO $ getAppUserDataDirectory stackProgName+ parseAbsDir x+ Just x -> do+ y <- liftIO $ do+ createDirectoryIfMissing True x+ canonicalizePath x+ parseAbsDir y++-- | Determine the extra config file locations which exist.+--+-- Returns most local first+getExtraConfigs :: MonadIO m+ => Path Abs Dir -- ^ stack root+ -> m [Path Abs File]+getExtraConfigs stackRoot = liftIO $ do+ env <- getEnvironment+ mstackConfig <-+ maybe (return Nothing) (fmap Just . parseAbsFile)+ $ lookup "STACK_CONFIG" env+ mstackGlobalConfig <-+ maybe (return Nothing) (fmap Just . parseAbsFile)+ $ lookup "STACK_GLOBAL_CONFIG" env+ filterM (liftIO . doesFileExist . toFilePath)+ $ fromMaybe (stackRoot </> stackDotYaml) mstackConfig+ : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig)++-- | Load and parse YAML from the given file.+loadYaml :: (FromJSON a,MonadIO m) => Path Abs File -> m a+loadYaml path =+ liftIO $ Yaml.decodeFileEither (toFilePath path)+ >>= either throwM return++-- | Get the location of the project config file, if it exists+getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)+ => m (Maybe (Path Abs File))+getProjectConfig = do+ env <- liftIO getEnvironment+ case lookup "STACK_YAML" env of+ Just fp -> do+ $logInfo "Getting project config file from STACK_YAML environment"+ liftM Just $ case parseAbsFile fp of+ Left _ -> do+ currDir <- getWorkingDir+ resolveFile currDir fp+ Right path -> return path+ Nothing -> do+ currDir <- getWorkingDir+ search currDir+ where+ search dir = do+ let fp = dir </> stackDotYaml+ fp' = toFilePath fp+ $logDebug $ "Checking for project config at: " <> T.pack fp'+ exists <- liftIO $ doesFileExist fp'+ if exists+ then return $ Just fp+ else do+ let dir' = parent dir+ if dir == dir'+ -- fully traversed, give up+ then return Nothing+ else search dir'++-- | Find the project config file location, respecting environment variables+-- and otherwise traversing parents. If no config is found, we supply a default+-- based on current directory.+loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)+ => m (Maybe (Project, Path Abs File, ConfigMonoid))+loadProjectConfig = do+ mfp <- getProjectConfig+ case mfp of+ Just fp -> do+ currDir <- getWorkingDir+ $logDebug $ "Loading project config file " <>+ T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp))+ load fp+ Nothing -> do+ $logDebug $ "No project config file found, using defaults."+ return Nothing+ where+ load fp = do+ ProjectAndConfigMonoid project config <- loadYaml fp+ return $ Just (project, fp, config)
+ src/Stack/Constants.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Constants used throughout the project.++module Stack.Constants+ (builtConfigFileFromDir+ ,builtFileFromDir+ ,configuredFileFromDir+ ,defaultShakeThreads+ ,distDirFromDir+ ,distRelativeDir+ ,haskellFileExts+ ,projectDockerSandboxDir+ ,rawGithubUrl+ ,stackDotYaml+ ,stackRootEnvVar+ ,userDocsDir+ ,configCacheFile+ ,buildCacheFile+ ,stackProgName+ )+ where++import Control.Monad (liftM)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Reader (MonadReader)+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++-- | 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+ -> m (Path Abs File)+builtFileFromDir cabalPkgVer fp = do+ dist <- distDirFromDir cabalPkgVer 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+ -> m (Path Abs File)+configuredFileFromDir cabalPkgVer fp = do+ dist <- distDirFromDir cabalPkgVer 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+ -> m (Path Abs File)+builtConfigFileFromDir cabalPkgVer fp =+ liftM (fp </>) (builtConfigRelativeFile cabalPkgVer)++-- | 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+ return (dist </> $(mkRelFile "stack.config"))++-- | Default shake thread count for parallel builds.+defaultShakeThreads :: Int+defaultShakeThreads = 4++-- -- | Hoogle database file.+-- hoogleDatabaseFile :: Path Abs Dir -> Path Abs File+-- hoogleDatabaseFile docLoc =+-- docLoc </>+-- $(mkRelFile "default.hoo")++-- -- | Extension for hoogle databases.+-- hoogleDbExtension :: String+-- hoogleDbExtension = "hoo"++-- -- | Extension of haddock files+-- haddockExtension :: String+-- haddockExtension = "haddock"++-- | User documentation directory.+userDocsDir :: Config -> Path Abs Dir+userDocsDir config = configStackRoot config </> $(mkRelDir "doc/")++-- | 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.+ -> m (Path Abs File)+buildCacheFile cabalPkgVersion dir = do+ liftM+ (</> $(mkRelFile "stack-build-cache"))+ (distDirFromDir cabalPkgVersion 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.+ -> m (Path Abs File)+configCacheFile cabalPkgVersion dir = do+ liftM+ (</> $(mkRelFile "stack-config-cache"))+ (distDirFromDir cabalPkgVersion dir)++-- | Package's build artifacts directory.+distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env)+ => PackageIdentifier -- ^ Cabal version+ -> Path Abs Dir+ -> m (Path Abs Dir)+distDirFromDir cabalPkgVersion fp =+ liftM (fp </>) (distRelativeDir cabalPkgVersion)++-- | Relative location of build artifacts.+distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env)+ => PackageIdentifier -- ^ Cabal version+ -> m (Path Rel Dir)+distRelativeDir cabalPkgVer = do+ 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")++-- | Get a URL for a raw file on Github+rawGithubUrl :: Text -- ^ user/org name+ -> Text -- ^ repo name+ -> Text -- ^ branch name+ -> Text -- ^ filename+ -> Text+rawGithubUrl org repo branch file = T.concat+ [ "https://raw.githubusercontent.com/"+ , org+ , "/"+ , repo+ , "/"+ , branch+ , "/"+ , file+ ]++-- -- | Hoogle database file.+-- hoogleDatabaseFile :: Path Abs Dir -> Path Abs File+-- hoogleDatabaseFile docLoc =+-- docLoc </>+-- $(mkRelFile "default.hoo")++-- -- | Extension for hoogle databases.+-- hoogleDbExtension :: String+-- hoogleDbExtension = "hoo"++-- -- | Extension of haddock files+-- haddockExtension :: String+-- haddockExtension = "haddock"++-- | Docker sandbox from project root.+projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir+projectDockerSandboxDir projectRoot = projectRoot </> $(mkRelDir ".docker-sandbox/")++-- | Name of the 'stack' program.+stackProgName :: String+stackProgName = "stack"++-- | The filename used for the stack config file.+stackDotYaml :: Path Rel File+stackDotYaml = $(mkRelFile "stack.yaml")++-- | Environment variable used to override the '~/.stack' location.+stackRootEnvVar :: String+stackRootEnvVar = "STACK_ROOT"
+ src/Stack/Docker.hs view
@@ -0,0 +1,975 @@+{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, NamedFieldPuns, OverloadedStrings, RankNTypes,+ RecordWildCards, TemplateHaskell, TupleSections #-}++-- | Run commands in Docker containers+module Stack.Docker+ (checkVersions+ ,cleanup+ ,CleanupOpts(..)+ ,CleanupAction(..)+ ,dockerCleanupCmdName+ ,dockerCmdName+ ,dockerOptsParser+ ,dockerOptsFromMonoid+ ,dockerPullCmdName+ ,preventInContainer+ ,pull+ ,rerunCmdWithOptionalContainer+ ,rerunCmdWithRequiredContainer+ ,rerunWithOptionalContainer+ ,reset+ ) where++import Control.Applicative+import Control.Exception+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 Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Char (isSpace,toUpper,isAscii)+import Data.List (dropWhileEnd,find,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid+import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))+import Data.Typeable (Typeable)+import Options.Applicative.Builder.Extra (maybeBoolFlags)+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+import System.Directory (createDirectoryIfMissing,removeDirectoryRecursive,removeFile)+import System.Directory (doesDirectoryExist)+import System.Environment (lookupEnv,getProgName,getArgs,getExecutablePath)+import System.Exit (ExitCode(ExitSuccess),exitWith)+import System.FilePath (takeBaseName,isPathSeparator)+import System.Info (arch,os)+import System.IO (stderr,stdin,stdout,hIsTerminalDevice)+import qualified System.Process as Proc+import System.Process.PagerEditor (editByteString)+import System.Process.Read+import Text.Printf (printf)++#ifndef mingw32_HOST_OS+import System.Posix.Signals (installHandler,sigTERM,Handler(Catch))+#endif++-- | 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)+ => 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++-- | 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)+ => Config+ -> Maybe (Path Abs Dir)+ -> IO (FilePath,[String],Config)+ -> IO ()+ -> m ()+rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs inner =+ do inContainer <- getInContainer+ if inContainer || not (dockerEnable (configDocker config))+ then liftIO inner+ else do (cmd_,args,config') <- liftIO getCmdArgs+ runContainerAndExit config' mprojectRoot cmd_ args [] (return ())++-- | 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)+ => Config+ -> Maybe (Path Abs Dir)+ -> IO (FilePath,[String],Config)+ -> m ()+rerunCmdWithRequiredContainer config mprojectRoot getCmdArgs =+ do when (not (dockerEnable (configDocker config)))+ (throwM DockerMustBeEnabledException)+ (cmd_,args,config') <- liftIO getCmdArgs+ runContainerAndExit config' mprojectRoot cmd_ args [] (return ())++-- | Error if running in a container.+preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()+preventInContainer inner =+ do inContainer <- getInContainer+ if inContainer+ then throwM OnlyOnHostException+ else inner++-- | 'True' if we are currently running inside a Docker container.+getInContainer :: (MonadIO m) => m Bool+getInContainer =+ do maybeEnvVar <- liftIO (lookupEnv sandboxIDEnvVar)+ 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)+ => Config+ -> Maybe (Path Abs Dir)+ -> FilePath+ -> [String]+ -> [(String,String)]+ -> IO ()+ -> m ()+runContainerAndExit config+ mprojectRoot+ cmnd+ args+ envVars+ successPostAction =+ do envOverride <- getEnvOverride (configPlatform config)+ checkDockerVersion envOverride+ uidOut <- readProcessStdout Nothing envOverride "id" ["-u"]+ gidOut <- readProcessStdout Nothing envOverride "id" ["-g"]+ (dockerHost,dockerCertPath,dockerTlsVerify) <-+ liftIO ((,,) <$> lookupEnv "DOCKER_HOST"+ <*> lookupEnv "DOCKER_CERT_PATH"+ <*> lookupEnv "DOCKER_TLS_VERIFY")+ (isStdinTerminal,isStdoutTerminal,isStderrTerminal) <-+ liftIO ((,,) <$> hIsTerminalDevice stdin+ <*> hIsTerminalDevice stdout+ <*> hIsTerminalDevice stderr)+ pwd <- getWorkingDir+ when (maybe False (isPrefixOf "tcp://") dockerHost &&+ maybe False (isInfixOf "boot2docker") dockerCertPath)+ ($logWarn "WARNING: Using boot2docker is NOT supported, and not likely to perform well.")+ let image = dockerImage docker+ maybeImageInfo <- inspect envOverride image+ imageInfo <- case maybeImageInfo of+ Just ii -> return ii+ Nothing+ | dockerAutoPull docker ->+ do pullImage pwd envOverride docker image+ mii2 <- inspect envOverride image+ case mii2 of+ Just ii2 -> return ii2+ Nothing -> throwM (InspectFailedException image)+ | otherwise -> throwM (NotPulledException image)+ let uid = dropWhileEnd isSpace (decodeUtf8 uidOut)+ gid = dropWhileEnd isSpace (decodeUtf8 gidOut)+ imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo))+ (sandboxID,oldImage) =+ case lookupImageEnv sandboxIDEnvVar imageEnvVars of+ Just x -> (x,False)+ Nothing ->+ --EKB TODO: remove this and oldImage after lts-1.x images no longer in use+ let sandboxName = maybe "default" id (lookupImageEnv "SANDBOX_NAME" imageEnvVars)+ maybeImageCabalRemoteRepoName = lookupImageEnv "CABAL_REMOTE_REPO_NAME" imageEnvVars+ maybeImageStackageSlug = lookupImageEnv "STACKAGE_SLUG" imageEnvVars+ maybeImageStackageDate = lookupImageEnv "STACKAGE_DATE" imageEnvVars+ in (case (maybeImageStackageSlug,maybeImageStackageDate) of+ (Just stackageSlug,_) -> sandboxName ++ "_" ++ stackageSlug+ (_,Just stackageDate) -> sandboxName ++ "_" ++ stackageDate+ _ -> sandboxName ++ maybe "" ("_" ++) maybeImageCabalRemoteRepoName+ ,True)+ sandboxIDDir <- parseRelDir (sandboxID ++ "/")+ let stackRoot = configStackRoot config+ sandboxDir = projectDockerSandboxDir projectRoot+ sandboxSandboxDir = sandboxDir </> $(mkRelDir ".sandbox/") </> sandboxIDDir+ sandboxHomeDir = sandboxDir </> homeDirName+ sandboxRepoDir = sandboxDir </> sandboxIDDir+ sandboxSubdirs = map (\d -> sandboxRepoDir </> d)+ sandboxedHomeSubdirectories+ isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal+ execDockerProcess =+ do mapM_ (createDirectoryIfMissing True)+ (concat [[toFilePath sandboxHomeDir+ ,toFilePath sandboxSandboxDir] +++ map toFilePath sandboxSubdirs])+ execProcessAndExit+ envOverride+ "docker"+ (concat+ [["run"+ ,"--net=host"+ ,"-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+ ,"-v",trimTrailingPathSep sandboxHomeDir ++ ":" ++ trimTrailingPathSep sandboxRepoDir]+ ,if oldImage+ then ["-e",sandboxIDEnvVar ++ "=" ++ sandboxID+ ,"--entrypoint=/root/entrypoint.sh"]+ else []+ ,case (dockerPassHost docker,dockerHost) of+ (True,Just x@('u':'n':'i':'x':':':'/':'/':s)) -> ["-e","DOCKER_HOST=" ++ x+ ,"-v",s ++ ":" ++ s]+ (True,Just x) -> ["-e","DOCKER_HOST=" ++ x]+ (True,Nothing) -> ["-v","/var/run/docker.sock:/var/run/docker.sock"]+ (False,_) -> []+ ,case (dockerPassHost docker,dockerCertPath) of+ (True,Just x) -> ["-e","DOCKER_CERT_PATH=" ++ x+ ,"-v",x ++ ":" ++ x]+ _ -> []+ ,case (dockerPassHost docker,dockerTlsVerify) of+ (True,Just x )-> ["-e","DOCKER_TLS_VERIFY=" ++ x]+ _ -> []+ ,concatMap sandboxSubdirArg sandboxSubdirs+ ,concatMap mountArg (dockerMount docker)+ ,case dockerContainerName docker of+ Just name -> ["--name=" ++ name]+ Nothing -> []+ ,if dockerDetach docker+ then ["-d"]+ else concat [["--rm" | not (dockerPersist docker)]+ ,["-t" | isTerm]+ ,["-i" | isTerm]]+ ,dockerRunArgs docker+ ,[image]+ ,map (\(k,v) -> k ++ "=" ++ v) envVars+ ,[cmnd]+ ,args])+ successPostAction+ liftIO (do updateDockerImageLastUsed config+ (iiId imageInfo)+ (toFilePath projectRoot)+ execDockerProcess)++ where+ lookupImageEnv name vars =+ case lookup name vars of+ Just ('=':val) -> Just val+ _ -> Nothing+ mountArg (Mount host container) = ["-v",host ++ ":" ++ container]+ sandboxSubdirArg subdir = ["-v",trimTrailingPathSep subdir++ ":" ++ trimTrailingPathSep subdir]+ trimTrailingPathSep = dropWhileEnd isPathSeparator . toFilePath+ projectRoot = fromMaybeProjectRoot mprojectRoot+ docker = configDocker config++-- | Clean-up old docker images and containers.+cleanup :: (MonadLogger m,MonadIO m,MonadThrow m) => Config -> CleanupOpts -> m ()+cleanup config opts =+ do envOverride <- getEnvOverride (configPlatform config)+ checkDockerVersion envOverride+ let runDocker = readProcessStdout Nothing envOverride "docker"+ imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"]+ danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"]+ runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"]+ restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"]+ exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"]+ pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"]+ let imageRepos = parseImagesOut imagesOut+ danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut)+ runningContainers = parseContainersOut runningContainersOut +++ parseContainersOut restartingContainersOut+ stoppedContainers = parseContainersOut exitedContainersOut +++ parseContainersOut pausedContainersOut+ inspectMap <- inspects envOverride+ (Map.keys imageRepos +++ danglingImageHashes +++ map fst stoppedContainers +++ map fst runningContainers)+ (imagesLastUsed,curTime) <-+ liftIO ((,) <$> getDockerImagesLastUsed config+ <*> getZonedTime)+ let planWriter = buildPlan curTime+ imagesLastUsed+ imageRepos+ danglingImageHashes+ stoppedContainers+ runningContainers+ inspectMap+ plan = toLazyByteString (execWriter planWriter)+ plan' <- case dcAction opts of+ CleanupInteractive ->+ liftIO (editByteString (intercalate "-" [stackProgName+ ,dockerCmdName+ ,dockerCleanupCmdName+ ,"plan"])+ plan)+ CleanupImmediate -> return plan+ CleanupDryRun -> do liftIO (LBS.hPut stdout plan)+ return LBS.empty+ mapM_ (performPlanLine envOverride)+ (reverse (filter filterPlanLine (lines (LBS.unpack plan'))))+ allImageHashesOut <- runDocker ["images","-aq","--no-trunc"]+ liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut)))+ where+ filterPlanLine line =+ case line of+ c:_ | isSpace c -> False+ _ -> True+ performPlanLine envOverride line =+ case filter (not . null) (words (takeWhile (/= '#') line)) of+ [] -> return ()+ (c:_):t:v:_ ->+ do args <- if | toUpper c == 'R' && t == imageStr ->+ do $logInfo (concatT ["Removing image: '",v,"'"])+ return ["rmi",v]+ | toUpper c == 'R' && t == containerStr ->+ do $logInfo (concatT ["Removing container: '",v,"'"])+ return ["rm","-f",v]+ | otherwise -> throwM (InvalidCleanupCommandException line)+ e <- liftIO (try (callProcess Nothing envOverride "docker" args))+ case e of+ Left (ProcessExitedUnsuccessfully _ _) ->+ $logError (concatT ["Could not remove: '",v,"'"])+ Right () -> return ()+ _ -> throwM (InvalidCleanupCommandException line)+ parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8+ where parseImageRepo :: String -> (String, [String])+ parseImageRepo line =+ case words line of+ repo:tag:hash:_+ | repo == "<none>" -> (hash,[])+ | tag == "<none>" -> (hash,[repo])+ | otherwise -> (hash,[repo ++ ":" ++ tag])+ _ -> throw (InvalidImagesOutputException line)+ parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8+ where parseContainer line =+ case words line of+ hash:image:rest -> (hash,(image,last rest))+ _ -> throw (InvalidPSOutputException line)+ buildPlan curTime+ imagesLastUsed+ imageRepos+ danglingImageHashes+ stoppedContainers+ runningContainers+ inspectMap =+ do case dcAction opts of+ CleanupInteractive ->+ do buildStrLn+ (concat+ ["# STACK DOCKER CLEANUP PLAN"+ ,"\n#"+ ,"\n# When you leave the editor, the lines in this plan will be processed."+ ,"\n#"+ ,"\n# Lines that begin with 'R' denote an image or container that will be."+ ,"\n# removed. You may change the first character to/from 'R' to remove/keep"+ ,"\n# and image or container that would otherwise be kept/removed."+ ,"\n#"+ ,"\n# To cancel the cleanup, delete all lines in this file."+ ,"\n#"+ ,"\n# By default, the following images/containers will be removed:"+ ,"\n#"])+ buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used"+ buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created"+ buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created"+ buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created"+ buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created"+ buildStrLn+ (concat+ ["#"+ ,"\n# The default plan can be adjusted using command-line arguments."+ ,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] +++ " --help' for details."+ ,"\n#"])+ _ -> buildStrLn+ (unlines+ ["# Lines that begin with 'R' denote an image or container that will be."+ ,"# removed."])+ buildSection "KNOWN IMAGES (pulled/used by stack)"+ imagesLastUsed+ buildKnownImage+ buildSection "UNKNOWN IMAGES (not managed by stack)"+ (sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m)+ imageRepos+ imagesLastUsed)))+ buildUnknownImage+ buildSection "DANGLING IMAGES (no named references and not depended on by other images)"+ (sortCreated (map (,()) danglingImageHashes))+ buildDanglingImage+ buildSection "STOPPED CONTAINERS"+ (sortCreated stoppedContainers)+ (buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts))+ buildSection "RUNNING CONTAINERS"+ (sortCreated runningContainers)+ (buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts))+ where+ buildDefault accessor description =+ case accessor opts of+ Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".")+ Nothing -> return ()+ sortCreated l =+ reverse (sortBy (\(_,_,a) (_,_,b) -> compare a b)+ (catMaybes (map (\(h,r) -> fmap (\ii -> (h,r,iiCreated ii))+ (Map.lookup h inspectMap))+ l)))+ buildSection sectionHead items itemBuilder =+ do let (anyWrote,b) = runWriter (forM items itemBuilder)+ if or anyWrote+ then do buildSectionHead sectionHead+ tell b+ else return ()+ buildKnownImage (imageHash,lastUsedProjects) =+ case Map.lookup imageHash imageRepos of+ Just repos@(_:_) ->+ do case lastUsedProjects of+ (l,_):_ -> forM_ repos (buildImageTime (dcRemoveKnownImagesLastUsedDaysAgo opts) l)+ _ -> forM_ repos buildKeepImage+ forM_ lastUsedProjects buildProject+ buildInspect imageHash+ return True+ _ -> return False+ buildUnknownImage (hash, repos, created) =+ case repos of+ [] -> return False+ _ -> do forM_ repos (buildImageTime (dcRemoveUnknownImagesCreatedDaysAgo opts) created)+ buildInspect hash+ return True+ buildDanglingImage (hash, (), created) =+ do buildImageTime (dcRemoveDanglingImagesCreatedDaysAgo opts) created hash+ buildInspect hash+ return True+ buildContainer removeAge (hash,(image,name),created) =+ do let display = (name ++ " (image: " ++ image ++ ")")+ buildTime containerStr removeAge created display+ buildInspect hash+ return True+ buildProject (lastUsedTime, projectPath) =+ buildInfo ("Last used " +++ showDaysAgo lastUsedTime +++ " in " +++ projectPath)+ buildInspect hash =+ case Map.lookup hash inspectMap of+ Just (Inspect{iiCreated,iiVirtualSize}) ->+ buildInfo ("Created " +++ showDaysAgo iiCreated +++ maybe ""+ (\s -> " (size: " +++ printf "%g" (fromIntegral s / 1024.0 / 1024.0 :: Float) +++ "M)")+ iiVirtualSize)+ Nothing -> return ()+ showDays days =+ case days of+ 0 -> "today"+ 1 -> "yesterday"+ n -> show n ++ " days ago"+ showDaysAgo oldTime = showDays (daysAgo oldTime)+ daysAgo oldTime =+ let ZonedTime (LocalTime today _) zone = curTime+ LocalTime oldDay _ = utcToLocalTime zone oldTime+ in diffDays today oldDay+ buildImageTime = buildTime imageStr+ buildTime t removeAge time display =+ case removeAge of+ Just d | daysAgo time >= d -> buildStrLn ("R " ++ t ++ " " ++ display)+ _ -> buildKeep t display+ buildKeep t d = buildStrLn (" " ++ t ++ " " ++ d)+ buildKeepImage = buildKeep imageStr+ buildSectionHead s = buildStrLn ("\n#\n# " ++ s ++ "\n#\n")+ buildInfo = buildStrLn . (" # " ++)+ buildStrLn l = do buildStr l+ tell (charUtf8 '\n')+ buildStr = tell . stringUtf8++ imageStr = "image"+ containerStr = "container"++-- | Inspect Docker image or container.+inspect :: (MonadIO m,MonadThrow m) => EnvOverride -> String -> m (Maybe Inspect)+inspect envOverride image =+ do results <- inspects envOverride [image]+ case Map.toList results of+ [] -> return Nothing+ [(_,i)] -> return (Just i)+ _ -> throwM (InvalidInspectOutputException "expect a single result")++-- | Inspect multiple Docker images and/or containers.+inspects :: (MonadIO m,MonadThrow m) => EnvOverride -> [String] -> m (Map String Inspect)+inspects _ [] = return Map.empty+inspects envOverride images =+ do maybeInspectOut <- tryProcessStdout Nothing envOverride "docker" ("inspect" : images)+ case maybeInspectOut of+ Right inspectOut ->+ -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8+ case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of+ Left msg -> throwM (InvalidInspectOutputException msg)+ Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))+ Left (ProcessExitedUnsuccessfully _ _) -> return Map.empty++-- | Pull latest version of configured Docker image from registry.+pull :: (MonadLogger m,MonadIO m,MonadThrow m) => Config -> m ()+pull config =+ do envOverride <- getEnvOverride (configPlatform config)+ checkDockerVersion envOverride+ pwd <- getWorkingDir+ pullImage pwd 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 =+ do $logInfo (concatT ["Pulling image from registry: '",image,"'"])+ when (dockerRegistryLogin docker)+ (do $logInfo "You may need to log in."+ runIn+ pwd+ "docker"+ envOverride+ (concat+ [["login"]+ ,maybe [] (\u -> ["--username=" ++ u]) (dockerRegistryUsername docker)+ ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)+ ,[takeWhile (/= '/') image]])+ Nothing)+ 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 envOverride =+ do dockerExists <- doesExecutableExist envOverride "docker"+ when (not dockerExists)+ (throwM DockerNotInstalledException)+ dockerVersionOut <- readProcessStdout Nothing envOverride "docker" ["--version"]+ case words (decodeUtf8 dockerVersionOut) of+ (_:_:v:_) ->+ case parseVersionFromString (dropWhileEnd (== ',') v) of+ Just v'+ | v' < minimumDockerVersion ->+ throwM (DockerTooOldException minimumDockerVersion v')+ | v' `elem` prohibitedDockerVersions ->+ throwM (DockerVersionProhibitedException prohibitedDockerVersions v')+ | otherwise ->+ return ()+ _ -> throwM InvalidVersionOutputException+ _ -> throwM InvalidVersionOutputException+ where minimumDockerVersion = $(mkVersion "1.3.0")+ prohibitedDockerVersions = [$(mkVersion "1.2.0")]++-- | Run a process, then exit with the same exit code.+execProcessAndExit :: EnvOverride -> FilePath -> [String] -> IO () -> IO ()+execProcessAndExit envOverride cmnd args successPostAction =+ do (_, _, _, h) <- Proc.createProcess (Proc.proc cmnd args){Proc.delegate_ctlc = True+ ,Proc.env = envHelper envOverride}+#ifndef mingw32_HOST_OS+ _ <- installHandler sigTERM (Catch (Proc.terminateProcess h)) Nothing+#endif+ exitCode <- Proc.waitForProcess h+ when (exitCode == ExitSuccess)+ successPostAction+ exitWith exitCode++-- | Remove the project's Docker sandbox.+reset :: (MonadIO m) => Maybe (Path Abs Dir) -> Bool -> m ()+reset maybeProjectRoot keepHome =+ liftIO (removeDirectoryContents+ (projectDockerSandboxDir projectRoot)+ [homeDirName | keepHome]+ [])+ where projectRoot = fromMaybeProjectRoot maybeProjectRoot++-- | Remove the contents of a directory, without removing the directory itself.+-- This is used instead of 'FS.removeTree' to clear bind-mounted directories, since+-- removing the root of the bind-mount won't work.+removeDirectoryContents :: Path Abs Dir -- ^ Directory to remove contents of+ -> [Path Rel Dir] -- ^ Top-level directory names to exclude from removal+ -> [Path Rel File] -- ^ Top-level file names to exclude from removal+ -> IO ()+removeDirectoryContents path excludeDirs excludeFiles =+ do isRootDir <- doesDirectoryExist (toFilePath path)+ when isRootDir+ (do (lsd,lsf) <- listDirectory path+ forM_ lsd+ (\d -> unless (dirname d `elem` excludeDirs)+ (removeDirectoryRecursive (toFilePath d)))+ forM_ lsf+ (\f -> unless (filename f `elem` excludeFiles)+ (removeFile (toFilePath f))))++-- | Subdirectories of the home directory to sandbox between GHC/Stackage versions.+sandboxedHomeSubdirectories :: [Path Rel Dir]+sandboxedHomeSubdirectories =+ [$(mkRelDir ".ghc/")+ ,$(mkRelDir ".cabal/")+ ,$(mkRelDir ".ghcjs/")]++-- | 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 ())++-- | Options parser configuration for Docker.+dockerOptsParser :: Bool -> Parser DockerOptsMonoid+dockerOptsParser showOptions =+ DockerOptsMonoid+ <$> pure Nothing+ <*> maybeBoolFlags dockerCmdName+ "using a Docker container"+ hide+ <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>+ hide <>+ metavar "NAME" <>+ help "Docker repository name") <|>+ (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>+ hide <>+ metavar "IMAGE" <>+ help "Exact Docker image ID (overrides docker-repo)") <|>+ pure Nothing)+ <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)+ "registry requires login"+ hide+ <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>+ hide <>+ metavar "USERNAME" <>+ help "Docker registry username")+ <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>+ hide <>+ metavar "PASSWORD" <>+ help "Docker registry password")+ <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)+ "automatic pulling latest version of image"+ hide+ <*> maybeBoolFlags (dockerOptName dockerDetachArgName)+ "running a detached Docker container"+ hide+ <*> maybeBoolFlags (dockerOptName dockerPersistArgName)+ "not deleting container after it exits"+ hide+ <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>+ hide <>+ metavar "NAME" <>+ help "Docker container name")+ <*> wordsStrOption (long (dockerOptName dockerRunArgsArgName) <>+ hide <>+ value [] <>+ metavar "'ARG1 [ARG2 ...]'" <>+ help "Additional arguments to pass to 'docker run'")+ <*> many (option auto (long (dockerOptName dockerMountArgName) <>+ hide <>+ metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>+ help ("Mount volumes from host in container " +++ "(may specify mutliple times)")))+ <*> maybeBoolFlags (dockerOptName dockerPassHostArgName)+ "passing Docker daemon connection information into container"+ hide+ <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>+ hide <>+ metavar "PATH" <>+ help "Location of image usage tracking database")+ where+ dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName+ maybeStrOption = optional . option str+ wordsStrOption = option (fmap words str)+ hide = if showOptions+ then idm+ else internal <> hidden++-- | Interprets DockerOptsMonoid options.+dockerOptsFromMonoid :: Maybe Project -> Path Abs Dir -> DockerOptsMonoid -> DockerOpts+dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = DockerOpts+ {dockerEnable = fromMaybe (fromMaybe False dockerMonoidExists) dockerMonoidEnable+ ,dockerImage =+ let defaultTag =+ case mproject of+ Nothing -> ""+ Just proj ->+ case projectResolver proj of+ ResolverSnapshot n@(LTS _ _) -> ":" ++ (T.unpack (renderSnapName n))+ _ -> throw (ResolverNotSupportedException (projectResolver proj))+ in case dockerMonoidRepoOrImage of+ Nothing -> "fpco/dev" ++ defaultTag+ Just (DockerMonoidImage image) -> image+ Just (DockerMonoidRepo repo) ->+ case find (`elem` (":@" :: String)) repo of+ Just _ -> -- Repo already specified a tag or digest, so don't append default+ repo+ Nothing -> repo ++ defaultTag+ ,dockerRegistryLogin = fromMaybe (isJust (emptyToNothing dockerMonoidRegistryUsername))+ dockerMonoidRegistryLogin+ ,dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername+ ,dockerRegistryPassword = emptyToNothing dockerMonoidRegistryPassword+ ,dockerAutoPull = fromMaybe False dockerMonoidAutoPull+ ,dockerDetach = fromMaybe False dockerMonoidDetach+ ,dockerPersist = fromMaybe False dockerMonoidPersist+ ,dockerContainerName = emptyToNothing dockerMonoidContainerName+ ,dockerRunArgs = dockerMonoidRunArgs+ ,dockerMount = dockerMonoidMount+ ,dockerPassHost = fromMaybe False dockerMonoidPassHost+ ,dockerDatabasePath =+ case dockerMonoidDatabasePath of+ Nothing -> stackRoot </> $(mkRelFile "docker.db")+ Just fp -> case parseAbsFile fp of+ Left e -> throw (InvalidDatabasePathException e)+ Right p -> p+ }+ where emptyToNothing Nothing = Nothing+ emptyToNothing (Just s) | null s = Nothing+ | otherwise = Just s++-- | Convenience function to decode ByteString to String.+decodeUtf8 :: BS.ByteString -> String+decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs))++-- | Convenience function constructing message for @$log*@.+concatT :: [String] -> Text+concatT = T.pack . concat++-- | Fail with friendly error if project root not set.+fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir+fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)++-- | Environment variable 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"++-- | Command-line argument for "docker"+dockerCmdName :: String+dockerCmdName = "docker"++-- | Command-line argument for @docker pull@.+dockerPullCmdName :: String+dockerPullCmdName = "pull"++-- | Command-line argument for @docker cleanup@.+dockerCleanupCmdName :: String+dockerCleanupCmdName = "cleanup"++-- | 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+ , dcRemoveKnownImagesLastUsedDaysAgo :: !(Maybe Integer)+ , dcRemoveUnknownImagesCreatedDaysAgo :: !(Maybe Integer)+ , dcRemoveDanglingImagesCreatedDaysAgo :: !(Maybe Integer)+ , dcRemoveStoppedContainersCreatedDaysAgo :: !(Maybe Integer)+ , dcRemoveRunningContainersCreatedDaysAgo :: !(Maybe Integer) }+ deriving (Show)++-- | Cleanup action.+data CleanupAction = CleanupInteractive+ | CleanupImmediate+ | CleanupDryRun+ deriving (Show)++-- | Parsed result of @docker inspect@.+data Inspect = Inspect+ {iiConfig :: ImageConfig+ ,iiCreated :: UTCTime+ ,iiId :: String+ ,iiVirtualSize :: Maybe Integer }+ deriving (Show)++-- | Parse @docker inspect@ output.+instance FromJSON Inspect where+ parseJSON v =+ do o <- parseJSON v+ (Inspect <$> o .: T.pack "Config"+ <*> o .: T.pack "Created"+ <*> o .: T.pack "Id"+ <*> o .:? T.pack "VirtualSize")++-- | Parsed @Config@ section of @docker inspect@ output.+data ImageConfig = ImageConfig+ {icEnv :: [String]}+ deriving (Show)++-- | Parse @Config@ section of @docker inspect@ output.+instance FromJSON ImageConfig where+ parseJSON v =+ do o <- parseJSON v+ (ImageConfig <$> o .:? T.pack "Env" .!= [])++-- | Exceptions thrown by Stack.Docker.+data StackDockerException+ = DockerMustBeEnabledException+ -- ^ Docker must be enabled to use the command.+ | OnlyOnHostException+ -- ^ Command must be run on host OS (not in a container).+ | InspectFailedException String+ -- ^ @docker inspect@ failed.+ | NotPulledException String+ -- ^ Image does not exist.+ | InvalidCleanupCommandException String+ -- ^ Input to @docker cleanup@ has invalid command.+ | InvalidImagesOutputException String+ -- ^ Invalid output from @docker images@.+ | InvalidPSOutputException String+ -- ^ Invalid output from @docker ps@.+ | InvalidInspectOutputException String+ -- ^ Invalid output from @docker inspect@.+ | PullFailedException String+ -- ^ Could not pull a Docker image.+ | DockerTooOldException Version Version+ -- ^ Installed version of @docker@ below minimum version.+ | DockerVersionProhibitedException [Version] Version+ -- ^ Installed version of @docker@ is prohibited.+ | InvalidVersionOutputException+ -- ^ Invalid output from @docker --version@.+ | HostStackTooOldException Version (Maybe Version)+ -- ^ Version of @stack@ on host is too old for version in image.+ | ContainerStackTooOldException Version Version+ -- ^ Version of @stack@ in container/image is too old for version on host.+ | ResolverNotSupportedException Resolver+ -- ^ Only LTS resolvers are supported for default image tag.+ | CannotDetermineProjectRootException+ -- ^ Can't determine the project root (where to put @.docker-sandbox@).+ | DockerNotInstalledException+ -- ^ @docker --version@ failed.+ | InvalidDatabasePathException SomeException+ -- ^ Invalid global database path.+ deriving (Typeable)++-- | Exception instance for StackDockerException.+instance Exception StackDockerException++-- | Show instance for StackDockerException.+instance Show StackDockerException where+ show DockerMustBeEnabledException =+ concat ["Docker must be enabled in your ",toFilePath stackDotYaml," to use this command."]+ show OnlyOnHostException =+ "This command must be run on host OS (not in a Docker container)."+ show (InspectFailedException image) =+ concat ["'docker inspect' failed for image after pull: ",image,"."]+ show (NotPulledException image) =+ concat ["The Docker image referenced by "+ ,toFilePath stackDotYaml+ ," has not\nbeen downloaded:\n "+ ,image+ ,"\n\nRun '"+ ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]+ ,"' to download it, then try again."]+ show (InvalidCleanupCommandException line) =+ concat ["Invalid line in cleanup commands: '",line,"'."]+ show (InvalidImagesOutputException line) =+ concat ["Invalid 'docker images' output line: '",line,"'."]+ show (InvalidPSOutputException line) =+ concat ["Invalid 'docker ps' output line: '",line,"'."]+ show (InvalidInspectOutputException msg) =+ concat ["Invalid 'docker inspect' output: ",msg,"."]+ show (PullFailedException image) =+ concat ["Could not pull Docker image:\n "+ ,image+ ,"\nThere may not be an image on the registry for your resolver's LTS version in\n"+ ,toFilePath stackDotYaml+ ,"."]+ show (DockerTooOldException minVersion haveVersion) =+ concat ["Minimum docker version '"+ ,versionString minVersion+ ,"' is required (you have '"+ ,versionString haveVersion+ ,"')."]+ show (DockerVersionProhibitedException prohibitedVersions haveVersion) =+ concat ["These Docker versions are prohibited (you have '"+ ,versionString haveVersion+ ,"'): "+ ,concat (intersperse ", " (map versionString prohibitedVersions))+ ,"."]+ show InvalidVersionOutputException =+ "Cannot get Docker version (invalid 'docker --version' output)."+ show (HostStackTooOldException minVersion (Just hostVersion)) =+ concat ["The host's version of '"+ ,stackProgName+ ,"' is too old for this Docker image.\nVersion "+ ,versionString minVersion+ ," is required; you have "+ ,versionString hostVersion+ ,"."]+ show (HostStackTooOldException minVersion Nothing) =+ concat ["The host's version of '"+ ,stackProgName+ ,"' is too old.\nVersion "+ ,versionString minVersion+ ," is required."]+ show (ContainerStackTooOldException requiredVersion containerVersion) =+ concat ["The Docker container's version of '"+ ,stackProgName+ ,"' is too old.\nVersion "+ ,versionString requiredVersion+ ," is required; the container has "+ ,versionString containerVersion+ ,"."]+ show (ResolverNotSupportedException resolver) =+ concat ["Resolver not supported for Docker images:\n "+ ,show resolver+ ,"\nUse an LTS resolver, or set the '"+ ,T.unpack dockerImageArgName+ ,"' explicitly, in "+ ,toFilePath stackDotYaml+ ,"."]+ show CannotDetermineProjectRootException =+ "Cannot determine project root directory for Docker sandbox."+ show DockerNotInstalledException=+ "Cannot find 'docker' in PATH. Is Docker installed?"+ show (InvalidDatabasePathException ex) =+ concat ["Invalid database path: ",show ex]
+ src/Stack/Docker/GlobalDB.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings,+ GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving,+ RankNTypes, NamedFieldPuns #-}++-- | Global sqlite database shared by all projects.+-- Warning: this is currently only accessible from __outside__ a Docker container.+module Stack.Docker.GlobalDB+ (updateDockerImageLastUsed+ ,getDockerImagesLastUsed+ ,pruneDockerImagesLastUsed+ ,DockerImageLastUsed+ ,DockerImageProjectId)+ where++import Control.Exception (IOException,catch,throwIO)+import Control.Monad (forM_)+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.Trans.Resource (ResourceT)+import Data.List (sortBy, isInfixOf, stripPrefix)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Time.Clock (UTCTime,getCurrentTime)+import Database.Persist+import Database.Persist.Sqlite+import Database.Persist.TH+import Path (toFilePath, parent)+import System.Directory (createDirectoryIfMissing)+import Stack.Types.Config+import Stack.Types.Docker++share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase|+DockerImageProject+ imageHash String+ projectPath FilePath+ lastUsedTime UTCTime+ DockerImageProjectPathKey imageHash projectPath+ deriving Show+|]++-- | Update last used time and project for a Docker image hash.+updateDockerImageLastUsed :: Config -> String -> FilePath -> IO ()+updateDockerImageLastUsed config imageId projectPath =+ do curTime <- getCurrentTime+ _ <- withGlobalDB config (upsert (DockerImageProject imageId projectPath curTime) [])+ return ()++-- | Get a list of Docker image hashes and when they were last used.+getDockerImagesLastUsed :: Config -> IO [DockerImageLastUsed]+getDockerImagesLastUsed config =+ do imageProjects <- withGlobalDB config (selectList [] [Asc DockerImageProjectLastUsedTime])+ return (sortBy (flip sortImage)+ (Map.toDescList (Map.fromListWith (++)+ (map mapImageProject imageProjects))))+ where+ mapImageProject (Entity _ imageProject) =+ (dockerImageProjectImageHash imageProject+ ,[(dockerImageProjectLastUsedTime imageProject+ ,dockerImageProjectProjectPath imageProject)])+ sortImage (_,(a,_):_) (_,(b,_):_) = compare a b+ sortImage _ _ = EQ++-- | Given a list of all existing Docker images, remove any that no longer exist from+-- the database.+pruneDockerImagesLastUsed :: Config -> [String] -> IO ()+pruneDockerImagesLastUsed config existingHashes =+ withGlobalDB config go+ where go = do l <- selectList [] []+ forM_ l (\(Entity k (DockerImageProject{dockerImageProjectImageHash = h})) ->+ if h `elem` existingHashes+ then return ()+ else delete k)++-- | Run an action with the global database. This performs any needed migrations as well.+withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a+withGlobalDB config action =+ do let db = dockerDatabasePath (configDocker config)+ createDirectoryIfMissing True (toFilePath (parent db))+ runSqlite (T.pack (toFilePath db))+ (do _ <- runMigrationSilent migrateTables+ action)+ `catch` \ex -> do+ let str = show ex+ stripSuffix x = fmap reverse . stripPrefix x . reverse+ str' = fromMaybe str $ stripPrefix "user error (" $+ fromMaybe str $ stripSuffix ")" str+ if "ErrorReadOnly" `isInfixOf` str+ then fail $ str' +++ " This likely indicates that your DB file, " +++ toFilePath db ++ ", has incorrect permissions or ownership."+ else throwIO (ex :: IOException)++-- | Date and project path where Docker image hash last used.+type DockerImageLastUsed = (String, [(UTCTime, FilePath)])
+ src/Stack/Fetch.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-- | Functionality for downloading packages securely for cabal's usage.++module Stack.Fetch+ ( unpackPackages+ , unpackPackageIdents+ , resolvePackages+ , ResolvedPackage (..)+ , withCabalFiles+ , withCabalLoader+ ) where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Check as Tar+import Codec.Compression.GZip (decompress)+import Control.Applicative+import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.STM (TVar, atomically, modifyTVar,+ newTVarIO, readTVar,+ readTVarIO, writeTVar)+import Control.Monad (liftM, when, join, unless, void)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (asks)+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Control+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.List (intercalate)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.IO as T+import Data.Typeable (Typeable)+import Data.Word (Word64)+import Network.HTTP.Download+import Path+import Prelude -- Fix AMP warning+import Stack.GhcPkg+import Stack.PackageIndex+import Stack.Types+import System.Directory (canonicalizePath,+ createDirectoryIfMissing,+ doesDirectoryExist,+ renameDirectory)+import System.FilePath ((<.>))+import qualified System.FilePath as FP+import System.IO (IOMode (ReadMode),+ SeekMode (AbsoluteSeek),+ hSeek, withBinaryFile)++data FetchException+ = Couldn'tReadIndexTarball FilePath Tar.FormatError+ | Couldn'tReadPackageTarball FilePath SomeException+ | UnpackDirectoryAlreadyExists (Set FilePath)+ | CouldNotParsePackageSelectors [String]+ | UnknownPackageNames (Set PackageName)+ | UnknownPackageIdentifiers (Set PackageIdentifier)+ deriving Typeable+instance Exception FetchException++instance Show FetchException where+ show (Couldn'tReadIndexTarball fp err) = concat+ [ "There was an error reading the index tarball "+ , fp+ , ": "+ , show err+ ]+ show (Couldn'tReadPackageTarball fp err) = concat+ [ "There was an error reading the package tarball "+ , fp+ , ": "+ , show err+ ]+ show (UnpackDirectoryAlreadyExists dirs) = unlines+ $ "Unable to unpack due to already present directories:"+ : map (" " ++) (Set.toList dirs)+ show (CouldNotParsePackageSelectors strs) =+ "The following package selectors are not valid package names or identifiers: " +++ intercalate ", " strs+ show (UnknownPackageNames names) =+ "The following packages were not found in your indices: " +++ intercalate ", " (map packageNameString $ Set.toList names)+ show (UnknownPackageIdentifiers idents) =+ "The following package identifiers were not found in your indices: " +++ intercalate ", " (map packageIdentifierString $ Set.toList idents)++-- | Intended to work for the command line command.+unpackPackages :: (MonadIO m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadThrow m,MonadLogger m)+ => EnvOverride+ -> FilePath -- ^ destination+ -> [String] -- ^ names or identifiers+ -> m ()+unpackPackages menv dest input = do+ dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir+ (names, idents) <- case partitionEithers $ map parse input of+ ([], x) -> return $ partitionEithers x+ (errs, _) -> throwM $ CouldNotParsePackageSelectors errs+ resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)+ ToFetchResult toFetch alreadyUnpacked <- getToFetch dest' resolved+ unless (Map.null alreadyUnpacked) $+ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked+ unpacked <- fetchPackages Nothing toFetch+ F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> $logInfo $ T.pack $ concat+ [ "Unpacked "+ , packageIdentifierString ident+ , " to "+ , toFilePath dest''+ ]+ where+ -- Possible future enhancement: parse names as name + version range+ parse s =+ case parsePackageNameFromString s of+ Right x -> Right $ Left x+ Left _ ->+ case parsePackageIdentifierFromString s of+ Left _ -> Left s+ Right x -> Right $ Right x++-- | Ensure that all of the given package idents are unpacked into the build+-- unpack directory, and return the paths to all of the subdirectories.+unpackPackageIdents+ :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m)+ => EnvOverride+ -> Path Abs Dir -- ^ unpack directory+ -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157+ -> Set PackageIdentifier+ -> m (Map PackageIdentifier (Path Abs Dir))+unpackPackageIdents menv unpackDir mdistDir idents = do+ resolved <- resolvePackages menv idents Set.empty+ ToFetchResult toFetch alreadyUnpacked <- getToFetch unpackDir resolved+ nowUnpacked <- fetchPackages mdistDir toFetch+ return $ alreadyUnpacked <> nowUnpacked++data ResolvedPackage = ResolvedPackage+ { rpCache :: !PackageCache+ , rpIndex :: !PackageIndex+ }++-- | Resolve a set of package names and identifiers into @FetchPackage@ values.+resolvePackages :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)+ => EnvOverride+ -> Set PackageIdentifier+ -> Set PackageName+ -> m (Map PackageIdentifier ResolvedPackage)+resolvePackages menv idents0 names0 = do+ eres <- go+ case eres of+ Left _ -> do+ updateAllIndices menv+ go >>= either throwM return+ Right x -> return x+ where+ go = do+ caches <- getPackageCaches menv+ let versions = Map.fromListWith max $ map toTuple $ Map.keys caches+ (missing, idents1) = partitionEithers $ map+ (\name -> maybe (Left name ) (Right . PackageIdentifier name)+ (Map.lookup name versions))+ (Set.toList names0)+ return $ if null missing+ then goIdents caches $ idents0 <> Set.fromList idents1+ else Left $ UnknownPackageNames $ Set.fromList missing++ goIdents caches idents =+ case partitionEithers $ map (goIdent caches) $ Set.toList idents of+ ([], resolved) -> Right $ Map.fromList resolved+ (missing, _) -> Left $ UnknownPackageIdentifiers $ Set.fromList missing++ goIdent caches ident =+ case Map.lookup ident caches of+ Nothing -> Left ident+ Just (index, cache) -> Right (ident, ResolvedPackage+ { rpCache = cache+ , rpIndex = index+ })++data ToFetch = ToFetch+ { tfTarball :: !(Path Abs File)+ , tfDestDir :: !(Path Abs Dir)+ , tfUrl :: !T.Text+ , tfSize :: !(Maybe Word64)+ , tfSHA512 :: !(Maybe ByteString)+ , tfCabal :: !ByteString+ -- ^ Contents of the .cabal file+ }++data ToFetchResult = ToFetchResult+ { tfrToFetch :: !(Map PackageIdentifier ToFetch)+ , tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir))+ }++-- | Add the cabal files to a list of idents with their caches.+withCabalFiles+ :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)+ => IndexName+ -> [(PackageIdentifier, PackageCache, a)]+ -> (PackageIdentifier -> a -> ByteString -> IO b)+ -> m [b]+withCabalFiles name pkgs f = do+ indexPath <- configPackageIndex name+ liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->+ mapM (goPkg h) pkgs+ where+ goPkg h (ident, pc, tf) = do+ hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc+ cabalBS <- S.hGet h $ fromIntegral $ pcSize pc+ f ident tf cabalBS++-- | Provide a function which will load up a cabal @ByteString@ from the+-- package indices.+withCabalLoader+ :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env)+ => EnvOverride+ -> ((PackageIdentifier -> IO ByteString) -> m a)+ -> m a+withCabalLoader menv inner = do+ caches <- getPackageCaches menv+ env <- ask+ -- 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++-- | Figure out where to fetch from.+getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)+ => Path Abs Dir -- ^ directory to unpack into+ -> Map PackageIdentifier ResolvedPackage+ -> m ToFetchResult+getToFetch dest resolvedAll = do+ (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked $ Map.toList resolvedAll+ toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0+ return ToFetchResult+ { tfrToFetch = Map.unions toFetch1+ , tfrAlreadyUnpacked = Map.fromList unpacked+ }+ where+ checkUnpacked (ident, resolved) = do+ dirRel <- parseRelDir $ packageIdentifierString ident+ let destDir = dest </> dirRel+ exists <- liftIO $ doesDirectoryExist $ toFilePath destDir+ if exists+ then return $ Right (ident, destDir)+ else do+ let index = rpIndex resolved+ d = pcDownload $ rpCache resolved+ targz = T.pack $ packageIdentifierString ident ++ ".tar.gz"+ tarball <- configPackageTarball (indexName index) ident+ return $ Left (indexName index, [(ident, rpCache resolved, ToFetch+ { tfTarball = tarball+ , tfDestDir = destDir+ , tfUrl = case d of+ Just d' -> decodeUtf8 $ pdUrl d'+ Nothing -> indexDownloadPrefix index <> targz+ , tfSize = fmap pdSize d+ , tfSHA512 = fmap pdSHA512 d+ , tfCabal = S.empty -- filled in by goIndex+ })])++ goIndex (name, pkgs) =+ liftM Map.fromList $+ withCabalFiles name pkgs $ \ident tf cabalBS ->+ return (ident, tf { tfCabal = cabalBS })++-- | Download the given name,version pairs into the directory expected by cabal.+--+-- For each package it downloads, it will optionally unpack it to the given+-- @Path@ (if present). Note that unpacking is not simply a matter of+-- untarring, but also of grabbing the cabal file from the package index. The+-- destinations should not include package identifiers.+--+-- Returns the list of paths unpacked, including package identifiers. E.g.:+--+-- @+-- fetchPackages [("foo-1.2.3", Just "/some/dest")] ==> ["/some/dest/foo-1.2.3"]+-- @+--+-- Since 0.1.0.0+fetchPackages :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)+ => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157+ -> Map PackageIdentifier ToFetch+ -> m (Map PackageIdentifier (Path Abs Dir))+fetchPackages mdistDir toFetchAll = do+ connCount <- asks $ configConnectionCount . getConfig+ outputVar <- liftIO $ newTVarIO Map.empty++ parMapM_+ connCount+ (go outputVar)+ (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))+ -> (PackageIdentifier, ToFetch)+ -> m ()+ go outputVar (ident, toFetch) = do+ req <- parseUrl $ T.unpack $ tfUrl toFetch+ let destpath = tfTarball toFetch++ let toHashCheck bs = HashCheck SHA512 (C8.unpack 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"+ _ <- 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++ liftIO $ createDirectoryIfMissing True dest++ liftIO $ withBinaryFile fp ReadMode $ \h -> do+ -- Avoid using L.readFile, which is more likely to leak+ -- resources+ lbs <- L.hGetContents h+ let entries = fmap (either wrap wrap)+ $ Tar.checkTarbomb identStr+ $ Tar.read $ decompress lbs+ wrap :: Exception e => e -> FetchException+ wrap = Couldn'tReadPackageTarball fp . toException+ identStr = packageIdentifierString ident+ Tar.unpack dest entries++ case mdistDir of+ Nothing -> return ()+ -- See: https://github.com/fpco/stack/issues/157+ Just distDir -> do+ let inner = dest FP.</> identStr+ oldDist = inner FP.</> "dist"+ newDist = inner FP.</> toFilePath distDir+ exists <- doesDirectoryExist oldDist+ when exists $ do+ createDirectoryIfMissing True $ FP.takeDirectory newDist+ renameDirectory oldDist newDist++ let cabalFP =+ innerDest FP.</>+ packageNameString (packageIdentifierName ident)+ <.> "cabal"+ 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+ -> (a -> m ())+ -> f a+ -> m ()+parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs+parMapM_ cnt f xs0 = do+ var <- liftIO (newTVarIO $ F.toList xs0)++ -- See comment on similar line in Stack.Build+ runInBase <- liftBaseWith $ \run -> return (void . run)++ let worker = fix $ \loop -> join $ atomically $ do+ xs <- readTVar var+ case xs of+ [] -> return $ return ()+ x:xs' -> do+ writeTVar var xs'+ return $ do+ runInBase $ f x+ loop+ workers 1 = Concurrently worker+ workers i = Concurrently worker *> workers (i - 1)+ liftIO $ runConcurrently $ workers cnt
+ src/Stack/GhcPkg.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fno-warn-unused-do-bind #-}++-- | Functions for the GHC package database.++module Stack.GhcPkg+ (findGhcPkgId+ ,getGlobalDB+ ,EnvOverride+ ,envHelper+ ,createDatabase+ ,unregisterGhcPkgId+ ,getCabalPkgVer)+ where++import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import qualified Data.ByteString.Char8 as S8+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 Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)+import Prelude hiding (FilePath)+import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId))+import Stack.Types+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath)+import System.Process.Read++-- | Get the global package database+getGlobalDB :: (MonadIO m, MonadLogger m, MonadThrow m)+ => EnvOverride+ -> m (Path Abs Dir)+getGlobalDB menv = do+ -- This seems like a strange way to get the global package database+ -- location, but I don't know of a better one+ bs <- ghcPkg menv [] ["list", "--global"] >>= either throwM return+ let fp = S8.unpack $ stripTrailingColon $ firstLine bs+ liftIO (canonicalizePath fp) >>= parseAbsDir+ where+ stripTrailingColon bs+ | S8.null bs = bs+ | S8.last bs == ':' = S8.init bs+ | otherwise = bs+ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')++-- | Run the ghc-pkg executable+ghcPkg :: (MonadIO m, MonadLogger m)+ => EnvOverride+ -> [Path Abs Dir]+ -> [String]+ -> m (Either ProcessExitedUnsuccessfully S8.ByteString)+ghcPkg menv pkgDbs args = do+ $logDebug $ "Calling ghc-pkg with: " <> T.pack (show args')+ 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')+ return r+ where+ go = tryProcessStdout Nothing menv "ghc-pkg" args'+ args' = packageDbFlags pkgDbs ++ args++-- | Create a package database in the given directory, if it doesn't exist.+createDatabase :: (MonadIO m, MonadLogger m) => EnvOverride -> Path Abs Dir -> m ()+createDatabase menv db = do+ let db' = toFilePath db+ exists <- liftIO $ doesDirectoryExist db'+ unless exists $ do+ -- Creating the parent doesn't seem necessary, as ghc-pkg+ -- seems to be sufficiently smart. But I don't feel like+ -- finding out it isn't the hard way+ liftIO $ createDirectoryIfMissing True $ toFilePath $ parent db+ _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", db']+ return ()++-- | Get the necessary ghc-pkg flags for setting up the given package database+packageDbFlags :: [Path Abs Dir] -> [String]+packageDbFlags pkgDbs =+ "--no-user-package-db"+ : map (\x -> ("--package-db=" ++ toFilePath x)) pkgDbs++-- | Get the id of the package e.g. @foo-0.0.0-9c293923c0685761dcff6f8c3ad8f8ec@.+findGhcPkgId :: (MonadIO m, MonadLogger m)+ => EnvOverride+ -> [Path Abs Dir] -- ^ package databases+ -> PackageName+ -> m (Maybe GhcPkgId)+findGhcPkgId menv pkgDbs name = do+ result <-+ ghcPkg menv pkgDbs ["describe", packageNameString name]+ case result of+ Left{} ->+ return Nothing+ Right lbs -> do+ let mpid =+ fmap+ T.encodeUtf8+ (listToMaybe+ (mapMaybe+ (fmap stripCR .+ T.stripPrefix "id: ")+ (map T.decodeUtf8 (S8.lines lbs))))+ case mpid of+ Just !pid ->+ return (parseGhcPkgId pid)+ _ ->+ return Nothing+ where+ stripCR t =+ fromMaybe t (T.stripSuffix "\r" t)++unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+ => EnvOverride+ -> Path Abs Dir -- ^ package database+ -> GhcPkgId+ -> m ()+unregisterGhcPkgId menv pkgDb gid = do+ eres <- ghcPkg menv [pkgDb] args+ case eres of+ Left e -> $logWarn $ T.pack $ show e+ Right _ -> return ()+ where+ -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead+ args = ["unregister", "--user", "--force", packageIdentifierString $ ghcPkgIdPackageIdentifier gid]++-- | Get the version of Cabal from the global package database.+getCabalPkgVer :: (MonadThrow m,MonadIO m,MonadLogger m)+ => EnvOverride -> m PackageIdentifier+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 >>=+ maybe+ (throwM $ Couldn'tFindPkgId cabalName)+ (return . ghcPkgIdPackageIdentifier)+ where+ cabalName =+ $(mkPackageName "Cabal")
+ src/Stack/Package.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++-- | Dealing with Cabal.++module Stack.Package+ (readPackage+ ,readPackageBS+ ,readPackageDir+ ,readPackageUnresolved+ ,readPackageUnresolvedBS+ ,resolvePackage+ ,getCabalFileName+ ,Package(..)+ ,GetPackageFiles(..)+ ,PackageConfig(..)+ ,buildLogPath+ ,PackageException (..)+ ,resolvePackageDescription+ ,packageToolDependencies+ ,packageDependencies+ ,packageIdentifier)+ where++import Control.Exception hiding (try,catch)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger (MonadLogger,logWarn)+import Control.Monad.Reader+import qualified Data.ByteString as S+import Data.Data+import Data.Either+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Maybe.Extra+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Distribution.Compiler+import Distribution.InstalledPackageInfo (PError)+import qualified Distribution.ModuleName as Cabal+import Distribution.ModuleName (ModuleName)+import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)+import Distribution.PackageDescription hiding (FlagName)+import Distribution.PackageDescription.Parse+import Distribution.Simple.Utils+import Distribution.System (OS, Arch, Platform (..))+import Distribution.Version (intersectVersionRanges)+import Path as FL+import Path.Find+import Path.IO+import Prelude hiding (FilePath)+import Stack.Constants+import Stack.Types+import qualified Stack.Types.PackageIdentifier+import System.Directory (getDirectoryContents)+import System.FilePath (splitExtensions)+import qualified System.FilePath as FilePath+import System.IO.Error++-- | All exceptions thrown by the library.+data PackageException+ = PackageInvalidCabalFile (Maybe (Path Abs File)) PError+ | PackageNoCabalFileFound (Path Abs Dir)+ | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]+ | MismatchedCabalName (Path Abs File) PackageName+ deriving Typeable+instance Exception PackageException+instance Show PackageException where+ show (PackageInvalidCabalFile mfile err) =+ "Unable to parse cabal file" +++ (case mfile of+ Nothing -> ""+ Just file -> ' ' : toFilePath file) +++ ": " +++ show err+ show (PackageNoCabalFileFound dir) =+ "No .cabal file found in directory " +++ toFilePath dir+ show (PackageMultipleCabalFilesFound dir files) =+ "Multiple .cabal files found in directory " +++ toFilePath dir +++ ": " +++ intercalate ", " (map (toFilePath . filename) files)+ show (MismatchedCabalName fp name) = concat+ [ "cabal file "+ , toFilePath fp+ , " has a mismatched package name: "+ , packageNameString name+ ]++-- | Some package info.+data Package =+ Package {packageName :: !PackageName -- ^ Name of the package.+ ,packageVersion :: !Version -- ^ Version of the package+ ,packageFiles :: !GetPackageFiles+ ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.+ ,packageTools :: ![Dependency] -- ^ A build tool name.+ ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).+ ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.+ ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?+ ,packageTests :: !(Set Text) -- ^ names of test suites+ }+ deriving (Show,Typeable)++-- | Files that the package depends on, relative to package directory.+-- Argument is the location of the .cabal file+newtype GetPackageFiles = GetPackageFiles+ { getPackageFiles :: forall m. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)+ => Path Abs File+ -> m (Set (Path Abs File))+ }+instance Show GetPackageFiles where+ show _ = "<GetPackageFiles>"++-- | Get the identifier of the package.+packageIdentifier :: Package -> Stack.Types.PackageIdentifier.PackageIdentifier+packageIdentifier pkg =+ Stack.Types.PackageIdentifier.PackageIdentifier+ (packageName pkg)+ (packageVersion pkg)++-- | Package build configuration+data PackageConfig =+ PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?+ ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?+ ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.+ ,packageConfigGhcVersion :: !Version -- ^ GHC version+ ,packageConfigPlatform :: !Platform -- ^ host platform+ }+ deriving (Show,Typeable)++-- | Compares the package name.+instance Ord Package where+ compare = on compare packageName++-- | Compares the package name.+instance Eq Package where+ (==) = on (==) packageName++-- | Read the raw, unresolved package information.+readPackageUnresolved :: (MonadIO m, MonadThrow m)+ => Path Abs File+ -> m GenericPackageDescription+readPackageUnresolved cabalfp =+ liftIO (S.readFile (FL.toFilePath cabalfp))+ >>= readPackageUnresolvedBS (Just cabalfp)++-- | Read the raw, unresolved package information from a ByteString.+readPackageUnresolvedBS :: (MonadThrow m)+ => Maybe (Path Abs File)+ -> S.ByteString+ -> m GenericPackageDescription+readPackageUnresolvedBS mcabalfp bs =+ case parsePackageDescription chars of+ ParseFailed per ->+ throwM (PackageInvalidCabalFile mcabalfp per)+ ParseOk _ gpkg -> return gpkg+ where+ chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs))++ -- https://github.com/haskell/hackage-server/issues/351+ dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t++-- | Reads and exposes the package information+readPackage :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)+ => PackageConfig+ -> Path Abs File+ -> m Package+readPackage packageConfig cabalfp =+ resolvePackage packageConfig `liftM` readPackageUnresolved cabalfp++-- | Reads and exposes the package information, from a ByteString+readPackageBS :: (MonadThrow m)+ => PackageConfig+ -> S.ByteString+ -> m Package+readPackageBS packageConfig bs =+ resolvePackage packageConfig `liftM` readPackageUnresolvedBS Nothing bs++-- | Convenience wrapper around @readPackage@ that first finds the cabal file+-- in the given directory.+readPackageDir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)+ => PackageConfig+ -> Path Abs Dir+ -> m (Path Abs File, Package)+readPackageDir packageConfig dir = do+ cabalfp <- getCabalFileName dir+ pkg <- readPackage packageConfig cabalfp+ name <- parsePackageNameFromFilePath cabalfp+ when (packageName pkg /= name)+ $ throwM $ MismatchedCabalName cabalfp name+ return (cabalfp, pkg)++-- | Resolve a parsed cabal file into a 'Package'.+resolvePackage :: PackageConfig+ -> GenericPackageDescription+ -> Package+resolvePackage packageConfig gpkg = Package+ { packageName = name+ , packageVersion = fromCabalVersion (pkgVersion pkgId)+ , packageDeps = deps+ , packageFiles = GetPackageFiles $ \cabalfp -> do+ files <- runReaderT (packageDescFiles pkg) cabalfp+ return $ S.fromList $ cabalfp : files+ , packageTools = packageDescTools pkg+ , 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+ }++ where+ pkgId = package (packageDescription gpkg)+ name = fromCabalPackageName (pkgName pkgId)+ pkg = resolvePackageDescription packageConfig gpkg+ deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg)++-- | Get all dependencies of the package (buildable targets only).+packageDependencies :: PackageDescription -> Map PackageName VersionRange+packageDependencies =+ M.fromListWith intersectVersionRanges .+ concatMap (map (\dep -> ((depName dep),depRange dep)) .+ targetBuildDepends) .+ allBuildInfo'++-- | Get all build tool dependencies of the package (buildable targets only).+packageToolDependencies :: PackageDescription -> Map S.ByteString VersionRange+packageToolDependencies =+ M.fromList .+ concatMap (map (\dep -> ((packageNameByteString $ depName dep),depRange dep)) .+ buildTools) .+ allBuildInfo'++-- | Get all dependencies of the package (buildable targets only).+packageDescTools :: PackageDescription -> [Dependency]+packageDescTools = concatMap buildTools . allBuildInfo'++-- | This is a copy-paste from Cabal's @allBuildInfo@ function, but with the+-- @buildable@ test removed. The reason is that (surprise) Cabal is broken,+-- see: https://github.com/haskell/cabal/issues/1725+allBuildInfo' :: PackageDescription -> [BuildInfo]+allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr]+ , let bi = libBuildInfo lib+ , True || buildable bi ]+ ++ [ bi | exe <- executables pkg_descr+ , let bi = buildInfo exe+ , True || buildable bi ]+ ++ [ bi | tst <- testSuites pkg_descr+ , let bi = testBuildInfo tst+ , True || buildable bi+ , testEnabled tst ]+ ++ [ bi | tst <- benchmarks pkg_descr+ , let bi = benchmarkBuildInfo tst+ , True || buildable bi+ , benchmarkEnabled tst ]++-- | Get all files referenced by the package.+packageDescFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)+ => PackageDescription -> m [Path Abs File]+packageDescFiles pkg =+ do libfiles <-+ liftM concat+ (mapM libraryFiles+ (maybe [] return (library pkg)))+ exefiles <-+ liftM concat+ (mapM executableFiles+ (executables pkg))+ dfiles <-+ resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))+ srcfiles <-+ resolveGlobFiles (extraSrcFiles pkg)+ -- extraTmpFiles purposely not included here, as those are files generated+ -- by the build script. Another possible implementation: include them, but+ -- don't error out if not present+ docfiles <-+ resolveGlobFiles (extraDocFiles pkg)+ return (concat [libfiles,exefiles,dfiles,srcfiles,docfiles])++-- | Resolve globbing of files (e.g. data files) to absolute paths.+resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)+ => [String] -> m [Path Abs File]+resolveGlobFiles =+ liftM (catMaybes . concat) .+ mapM resolve+ where+ resolve name =+ if any (== '*') name+ then explode name+ else liftM return (resolveFileOrWarn name)+ explode name = do+ dir <- asks parent+ names <-+ matchDirFileGlob'+ (FL.toFilePath dir)+ name+ mapM resolveFileOrWarn names+ matchDirFileGlob' dir glob =+ catch+ (liftIO (matchDirFileGlob_ dir glob))+ (\(e :: IOException) ->+ if isUserError e+ then do+ $logWarn+ ("Wildcard does not match any files: " <> T.pack glob <> "\n" <>+ "in directory: " <> T.pack dir)+ return []+ else throwM e)++-- | This is a copy/paste of the Cabal library function, but with+--+-- @ext == ext'@+--+-- Changed to+--+-- @isSuffixOf ext ext'@+--+-- So that this will work:+--+-- @+-- λ> matchDirFileGlob_ "." "test/package-dump/*.txt"+-- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"]+-- @+--+matchDirFileGlob_ :: String -> String -> IO [String]+matchDirFileGlob_ dir filepath = case parseFileGlob filepath of+ Nothing -> die $ "invalid file glob '" ++ filepath+ ++ "'. Wildcards '*' are only allowed in place of the file"+ ++ " name, not in the directory name or file extension."+ ++ " If a wildcard is used it must be with an file extension."+ Just (NoGlob filepath') -> return [filepath']+ Just (FileGlob dir' ext) -> do+ files <- getDirectoryContents (dir FilePath.</> dir')+ case [ dir' FilePath.</> file+ | file <- files+ , let (name, ext') = splitExtensions file+ , not (null name) && isSuffixOf ext ext' ] of+ [] -> die $ "filepath wildcard '" ++ filepath+ ++ "' does not match any files."+ matches -> return matches++-- | Get all files referenced by the executable.+executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)+ => Executable -> m [Path Abs File]+executableFiles exe =+ do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)+ dir <- asks parent+ exposed <-+ resolveFiles+ (dirs ++ [dir])+ [Right (modulePath exe)]+ haskellFileExts+ bfiles <- buildFiles dir build+ return (concat [bfiles,exposed])+ where build = buildInfo exe++-- | Get all files referenced by the library.+libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)+ => Library -> m [Path Abs File]+libraryFiles lib =+ do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)+ dir <- asks parent+ exposed <- resolveFiles+ (dirs ++ [dir])+ (map Left (exposedModules lib))+ haskellFileExts+ bfiles <- buildFiles dir build+ return (concat [bfiles,exposed])+ where build = libBuildInfo lib++-- | Get all files in a build.+buildFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)+ => Path Abs Dir -> BuildInfo -> m [Path Abs File]+buildFiles dir build = do+ dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)+ other <- resolveFiles+ (dirs ++ [dir])+ (map Left (otherModules build))+ haskellFileExts+ cSources' <- mapMaybeM resolveFileOrWarn (cSources build)+ return (other ++ cSources')++-- | Get all dependencies of a package, including library,+-- executables, tests, benchmarks.+resolvePackageDescription :: PackageConfig+ -> GenericPackageDescription+ -> PackageDescription+resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib exes tests benches) =+ desc {library =+ fmap (resolveConditions rc updateLibDeps) mlib+ ,executables =+ map (resolveConditions rc updateExeDeps .+ snd)+ exes+ ,testSuites =+ map (resolveConditions rc updateTestDeps .+ snd)+ tests+ ,benchmarks =+ map (resolveConditions rc updateBenchmarkDeps .+ snd)+ benches}+ where flags =+ M.union (packageConfigFlags packageConfig)+ (flagMap defaultFlags)++ rc = mkResolveConditions+ (packageConfigGhcVersion packageConfig)+ (packageConfigPlatform packageConfig)+ flags++ updateLibDeps lib deps =+ lib {libBuildInfo =+ ((libBuildInfo lib) {targetBuildDepends =+ deps})}+ updateExeDeps exe deps =+ exe {buildInfo =+ (buildInfo exe) {targetBuildDepends = deps}}+ updateTestDeps test deps =+ test {testBuildInfo =+ (testBuildInfo test) {targetBuildDepends = deps}+ ,testEnabled = packageConfigEnableTests packageConfig}+ updateBenchmarkDeps benchmark deps =+ benchmark {benchmarkBuildInfo =+ (benchmarkBuildInfo benchmark) {targetBuildDepends = deps}+ ,benchmarkEnabled = packageConfigEnableBenchmarks packageConfig}++-- | Make a map from a list of flag specifications.+--+-- What is @flagManual@ for?+flagMap :: [Flag] -> Map FlagName Bool+flagMap = M.fromList . map pair+ where pair :: Flag -> (FlagName, Bool)+ pair (MkFlag (fromCabalFlagName -> name) _desc def _manual) = (name,def)++data ResolveConditions = ResolveConditions+ { rcFlags :: Map FlagName Bool+ , rcGhcVersion :: Version+ , rcOS :: OS+ , rcArch :: Arch+ }++-- | Generic a @ResolveConditions@ using sensible defaults.+mkResolveConditions :: Version -- ^ GHC version+ -> Platform -- ^ installation target platform+ -> Map FlagName Bool -- ^ enabled flags+ -> ResolveConditions+mkResolveConditions ghcVersion (Platform arch os) flags = ResolveConditions+ { rcFlags = flags+ , rcGhcVersion = ghcVersion+ , rcOS = os+ , rcArch = arch+ }++-- | Resolve the condition tree for the library.+resolveConditions :: (Monoid target,Show target)+ => ResolveConditions+ -> (target -> cs -> target)+ -> CondTree ConfVar cs target+ -> target+resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children+ where basic = addDeps lib deps+ children = mconcat (map apply cs)+ where apply (cond,node,mcs) =+ if (condSatisfied cond)+ then resolveConditions rc addDeps node+ else maybe mempty (resolveConditions rc addDeps) mcs+ condSatisfied c =+ case c of+ Var v -> varSatisifed v+ Lit b -> b+ CNot c' ->+ not (condSatisfied c')+ COr cx cy ->+ or [condSatisfied cx,condSatisfied cy]+ CAnd cx cy ->+ and [condSatisfied cx,condSatisfied cy]+ varSatisifed v =+ case v of+ OS os -> os == rcOS rc+ Arch arch -> arch == rcArch rc+ Flag flag ->+ case M.lookup (fromCabalFlagName flag) (rcFlags rc) of+ Just x -> x+ Nothing ->+ -- NOTE: This should never happen, as all flags+ -- which are used must be declared. Defaulting+ -- to False+ False+ Impl flavor range ->+ flavor == GHC &&+ withinRange (rcGhcVersion rc) range++-- | Get the name of a dependency.+depName :: Dependency -> PackageName+depName = \(Dependency n _) -> fromCabalPackageName n++-- | Get the version range of a dependency.+depRange :: Dependency -> VersionRange+depRange = \(Dependency _ r) -> r++-- | Try to resolve the list of base names in the given directory by+-- looking for unique instances of base names applied with the given+-- extensions.+resolveFiles :: MonadIO m+ => [Path Abs Dir] -- ^ Directories to look in.+ -> [Either ModuleName String] -- ^ Base names.+ -> [Text] -- ^ Extentions.+ -> m [Path Abs File]+resolveFiles dirs names exts =+ liftM catMaybes (forM names (liftIO . makeNameCandidates))+ where makeNameCandidates name =+ fmap (listToMaybe . rights . concat)+ (mapM (makeDirCandidates name) dirs)+ makeDirCandidates :: Either ModuleName String+ -> Path Abs Dir+ -> IO [Either ResolveException (Path Abs File)]+ makeDirCandidates name dir =+ mapM (\ext ->+ try (case name of+ Left mn ->+ resolveFile dir+ (Cabal.toFilePath mn ++ "." ++ ext)+ Right fp ->+ resolveFile dir fp))+ (map T.unpack exts)++-- | Get the filename for the cabal file in the given directory.+--+-- If no .cabal file is present, or more than one is present, an exception is+-- thrown via 'throwM'.+getCabalFileName+ :: (MonadThrow m, MonadIO m)+ => Path Abs Dir -- ^ package directory+ -> m (Path Abs File)+getCabalFileName pkgDir = do+ files <- liftIO $ findFiles+ pkgDir+ (flip hasExtension "cabal" . FL.toFilePath)+ (const False)+ case files of+ [] -> throwM $ PackageNoCabalFileFound pkgDir+ [x] -> return x+ _:_ -> throwM $ PackageMultipleCabalFilesFound pkgDir files+ where hasExtension fp x = FilePath.takeExtensions fp == "." ++ x++-- | Path for the package's build log.+buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => Package -> m (Path Abs File)+buildLogPath package' = do+ env <- ask+ let stack = configProjectWorkDir env+ fp <- parseRelFile $ concat+ [ packageNameString $ packageName package'+ , "-"+ , versionString $ packageVersion package'+ , ".log"+ ]+ return $ stack </> $(mkRelDir "logs") </> fp++-- | Resolve the file, if it can't be resolved, warn for the user+-- (purely to be helpful).+resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)+ => FilePath.FilePath+ -> m (Maybe (Path Abs File))+resolveFileOrWarn y =+ do cwd <- getWorkingDir+ file <- ask+ dir <- asks parent+ result <- resolveFileMaybe dir y+ case result of+ Nothing ->+ $logWarn ("Warning: File listed in " <>+ T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>+ " file does not exist: " <>+ T.pack y)+ _ -> return ()+ return result++-- | Resolve the directory, if it can't be resolved, warn for the user+-- (purely to be helpful).+resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)+ => FilePath.FilePath+ -> m (Maybe (Path Abs Dir))+resolveDirOrWarn y =+ do cwd <- getWorkingDir+ file <- ask+ dir <- asks parent+ result <- resolveDirMaybe dir y+ case result of+ Nothing ->+ $logWarn ("Warning: Directory listed in " <>+ T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>+ " file does not exist: " <>+ T.pack y)+ _ -> return ()+ return result
+ src/Stack/PackageDump.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Stack.PackageDump+ ( Line+ , eachSection+ , eachPair+ , DumpPackage (..)+ , conduitDumpPackage+ , ghcPkgDump+ , ProfilingCache+ , newProfilingCache+ , loadProfilingCache+ , saveProfilingCache+ , addProfiling+ , sinkMatching+ , 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 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 qualified Data.Conduit.Binary as CB+import qualified Data.Map as Map+import Data.Either (partitionEithers)+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++-- | Cached information on whether a package has profiling libraries+newtype ProfilingCache = ProfilingCache (IORef (Map GhcPkgId Bool))++-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database+ghcPkgDump+ :: (MonadIO m, MonadLogger m)+ => EnvOverride+ -> Maybe (Path Abs Dir) -- ^ if Nothing, use global+ -> Sink ByteString IO a+ -> 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+ where+ args = concat+ [ case mpkgDb of+ Nothing -> ["--global", "--no-user-package-db"]+ Just pkgdb -> ["--user", "--no-user-package-db", "--package-db", toFilePath pkgdb]+ , ["dump", "--expand-pkgroot"]+ ]++-- | Create a new, empty @ProfilingCache@+newProfilingCache :: MonadIO m => m ProfilingCache+newProfilingCache = liftIO $ ProfilingCache <$> newIORef Map.empty++-- | Load a @ProfilingCache@ from disk, swallowing any errors and returning an+-- empty cache.+loadProfilingCache :: MonadIO m => Path Abs File -> m ProfilingCache+loadProfilingCache path = do+ m <- taggedDecodeOrLoad (toFilePath path) (return Map.empty)+ liftIO $ fmap ProfilingCache $ newIORef m++-- | Save a @ProfilingCache@ to disk+saveProfilingCache :: MonadIO m => Path Abs File -> ProfilingCache -> m ()+saveProfilingCache path (ProfilingCache ref) = liftIO $ do+ createDirectoryIfMissing True $ toFilePath $ parent path+ readIORef ref >>= taggedEncodeFile (toFilePath path)++-- | Prune a list of possible packages down to those whose dependencies are met.+--+-- * id uniquely identifies an item+--+-- * There can be multiple items per name+pruneDeps+ :: (Ord name, Ord id)+ => (id -> name) -- ^ extract the name from an id+ -> (item -> id) -- ^ the id of an item+ -> (item -> [id]) -- ^ get the dependencies of an item+ -> (item -> item -> item) -- ^ choose the desired of two possible items+ -> [item] -- ^ input items+ -> Map name item+pruneDeps getName getId getDepends chooseBest =+ Map.fromList+ . (map $ \item -> (getName $ getId item, item))+ . loop Set.empty Set.empty []+ where+ loop foundIds usedNames foundItems dps =+ case partitionEithers $ map depsMet dps of+ ([], _) -> foundItems+ (s', dps') ->+ let foundIds' = Map.fromListWith chooseBest s'+ foundIds'' = Set.fromList $ map getId $ Map.elems foundIds'+ usedNames' = Map.keysSet foundIds'+ foundItems' = Map.elems foundIds'+ in loop+ (Set.union foundIds foundIds'')+ (Set.union usedNames usedNames')+ (foundItems ++ foundItems')+ (catMaybes dps')+ where+ depsMet dp+ | name `Set.member` usedNames = Right Nothing+ | all (`Set.member` foundIds) (getDepends dp) = Left (name, dp)+ | otherwise = Right $ Just dp+ where+ id' = getId dp+ name = getName id'++-- | Find the package IDs matching the given constraints with all dependencies installed.+-- Packages not mentioned in the provided @Map@ are allowed to be present too.+sinkMatching :: Monad m+ => Bool -- ^ require profiling?+ -> Map PackageName Version -- ^ allowed versions+ -> Consumer (DumpPackage Bool) m (Map PackageName (DumpPackage Bool))+sinkMatching reqProfiling allowed = do+ dps <- CL.filter (\dp -> isAllowed (dpGhcPkgId dp) && (not reqProfiling || dpProfiling dp))+ =$= CL.consume+ return $ pruneDeps+ (packageIdentifierName . ghcPkgIdPackageIdentifier)+ dpGhcPkgId+ dpDepends+ const -- Could consider a better comparison in the future+ dps+ where+ isAllowed gid =+ case Map.lookup name allowed of+ Just version' | version /= version' -> False+ _ -> True+ where+ PackageIdentifier name version = ghcPkgIdPackageIdentifier gid++-- | Add profiling information to the stream of @DumpPackage@s+addProfiling :: MonadIO m+ => ProfilingCache+ -> Conduit (DumpPackage a) m (DumpPackage Bool)+addProfiling (ProfilingCache ref) =+ CL.mapM go+ where+ go dp = liftIO $ do+ m <- readIORef ref+ let gid = dpGhcPkgId dp+ p <- case Map.lookup gid m of+ Just p -> return p+ Nothing | null (dpLibraries dp) -> return True+ Nothing -> do+ let loop [] = return False+ loop (dir:dirs) = do+ contents <- getDirectoryContents $ S8.unpack dir+ if or [isProfiling content lib+ | content <- contents+ , lib <- dpLibraries dp+ ]+ then return True+ else loop dirs+ loop $ dpLibDirs dp+ return dp { dpProfiling = p }++isProfiling :: FilePath -- ^ entry in directory+ -> ByteString -- ^ name of library+ -> Bool+isProfiling content lib =+ prefix `S.isPrefixOf` S8.pack content+ where+ prefix = S.concat ["lib", lib, "_p"]++-- | Dump information for a single package+data DumpPackage profiling = DumpPackage+ { dpGhcPkgId :: !GhcPkgId+ , dpLibDirs :: ![ByteString]+ , dpLibraries :: ![ByteString]+ , dpDepends :: ![GhcPkgId]+ , dpProfiling :: !profiling+ }+ deriving (Show, Eq, Ord)++data PackageDumpException+ = MissingSingleField ByteString (Map ByteString [Line])+ | MismatchedId PackageName Version GhcPkgId+ deriving Typeable+instance Exception PackageDumpException+instance Show PackageDumpException where+ show (MissingSingleField name values) = unlines $ concat+ [ return $ concat+ [ "Expected single value for field name "+ , show name+ , " when parsing ghc-pkg dump output:"+ ]+ , map (\(k, v) -> " " ++ show (k, v)) (Map.toList values)+ ]+ show (MismatchedId name version gid) =+ "Invalid id/name/version in ghc-pkg dump output: " +++ show (name, version, gid)++-- | Convert a stream of bytes into a stream of @DumpPackage@s+conduitDumpPackage :: MonadThrow m+ => Conduit ByteString m (DumpPackage ())+conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do+ pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume+ let m = Map.fromList pairs+ let parseS k =+ case Map.lookup k m of+ Just [v] -> return v+ _ -> throwM $ MissingSingleField k m+ -- Can't fail: if not found, same as an empty list. See:+ -- https://github.com/fpco/stack/issues/182+ parseM k =+ case Map.lookup k m of+ Just vs -> vs+ Nothing -> []++ parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId)+ parseDepend "builtin_rts" = return Nothing+ parseDepend bs =+ liftM Just $ parseGhcPkgId bs'+ where+ (bs', _builtinRts) =+ case stripSuffixBS " builtin_rts" bs of+ Nothing ->+ case stripPrefixBS "builtin_rts " bs of+ Nothing -> (bs, False)+ Just x -> (x, True)+ Just x -> (x, True)+ case Map.lookup "id" m of+ Just ["builtin_rts"] -> return Nothing+ _ -> do+ name <- parseS "name" >>= parsePackageName+ version <- parseS "version" >>= parseVersion+ ghcPkgId <- parseS "id" >>= parseGhcPkgId+ when (PackageIdentifier name version /= ghcPkgIdPackageIdentifier ghcPkgId)+ $ throwM $ MismatchedId name version ghcPkgId++ -- if a package has no modules, these won't exist+ let libDirs = parseM "library-dirs"+ libraries = parseM "hs-libraries"+ depends <- mapM parseDepend $ parseM "depends"++ return $ Just DumpPackage+ { dpGhcPkgId = ghcPkgId+ , dpLibDirs = libDirs+ , dpLibraries = S8.words $ S8.unwords libraries+ , dpDepends = catMaybes (depends :: [Maybe GhcPkgId])+ , dpProfiling = ()+ }++stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString+stripPrefixBS x y+ | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y+ | otherwise = Nothing++stripSuffixBS :: ByteString -> ByteString -> Maybe ByteString+stripSuffixBS x y+ | x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y+ | otherwise = Nothing++-- | A single line of input, not including line endings+type Line = ByteString++-- | Apply the given Sink to each section of output, broken by a single line containing ---+eachSection :: Monad m+ => Sink Line m a+ -> Conduit ByteString m a+eachSection inner =+ CL.map (S.filter (/= _cr)) =$= CB.lines =$= start+ where+ _cr = 13++ peekBS = await >>= maybe (return Nothing) (\bs ->+ if S.null bs+ then peekBS+ else leftover bs >> return (Just bs))++ start = peekBS >>= maybe (return ()) (const go)++ go = do+ x <- toConsumer $ takeWhileC (/= "---") =$= inner+ yield x+ CL.drop 1+ start++-- | Grab each key/value pair+eachPair :: Monad m+ => (ByteString -> Sink Line m a)+ -> Conduit Line m a+eachPair inner =+ start+ where+ start = await >>= maybe (return ()) start'++ _colon = 58+ _space = 32++ start' bs1 =+ toConsumer (valSrc =$= inner key) >>= yield >> start+ where+ (key, bs2) = S.breakByte _colon bs1+ (spaces, bs3) = S.span (== _space) $ S.drop 1 bs2+ indent = S.length key + 1 + S.length spaces++ valSrc+ | S.null bs3 = noIndent+ | otherwise = yield bs3 >> loopIndent indent++ noIndent = do+ mx <- await+ case mx of+ Nothing -> return ()+ Just bs -> do+ let (spaces, val) = S.span (== _space) bs+ if S.length spaces == 0+ then leftover val+ else do+ yield val+ loopIndent (S.length spaces)++ loopIndent i =+ loop+ where+ loop = await >>= maybe (return ()) go++ go bs+ | S.length spaces == i && S.all (== _space) spaces =+ yield val >> loop+ | otherwise = leftover bs+ where+ (spaces, val) = S.splitAt i bs++-- | General purpose utility+takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a+takeWhileC f =+ loop+ where+ loop = await >>= maybe (return ()) go++ go x+ | f x = yield x >> loop+ | otherwise = leftover x
+ src/Stack/PackageIndex.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-- | Dealing with the 00-index file and all its cabal files.+module Stack.PackageIndex+ ( updateAllIndices+ , PackageDownload (..)+ , PackageCache (..)+ , getPackageCaches+ ) where++import qualified Codec.Archive.Tar as Tar+import Control.Applicative+import Control.Exception (Exception)+import Control.Exception.Enclosed (tryIO)+import Control.Monad (unless, when, liftM, mzero)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logDebug,+ logInfo, logWarn)+import Control.Monad.Reader (asks)++import Data.Aeson+import qualified Data.Binary as Binary+import Data.Binary.VersionTagged (taggedDecodeOrLoad)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Conduit (($$), (=$), yield, Producer, ZipSink (..))+import Data.Conduit.Binary (sinkHandle,+ sourceHandle)+import qualified Data.Conduit.List as CL+import Data.Conduit.Zlib (ungzip)+import Data.Int (Int64)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+++import Data.Text.Encoding (encodeUtf8)++import Data.Traversable (forM)++import Data.Typeable (Typeable)++import Data.Word (Word64)++++import GHC.Generics (Generic)++import Network.HTTP.Download+import Path (mkRelDir, parent,+ parseRelDir, toFilePath,+ (</>))+import Prelude -- Fix AMP warning+import Stack.Types+import System.Directory+import System.FilePath (takeBaseName, (<.>))+import System.IO (IOMode (ReadMode, WriteMode),+ withBinaryFile)+import System.Process.Read (runIn, 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+-- for efficiency.+data UnparsedCabalFile = UnparsedCabalFile+ { ucfName :: PackageName+ , ucfVersion :: Version+ , ucfOffset :: !Int64+ -- ^ Byte offset into the 00-index.tar file for the entry contents+ , ucfSize :: !Int64+ -- ^ Size of the entry contents, in bytes+ }++data PackageCache = PackageCache+ { pcOffset :: !Int64+ -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents+ , pcSize :: !Int64+ -- ^ size in bytes of the .cabal file+ , pcDownload :: !(Maybe PackageDownload)+ }+ deriving Generic+instance Binary.Binary PackageCache++-- | Stream all of the cabal files from the 00-index tar file.+sourcePackageIndex :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)+ => EnvOverride+ -> PackageIndex+ -> Producer m (Either UnparsedCabalFile (PackageIdentifier, L.ByteString))+sourcePackageIndex menv index = do+ requireIndex menv index+ -- This uses full on lazy I/O instead of ResourceT to provide some+ -- protections. Caveat emptor+ path <- configPackageIndex (indexName index)+ lbs <- liftIO $ L.readFile $ Path.toFilePath path+ loop 0 (Tar.read lbs)+ where+ loop blockNo (Tar.Next e es) = do+ goE blockNo e+ loop blockNo' es+ where+ blockNo' = blockNo + entrySizeInBlocks e+ loop _ Tar.Done = return ()+ loop _ (Tar.Fail e) = throwM e++ goE blockNo e+ | Just front <- T.stripSuffix ".cabal" $ T.pack $ Tar.entryPath e+ , Tar.NormalFile _ size <- Tar.entryContent e = do+ PackageIdentifier name version <- parseNameVersion front+ yield $ Left UnparsedCabalFile+ { ucfName = name+ , ucfVersion = version+ , ucfOffset = (blockNo + 1) * 512+ , ucfSize = size+ }+ | Just front <- T.stripSuffix ".json" $ T.pack $ Tar.entryPath e+ , Tar.NormalFile lbs _size <- Tar.entryContent e = do+ ident <- parseNameVersion front+ yield $ Right (ident, lbs)+ | otherwise = return ()++ parseNameVersion t1 = do+ let (p', t2) = T.break (== '/') $ T.replace "\\" "/" t1+ p <- parsePackageNameFromString $ T.unpack p'+ t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return+ $ T.stripPrefix "/" t2+ let (v', t4) = T.break (== '/') t3+ v <- parseVersionFromString $ T.unpack v'+ when (t4 /= T.cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " <> p'+ return $ PackageIdentifier p v++data PackageIndexException+ = InvalidCabalPath Text Text+ | GitNotAvailable IndexName+ | MissingRequiredHashes IndexName PackageIdentifier+ deriving Typeable+instance Exception PackageIndexException+instance Show PackageIndexException where+ show (InvalidCabalPath x y) =+ "Invalid cabal path " ++ T.unpack x ++ ": " ++ T.unpack y+ show (GitNotAvailable name) = concat+ [ "Package index "+ , T.unpack $ indexNameText name+ , " only provides Git access, and you do not have"+ , " the git executable on your PATH"+ ]+ show (MissingRequiredHashes name ident) = concat+ [ "Package index "+ , T.unpack $ indexNameText name+ , " is configured to require package hashes, but no"+ , " hash is available for "+ , packageIdentifierString ident+ ]++-- | Require that an index be present, updating if it isn't.+requireIndex :: (MonadIO m,MonadLogger m+ ,MonadThrow m,MonadReader env m,HasHttpManager env+ ,HasConfig env)+ => EnvOverride+ -> PackageIndex+ -> m ()+requireIndex menv index = do+ tarFile <- configPackageIndex $ indexName index+ exists <- liftIO $ doesFileExist $ toFilePath tarFile+ unless exists $ updateIndex menv index++-- | Update all of the package indices+updateAllIndices+ :: (MonadIO m,MonadLogger m+ ,MonadThrow m,MonadReader env m,HasHttpManager env+ ,HasConfig env)+ => EnvOverride+ -> m ()+updateAllIndices menv =+ asks (configPackageIndices . getConfig) >>= mapM_ (updateIndex menv)++-- | Update the index tarball+updateIndex :: (MonadIO m,MonadLogger m+ ,MonadThrow m,MonadReader env m,HasHttpManager env+ ,HasConfig env)+ => EnvOverride+ -> PackageIndex+ -> m ()+updateIndex menv index =+ do $logInfo $ "Updating package index " <> indexNameText (indexName index) <> " ..."+ 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++-- | Update the index Git repo and the index tarball+updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env)+ => EnvOverride+ -> IndexName+ -> PackageIndex+ -> Text -- ^ Git URL+ -> m ()+updateIndexGit menv indexName' index gitUrl = do+ tarFile <- configPackageIndex indexName'+ let idxPath = parent tarFile+ liftIO (createDirectoryIfMissing True (toFilePath idxPath))+ do+ repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl+ let cloneArgs =+ ["clone"+ ,T.unpack gitUrl+ ,toFilePath repoName+ ,"--depth"+ ,"1"+ ,"-b" --+ ,"display"]+ sDir <- configPackageIndexRoot indexName'+ let suDir =+ sDir </>+ $(mkRelDir "git-update")+ acfDir = suDir </> repoName+ repoExists <-+ 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+ _ <-+ (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"])))+ $logDebug ("Exporting a tarball to " <>+ (T.pack . toFilePath) tarFile)+ deleteCache indexName'+ runIn acfDir+ "git"+ menv+ ["archive"+ ,"--format=tar"+ ,"-o"+ ,toFilePath tarFile+ ,"current-hackage"]+ Nothing++-- | Update the index tarball via HTTP+updateIndexHTTP :: (MonadIO m,MonadLogger m+ ,MonadThrow m,MonadReader env m,HasHttpManager env,HasConfig env)+ => IndexName+ -> PackageIndex+ -> Text -- ^ url+ -> m ()+updateIndexHTTP indexName' index url = do+ req <- parseUrl $ T.unpack url+ $logInfo ("Downloading package index from " <> url)+ gz <- configPackageIndexGz indexName'+ tar <- configPackageIndex indexName'+ wasDownloaded <- redownload req gz+ toUnpack <-+ if wasDownloaded+ then return True+ else liftIO $ fmap not $ doesFileExist $ toFilePath tar++ when toUnpack $ do+ let tmp = toFilePath tar <.> "tmp"++ deleteCache indexName'++ liftIO $ do+ withBinaryFile (toFilePath gz) ReadMode $ \input ->+ withBinaryFile tmp WriteMode $ \output ->+ sourceHandle input+ $$ ungzip+ =$ sinkHandle output+ renameFile tmp $ toFilePath tar++ when (indexGpgVerify index)+ $ $logWarn+ $ "You have enabled GPG verification of the package index, " <>+ "but GPG verification only works with Git downloading"++-- | Is the git executable installed?+isGitInstalled :: MonadIO m+ => EnvOverride+ -> m Bool+isGitInstalled = flip doesExecutableExist "git"++-- | Delete the package index cache+deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m) => IndexName -> m ()+deleteCache indexName' = do+ fp <- liftM toFilePath $ configPackageIndexCache indexName'+ eres <- liftIO $ tryIO $ removeFile fp+ case eres of+ Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)+ Right () -> $logDebug $ "Deleted index cache at " <> T.pack fp++data PackageDownload = PackageDownload+ { pdSHA512 :: !ByteString+ , pdUrl :: !ByteString+ , pdSize :: !Word64+ }+ deriving (Show, Generic)+instance Binary.Binary PackageDownload+instance FromJSON PackageDownload where+ parseJSON = withObject "Package" $ \o -> do+ hashes <- o .: "package-hashes"+ sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes)+ locs <- o .: "package-locations"+ url <-+ case reverse locs of+ [] -> mzero+ x:_ -> return x+ size <- o .: "package-size"+ return PackageDownload+ { pdSHA512 = encodeUtf8 sha512+ , pdUrl = encodeUtf8 url+ , pdSize = size+ }++-- | Load the cached package URLs, or created the cache if necessary.+getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env)+ => EnvOverride+ -> m (Map PackageIdentifier (PackageIndex, PackageCache))+getPackageCaches menv = do+ config <- askConfig+ liftM mconcat $ forM (configPackageIndices config) $ \index -> do+ fp <- liftM toFilePath $ configPackageIndexCache (indexName index)+ pis' <- taggedDecodeOrLoad fp $ populateCache menv index++ return (fmap (index,) pis')++-- | Populate the package index caches and return them.+populateCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env)+ => EnvOverride+ -> PackageIndex+ -> m (Map PackageIdentifier PackageCache)+populateCache menv index = do+ $logInfo "Populating index cache, may take a moment ..."+ let toIdent (Left ucf) = Just+ ( PackageIdentifier (ucfName ucf) (ucfVersion ucf)+ , PackageCache+ { pcOffset = ucfOffset ucf+ , pcSize = ucfSize ucf+ , pcDownload = Nothing+ }+ )+ toIdent (Right _) = Nothing++ parseDownload (Left _) = Nothing+ parseDownload (Right (ident, lbs)) = do+ case decode lbs of+ Nothing -> Nothing+ Just pd -> Just (ident, pd)++ (pis, pds) <- sourcePackageIndex menv index $$ getZipSink ((,)+ <$> ZipSink (CL.mapMaybe toIdent =$ CL.consume)+ <*> ZipSink (Map.fromList <$> (CL.mapMaybe parseDownload =$ CL.consume)))++ pis' <- liftM Map.fromList $ forM pis $ \(ident, pc) ->+ case Map.lookup ident pds of+ Just d -> return (ident, pc { pcDownload = Just d })+ Nothing+ | indexRequireHashes index -> throwM $ MissingRequiredHashes (indexName index) ident+ | otherwise -> return (ident, pc)++ $logInfo "Done populating index cache."++ return pis'++--------------- Lifted from cabal-install, Distribution.Client.Tar:+-- | Return the number of blocks in an entry.+entrySizeInBlocks :: Tar.Entry -> Int64+entrySizeInBlocks entry = 1 + case Tar.entryContent entry of+ Tar.NormalFile _ size -> bytesToBlocks size+ Tar.OtherEntryType _ _ size -> bytesToBlocks size+ _ -> 0+ where+ bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)
+ src/Stack/Path.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Implementation of the "path" subcommand+module Stack.Path+ ( pathString+ , PathArg(..)+ , pathGhc+ , pathLog+ , pathPackageDb+ ) where++import Control.Monad.Catch+import Control.Monad.Reader+import qualified Data.List as List+import Data.Typeable (Typeable)+import Path+import System.FilePath++import Stack.Types++data PathArg+ = PathGhc+ | PathLog+ | PathPackageDb+ deriving (Show, Eq, Ord)++data NotYetImplemented = NotYetImplemented String+ deriving (Show, Typeable)+instance Exception NotYetImplemented++-- | Finds the selected PathArg and displays it as a String.+pathString :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => PathArg -> m String+pathString PathGhc = liftM show pathGhc+pathString PathLog = liftM show pathLog+pathString PathPackageDb = liftM process pathPackageDb where+ -- Turns the list of package-db directories into a String+ -- suitable for consumption by GHC_PACKAGE_PATH.+ process :: [Path Abs Dir] -> String+ process = List.intercalate [searchPathSeparator] . map show++-- | The path to the ghc+-- that will be used for the current project.+pathGhc :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => m (Path Abs File)+pathGhc = throwM $ NotYetImplemented "Stack.Path.pathGhc https://github.com/fpco/stack/issues/95"++-- (Note: it's not actually as simple as just one log dir.)+-- | The path to the log file directory+-- that will be used for the current project.+pathLog :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => m (Path Abs Dir)+pathLog = throwM $ NotYetImplemented "Stack.Path.pathLog https://github.com/fpco/stack/issues/95"++-- | The list of package-db directories+-- that will be used for the current project.+-- The earlier databases in the list take precedence over the later ones.+pathPackageDb :: (MonadReader env m, HasBuildConfig env, MonadThrow m)+ => m [Path Abs Dir]+pathPackageDb = throwM $ NotYetImplemented "Stack.Path.pathPackageDb https://github.com/fpco/stack/issues/95"
+ src/Stack/Setup.hs view
@@ -0,0 +1,591 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Stack.Setup+ ( setupEnv+ , ensureGHC+ , SetupOpts (..)+ ) where++import Control.Applicative+import Control.Exception (Exception)+import Control.Monad (liftM, when)+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 Data.Aeson+import qualified Data.ByteString.Char8 as S8+import Data.Conduit (($$))+import qualified Data.Conduit.List as CL+import Data.IORef+import Data.List (intercalate)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe, catMaybes, fromMaybe)+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.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 Path+import Path.IO+import Prelude -- Fix AMP warning+import Stack.Build.Types+import Stack.GhcPkg (getGlobalDB)+import Stack.Types+import System.Directory+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath (searchPathSeparator)+import qualified System.FilePath as FP+import System.IO.Temp (withSystemTempDirectory)+import System.Process (rawSystem)+import System.Process.Read++data SetupOpts = SetupOpts+ { soptsInstallIfMissing :: !Bool+ , soptsUseSystem :: !Bool+ , soptsExpected :: !Version+ , soptsStackYaml :: !(Maybe (Path Abs File))+ -- ^ If we got the desired GHC version from that file+ , soptsForceReinstall :: !Bool+ }+ deriving Show+data SetupException = UnsupportedSetupCombo OS Arch+ | MissingDependencies [String]+ | UnknownGHCVersion Version (Set MajorVersion)+ | UnknownOSKey Text+ deriving Typeable+instance Exception SetupException+instance Show SetupException where+ show (UnsupportedSetupCombo os arch) = concat+ [ "I don't know how to install GHC for "+ , show (os, arch)+ , ", please install manually"+ ]+ show (MissingDependencies tools) =+ "The following executables are missing and must be installed:" +++ intercalate ", " tools+ show (UnknownGHCVersion version known) = concat+ [ "No information found for GHC version "+ , versionString version+ , ". Known GHC major versions: "+ , intercalate ", " (map show $ Set.toList known)+ ]+ show (UnknownOSKey oskey) =+ "Unable to find installation URLs for OS key: " +++ T.unpack oskey++-- | 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+ bconfig <- asks getBuildConfig+ let platform = getPlatform bconfig+ sopts = SetupOpts+ { soptsInstallIfMissing = installIfMissing+ , soptsUseSystem = useSystem+ , soptsExpected = bcGhcVersion bconfig+ , soptsStackYaml = Just $ bcStackYaml bconfig+ , soptsForceReinstall = False+ }+ mghcBin <- ensureGHC sopts+ menv0 <- getMinimalEnvOverride++ -- Modify the initial environment to include the GHC path, if a local GHC+ -- is being used+ let env0 = case mghcBin of+ Nothing -> unEnvOverride menv0+ Just ghcBin ->+ let x = unEnvOverride menv0+ mpath = Map.lookup "PATH" x+ path = T.intercalate (T.singleton searchPathSeparator)+ $ map (stripTrailingSlashT . T.pack) ghcBin+ ++ maybe [] return mpath+ in Map.insert "PATH" path x++ -- Remove potentially confusing environment variables+ env1 = Map.delete "GHC_PACKAGE_PATH"+ $ Map.delete "HASKELL_PACKAGE_SANDBOX"+ $ Map.delete "HASKELL_PACKAGE_SANDBOXES"+ env0++ -- extra installation bin directories+ mkDirs <- runReaderT extraBinDirs bconfig+ let mpath = Map.lookup "PATH" env1+ depsPath = mkPath (mkDirs False) mpath+ localsPath = mkPath (mkDirs True) mpath++ deps <- runReaderT packageDatabaseDeps bconfig+ depsExists <- liftIO $ doesDirectoryExist $ toFilePath deps+ localdb <- runReaderT packageDatabaseLocal bconfig+ localdbExists <- liftIO $ doesDirectoryExist $ toFilePath localdb+ globalDB <- mkEnvOverride platform env1 >>= getGlobalDB+ let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat+ [ [toFilePath localdb | locals && localdbExists]+ , [toFilePath deps | depsExists]+ , [toFilePath globalDB]+ ]++ envRef <- liftIO $ newIORef Map.empty+ let getEnvOverride' es = do+ m <- readIORef envRef+ case Map.lookup es m of+ Just eo -> return eo+ Nothing -> do+ eo <- mkEnvOverride platform+ $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)+ $ (if esIncludeGhcPackagePath es+ then Map.insert "GHC_PACKAGE_PATH" (mkGPP (esIncludeLocals es))+ else id)++ -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70+ $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePath deps)+ $ Map.insert "HASKELL_PACKAGE_SANDBOXES"+ (T.pack $ if esIncludeLocals es+ then intercalate [searchPathSeparator]+ [ toFilePath localdb+ , toFilePath deps+ , ""+ ]+ else intercalate [searchPathSeparator]+ [ toFilePath deps+ , ""+ ])+ $ env1+ !() <- 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)++ stripTrailingSlashS = T.unpack . stripTrailingSlashT . T.pack+ 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)+ => SetupOpts+ -> m (Maybe [FilePath])+ensureGHC sopts = do+ -- Check the available GHCs+ menv0 <- getMinimalEnvOverride++ msystem <-+ if soptsUseSystem sopts+ then getSystemGHC menv0+ else return Nothing++ let needLocal = case msystem of+ Nothing -> True+ Just system ->+ -- we allow a newer version of GHC within the same major series+ getMajorVersion system /= getMajorVersion expected ||+ expected > system++ -- If we need to install a GHC, try to do so+ if needLocal+ then do+ config <- asks getConfig+ let tools =+ case configPlatform config of+ Platform _ Windows ->+ [ ($(mkPackageName "ghc"), Just expected)+ , ($(mkPackageName "git"), Nothing)+ ]+ _ ->+ [ ($(mkPackageName "ghc"), Just expected)+ ]++ -- Avoid having to load it twice+ siRef <- liftIO $ newIORef Nothing+ manager <- asks getHttpManager+ let getSetupInfo' = liftIO $ do+ msi <- readIORef siRef+ case msi of+ Just si -> return si+ Nothing -> do+ si <- getSetupInfo manager+ writeIORef siRef $ Just si+ return si++ installed <- runReaderT listInstalled config+ idents <- mapM (ensureTool sopts installed getSetupInfo' msystem) tools+ paths <- runReaderT (mapM binDirs $ catMaybes idents) config+ -- TODO: strip the trailing slash for prettier PATH output+ return $ Just $ map toFilePath $ concat paths+ else return Nothing+ where+ expected = soptsExpected sopts++-- | Get the major version of the system GHC, if available+getSystemGHC :: (MonadIO m) => EnvOverride -> m (Maybe Version)+getSystemGHC menv = do+ exists <- doesExecutableExist menv "ghc"+ if exists+ then do+ eres <- liftIO $ tryProcessStdout Nothing menv "ghc" ["--numeric-version"]+ return $ do+ Right bs <- Just eres+ parseVersion $ S8.takeWhile isValidChar bs+ else return Nothing+ where+ isValidChar '.' = True+ isValidChar c = '0' <= c && c <= '9'++data DownloadPair = DownloadPair Version Text+ deriving Show+instance FromJSON DownloadPair where+ parseJSON = withObject "DownloadPair" $ \o -> DownloadPair+ <$> o .: "version"+ <*> o .: "url"++data SetupInfo = SetupInfo+ { siSevenzExe :: Text+ , siSevenzDll :: Text+ , siPortableGit :: DownloadPair+ , siGHCs :: Map Text (Map MajorVersion DownloadPair)+ }+ deriving Show+instance FromJSON SetupInfo where+ parseJSON = withObject "SetupInfo" $ \o -> SetupInfo+ <$> o .: "sevenzexe"+ <*> o .: "sevenzdll"+ <*> o .: "portable-git"+ <*> o .: "ghc"++-- | Download the most recent SetupInfo+getSetupInfo :: (MonadIO m, MonadThrow m) => Manager -> m SetupInfo+getSetupInfo manager = do+ bss <- liftIO $ flip runReaderT manager+ $ withResponse req $ \res -> responseBody res $$ CL.consume+ let bs = S8.concat bss+ either throwM return $ Yaml.decodeEither' bs+ where+ req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup.yaml"++markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+ => PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1+ -> m ()+markInstalled ident = do+ dir <- asks $ configLocalPrograms . getConfig+ fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed"+ liftIO $ writeFile (toFilePath $ dir </> fpRel) "installed"++unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+ => PackageIdentifier+ -> m ()+unmarkInstalled ident = do+ dir <- asks $ configLocalPrograms . getConfig+ fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed"+ removeFileIfExists $ dir </> fpRel++listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+ => m [PackageIdentifier]+listInstalled = do+ dir <- asks $ configLocalPrograms . getConfig+ liftIO $ createDirectoryIfMissing True $ toFilePath dir+ (_, files) <- listDirectory dir+ return $ mapMaybe toIdent files+ where+ toIdent fp = do+ x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp+ parsePackageIdentifierFromString $ T.unpack x++installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+ => PackageIdentifier+ -> m (Path Abs Dir)+installDir ident = do+ config <- asks getConfig+ reldir <- parseRelDir $ packageIdentifierString ident+ return $ configLocalPrograms config </> reldir++-- | Binary directories for the given installed package+binDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+ => PackageIdentifier+ -> m [Path Abs Dir]+binDirs ident = do+ config <- asks getConfig+ dir <- installDir ident+ case (configPlatform config, packageNameString $ packageIdentifierName ident) of+ (Platform _ Windows, "ghc") -> return+ [ dir </> $(mkRelDir "bin")+ , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")+ ]+ (Platform _ Windows, "git") -> return+ [ dir </> $(mkRelDir "cmd")+ , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")+ ]+ (_, "ghc") -> return+ [ dir </> $(mkRelDir "bin")+ ]+ (Platform _ x, tool) -> do+ $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)+ => SetupOpts+ -> [PackageIdentifier] -- ^ already installed+ -> m SetupInfo+ -> Maybe Version -- ^ installed GHC+ -> (PackageName, Maybe Version)+ -> m (Maybe PackageIdentifier)+ensureTool sopts installed getSetupInfo' msystem (name, mversion)+ | not $ null available = return $ Just $ PackageIdentifier name $ maximum available+ | not $ soptsInstallIfMissing sopts =+ if name == $(mkPackageName "ghc")+ then throwM $ GHCVersionMismatch msystem (soptsExpected sopts) (soptsStackYaml sopts)+ else do+ $logWarn $ "Continuing despite missing tool: " <> T.pack (packageNameString name)+ return Nothing+ | otherwise = do+ si <- getSetupInfo'+ (pair@(DownloadPair version _), installer) <-+ case packageNameString name of+ "git" -> do+ let pair = siPortableGit si+ return (pair, installGitWindows)+ "ghc" -> do+ osKey <- getOSKey+ pairs <-+ case Map.lookup osKey $ siGHCs si of+ Nothing -> throwM $ UnknownOSKey osKey+ Just pairs -> return pairs+ version <-+ case mversion of+ Nothing -> error "invariant violated: ghc must have a version"+ Just version -> return version+ pair <-+ case Map.lookup (getMajorVersion version) pairs of+ Nothing -> throwM $ UnknownGHCVersion version (Map.keysSet pairs)+ Just pair -> return pair+ platform <- asks $ configPlatform . getConfig+ let installer =+ case platform of+ Platform _ Windows -> installGHCWindows+ _ -> installGHCPosix+ return (pair, installer)+ x -> error $ "Invariant violated: ensureTool on " ++ x+ let ident = PackageIdentifier name version++ (file, at) <- downloadPair pair ident+ dir <- installDir ident+ unmarkInstalled ident+ installer si file at dir ident++ markInstalled ident+ return $ Just ident+ where+ available+ | soptsForceReinstall sopts = []+ | otherwise = filter goodVersion+ $ map packageIdentifierVersion+ $ filter (\pi' -> packageIdentifierName pi' == name) installed++ goodVersion =+ case mversion of+ Nothing -> const True+ Just expected -> \actual ->+ getMajorVersion expected == getMajorVersion actual &&+ actual >= expected++getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env) => m Text+getOSKey = do+ platform <- asks $ configPlatform . getConfig+ case platform of+ Platform I386 Linux -> return "linux32"+ Platform X86_64 Linux -> return "linux64"+ Platform I386 OSX -> return "macosx"+ Platform X86_64 OSX -> return "macosx"+ 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 arch os -> throwM $ UnsupportedSetupCombo os arch++downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+ => DownloadPair+ -> PackageIdentifier+ -> m (Path Abs File, ArchiveType)+downloadPair (DownloadPair _ url) ident = do+ config <- asks getConfig+ at <-+ case extension of+ ".tar.xz" -> return TarXz+ ".tar.bz2" -> return TarBz2+ ".7z.exe" -> return SevenZ+ _ -> error $ "Unknown extension: " ++ extension+ relfile <- parseRelFile $ packageIdentifierString ident ++ extension+ let path = configLocalPrograms config </> relfile+ chattyDownload (packageIdentifierText ident) url path+ return (path, at)+ where+ extension =+ loop $ T.unpack url+ where+ loop fp+ | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z"] = loop fp' ++ ext+ | otherwise = ""+ where+ (fp', ext) = FP.splitExtension fp++data ArchiveType+ = TarBz2+ | TarXz+ | SevenZ++installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+ => SetupInfo+ -> Path Abs File+ -> ArchiveType+ -> Path Abs Dir+ -> PackageIdentifier+ -> m ()+installGHCPosix _ archiveFile archiveType destDir ident = do+ menv <- getMinimalEnvOverride+ zipTool <-+ case archiveType of+ TarXz -> return "xz"+ TarBz2 -> return "bzip2"+ SevenZ -> error "Don't know how to deal with .7z files on non-Windows"+ checkDependencies $ zipTool : ["make", "tar"]++ withSystemTempDirectory "stack-setup" $ \root' -> do+ root <- parseAbsDir root'+ dir <- liftM (root Path.</>) $ parseRelDir $ packageIdentifierString ident++ $logInfo $ "Unpacking GHC ..."+ $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)+ runIn root "tar" menv ["xf", toFilePath archiveFile] Nothing++ $logInfo "Configuring GHC ..."+ runIn dir (toFilePath $ dir Path.</> $(mkRelFile "configure"))+ menv ["--prefix=" ++ toFilePath destDir] Nothing++ $logInfo "Installing GHC ..."+ runIn dir "make" menv ["install"] Nothing++ $logInfo $ "GHC installed."+ $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)+ where+ -- | Check if given processes appear to be present, throwing an exception if+ -- missing.+ checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)+ => [String] -> m ()+ checkDependencies tools = do+ menv <- getMinimalEnvOverride+ missing <- liftM catMaybes $ mapM (check menv) tools+ if null missing+ then return ()+ else throwM $ MissingDependencies missing+ where+ check menv tool = do+ 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)+ => SetupInfo+ -> Path Abs File+ -> ArchiveType+ -> Path Abs Dir+ -> PackageIdentifier+ -> m ()+installGHCWindows si archiveFile archiveType destDir _ = do+ case archiveType of+ TarXz -> return ()+ _ -> error $ "GHC on Windows must be a .tar.xz file"+ tarFile <-+ case T.stripSuffix ".xz" $ T.pack $ toFilePath archiveFile of+ Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile+ Just x -> parseAbsFile $ T.unpack x++ config <- asks getConfig+ run7z <- setup7z si config++ run7z (parent archiveFile) archiveFile+ run7z (parent archiveFile) tarFile++ $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)++installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env)+ => SetupInfo+ -> Path Abs File+ -> ArchiveType+ -> Path Abs Dir+ -> PackageIdentifier+ -> m ()+installGitWindows si archiveFile archiveType destDir _ = do+ case archiveType of+ SevenZ -> return ()+ _ -> error $ "Git on Windows must be a 7z archive"++ config <- asks getConfig+ run7z <- setup7z si config+ run7z destDir archiveFile++-- | 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)+ => SetupInfo+ -> Config+ -> m (Path Abs Dir -> Path Abs File -> n ())+setup7z si config = do+ chattyDownload "7z.dll" (siSevenzDll si) dll+ chattyDownload "7z.exe" (siSevenzExe si) exe+ return $ \outdir archive -> liftIO $ do+ ec <- rawSystem (toFilePath exe)+ [ "x"+ , "-o" ++ toFilePath outdir+ , "-y"+ , toFilePath archive+ ]+ when (ec /= ExitSuccess)+ $ error $ "Problem while decompressing " ++ toFilePath archive+ where+ dir = configLocalPrograms config </> $(mkRelDir "7z")+ exe = dir </> $(mkRelFile "7z.exe")+ dll = dir </> $(mkRelFile "7z.dll")++chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m)+ => Text+ -> Text -- ^ URL+ -> Path Abs File -- ^ destination+ -> m ()+chattyDownload label url path = do+ req <- parseUrl $ T.unpack url+ $logInfo $ T.concat+ [ "Downloading "+ , label+ , " ..."+ ]+ $logDebug $ T.concat+ [ "Downloading from "+ , url+ , " to "+ , T.pack $ toFilePath path+ , " ..."+ ]+ x <- download req path -- TODO add progress indicator+ if x+ then $logInfo ("Downloaded " <> label <> ".")+ else $logDebug "Already downloaded."
+ src/Stack/Types.hs view
@@ -0,0 +1,14 @@+-- | All types.++module Stack.Types+ (module X)+ where++import Stack.Types.BuildPlan as X+import Stack.Types.FlagName as X+import Stack.Types.GhcPkgId as X+import Stack.Types.PackageIdentifier as X+import Stack.Types.PackageName as X+import Stack.Types.Version as X+import Stack.Types.Config as X+import Stack.Types.Docker as X
+ src/Stack/Types/BuildPlan.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+-- | Shared types for various stackage packages.+module Stack.Types.BuildPlan+ ( -- * Types+ BuildPlan (..)+ , PackagePlan (..)+ , PackageConstraints (..)+ , TestState (..)+ , SystemInfo (..)+ , Maintainer (..)+ , ExeName (..)+ , SimpleDesc (..)+ , DepInfo (..)+ , Component (..)+ , SnapName (..)+ , MiniBuildPlan (..)+ , MiniPackageInfo (..)+ , renderSnapName+ , parseSnapName+ ) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.Aeson (FromJSON (..), ToJSON (..),+ object, withObject, withText,+ (.!=), (.:), (.:?), (.=))+import Data.Binary as Binary (Binary)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Set (Set)+import Data.String (IsString, fromString)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.Read (decimal)+import Data.Time (Day)+import qualified Data.Traversable as T+import Data.Typeable (TypeRep, Typeable, typeOf)+import Data.Vector (Vector)+import Distribution.System (Arch, OS)+import qualified Distribution.Text as DT+import qualified Distribution.Version as C+import GHC.Generics (Generic)+import Prelude -- Fix AMP warning+import Safe (readMay)+import Stack.Types.FlagName+import Stack.Types.PackageName+import Stack.Types.Version++-- | The name of an LTS Haskell or Stackage Nightly snapshot.+data SnapName+ = LTS !Int !Int+ | Nightly !Day+ deriving (Show, Eq, Ord)++data BuildPlan = BuildPlan+ { bpSystemInfo :: SystemInfo+ , bpTools :: Vector (PackageName, Version)+ , bpPackages :: Map PackageName PackagePlan+ , bpGithubUsers :: Map Text (Set Text)+ }+ deriving (Show, Eq)++instance ToJSON BuildPlan where+ toJSON BuildPlan {..} = object+ [ "system-info" .= bpSystemInfo+ , "tools" .= fmap goTool bpTools+ , "packages" .= bpPackages+ , "github-users" .= bpGithubUsers+ ]+ where+ goTool (k, v) = object+ [ "name" .= k+ , "version" .= v+ ]+instance FromJSON BuildPlan where+ parseJSON = withObject "BuildPlan" $ \o -> do+ bpSystemInfo <- o .: "system-info"+ bpTools <- o .: "tools" >>= T.mapM goTool+ bpPackages <- o .: "packages"+ bpGithubUsers <- o .:? "github-users" .!= mempty+ return BuildPlan {..}+ where+ goTool = withObject "Tool" $ \o -> (,)+ <$> o .: "name"+ <*> o .: "version"++data PackagePlan = PackagePlan+ { ppVersion :: Version+ , ppGithubPings :: Set Text+ , ppUsers :: Set PackageName+ , ppConstraints :: PackageConstraints+ , ppDesc :: SimpleDesc+ }+ deriving (Show, Eq)++instance ToJSON PackagePlan where+ toJSON PackagePlan {..} = object+ [ "version" .= ppVersion+ , "github-pings" .= ppGithubPings+ , "users" .= ppUsers+ , "constraints" .= ppConstraints+ , "description" .= ppDesc+ ]+instance FromJSON PackagePlan where+ parseJSON = withObject "PackageBuild" $ \o -> do+ ppVersion <- o .: "version"+ ppGithubPings <- o .:? "github-pings" .!= mempty+ ppUsers <- o .:? "users" .!= mempty+ ppConstraints <- o .: "constraints"+ ppDesc <- o .: "description"+ return PackagePlan {..}++display :: DT.Text a => a -> Text+display = fromString . DT.display++simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a+simpleParse orig = withTypeRep $ \rep ->+ case DT.simpleParse str of+ Nothing -> throwM (ParseFailedException rep (pack str))+ Just v -> return v+ where+ str = unpack orig++ withTypeRep :: Typeable a => (TypeRep -> m a) -> m a+ withTypeRep f =+ res+ where+ res = f (typeOf (unwrap res))++ unwrap :: m a -> a+ unwrap _ = error "unwrap"++data BuildPlanTypesException+ = ParseSnapNameException Text+ | ParseFailedException TypeRep Text+ deriving Typeable+instance Exception BuildPlanTypesException+instance Show BuildPlanTypesException where+ show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t+ show (ParseFailedException rep t) =+ "Unable to parse " ++ show t ++ " as " ++ show rep++data PackageConstraints = PackageConstraints+ { pcVersionRange :: VersionRange+ , pcMaintainer :: Maybe Maintainer+ , pcTests :: TestState+ , pcHaddocks :: TestState+ , pcBuildBenchmarks :: Bool+ , pcFlagOverrides :: Map FlagName Bool+ , pcEnableLibProfile :: Bool+ }+ deriving (Show, Eq)+instance ToJSON PackageConstraints where+ toJSON PackageConstraints {..} = object $ addMaintainer+ [ "version-range" .= display pcVersionRange+ , "tests" .= pcTests+ , "haddocks" .= pcHaddocks+ , "build-benchmarks" .= pcBuildBenchmarks+ , "flags" .= pcFlagOverrides+ , "library-profiling" .= pcEnableLibProfile+ ]+ where+ addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer+instance FromJSON PackageConstraints where+ parseJSON = withObject "PackageConstraints" $ \o -> do+ pcVersionRange <- (o .: "version-range")+ >>= either (fail . show) return . simpleParse+ pcTests <- o .: "tests"+ pcHaddocks <- o .: "haddocks"+ pcBuildBenchmarks <- o .: "build-benchmarks"+ pcFlagOverrides <- o .: "flags"+ pcMaintainer <- o .:? "maintainer"+ pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")+ return PackageConstraints {..}++data TestState = ExpectSuccess+ | ExpectFailure+ | Don'tBuild -- ^ when the test suite will pull in things we don't want+ deriving (Show, Eq, Ord, Bounded, Enum)++testStateToText :: TestState -> Text+testStateToText ExpectSuccess = "expect-success"+testStateToText ExpectFailure = "expect-failure"+testStateToText Don'tBuild = "do-not-build"++instance ToJSON TestState where+ toJSON = toJSON . testStateToText+instance FromJSON TestState where+ parseJSON = withText "TestState" $ \t ->+ case HashMap.lookup t states of+ Nothing -> fail $ "Invalid state: " ++ unpack t+ Just v -> return v+ where+ states = HashMap.fromList+ $ map (\x -> (testStateToText x, x)) [minBound..maxBound]++data SystemInfo = SystemInfo+ { siGhcVersion :: Version+ , siOS :: OS+ , siArch :: Arch+ , siCorePackages :: Map PackageName Version+ , siCoreExecutables :: Set ExeName+ }+ deriving (Show, Eq, Ord)+instance ToJSON SystemInfo where+ toJSON SystemInfo {..} = object+ [ "ghc-version" .= siGhcVersion+ , "os" .= display siOS+ , "arch" .= display siArch+ , "core-packages" .= siCorePackages+ , "core-executables" .= siCoreExecutables+ ]+instance FromJSON SystemInfo where+ parseJSON = withObject "SystemInfo" $ \o -> do+ let helper name = (o .: name) >>= either (fail . show) return . simpleParse+ siGhcVersion <- o .: "ghc-version"+ siOS <- helper "os"+ siArch <- helper "arch"+ siCorePackages <- o .: "core-packages"+ siCoreExecutables <- o .: "core-executables"+ return SystemInfo {..}++newtype Maintainer = Maintainer { unMaintainer :: Text }+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)++-- | Name of an executable.+newtype ExeName = ExeName { unExeName :: ByteString }+ deriving (Show, Eq, Ord, Hashable, IsString, Generic)+instance Binary ExeName+instance ToJSON ExeName where+ toJSON = toJSON . S8.unpack . unExeName+instance FromJSON ExeName where+ parseJSON = withText "ExeName" $ return . ExeName . encodeUtf8++-- | A simplified package description that tracks:+--+-- * Package dependencies+--+-- * Build tool dependencies+--+-- * Provided executables+--+-- It has fully resolved all conditionals+data SimpleDesc = SimpleDesc+ { sdPackages :: Map PackageName DepInfo+ , sdTools :: Map ExeName DepInfo+ , sdProvidedExes :: Set ExeName+ , sdModules :: Set Text+ -- ^ modules exported by the library+ }+ deriving (Show, Eq)+instance Monoid SimpleDesc where+ mempty = SimpleDesc mempty mempty mempty mempty+ mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc+ (Map.unionWith (<>) a w)+ (Map.unionWith (<>) b x)+ (c <> y)+ (d <> z)+instance ToJSON SimpleDesc where+ toJSON SimpleDesc {..} = object+ [ "packages" .= sdPackages+ , "tools" .= sdTools+ , "provided-exes" .= sdProvidedExes+ , "modules" .= sdModules+ ]+instance FromJSON SimpleDesc where+ parseJSON = withObject "SimpleDesc" $ \o -> do+ sdPackages <- o .: "packages"+ sdTools <- o .: "tools"+ sdProvidedExes <- o .: "provided-exes"+ sdModules <- o .: "modules"+ return SimpleDesc {..}++data DepInfo = DepInfo+ { diComponents :: Set Component+ , diRange :: VersionRange+ }+ deriving (Show, Eq)++instance Monoid DepInfo where+ mempty = DepInfo mempty C.anyVersion+ DepInfo a x `mappend` DepInfo b y = DepInfo+ (mappend a b)+ (C.intersectVersionRanges x y)+instance ToJSON DepInfo where+ toJSON DepInfo {..} = object+ [ "components" .= diComponents+ , "range" .= display diRange+ ]+instance FromJSON DepInfo where+ parseJSON = withObject "DepInfo" $ \o -> do+ diComponents <- o .: "components"+ diRange <- o .: "range" >>= either (fail . show) return . simpleParse+ return DepInfo {..}++data Component = CompLibrary+ | CompExecutable+ | CompTestSuite+ | CompBenchmark+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++compToText :: Component -> Text+compToText CompLibrary = "library"+compToText CompExecutable = "executable"+compToText CompTestSuite = "test-suite"+compToText CompBenchmark = "benchmark"++instance ToJSON Component where+ toJSON = toJSON . compToText+instance FromJSON Component where+ parseJSON = withText "Component" $ \t -> maybe+ (fail $ "Invalid component: " ++ unpack t)+ return+ (HashMap.lookup t comps)+ where+ comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound]++-- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@,+-- @nightly-2015-03-05@.+renderSnapName :: SnapName -> Text+renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y]+renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d++-- | Parse the short representation of a 'SnapName'.+parseSnapName :: MonadThrow m => Text -> m SnapName+parseSnapName t0 =+ case lts <|> nightly of+ Nothing -> throwM $ ParseSnapNameException t0+ Just sn -> return sn+ where+ lts = do+ t1 <- T.stripPrefix "lts-" t0+ Right (x, t2) <- Just $ decimal t1+ t3 <- T.stripPrefix "." t2+ Right (y, "") <- Just $ decimal t3+ return $ LTS x y+ nightly = do+ t1 <- T.stripPrefix "nightly-" t0+ Nightly <$> readMay (T.unpack t1)++instance ToJSON a => ToJSON (Map ExeName a) where+ toJSON = toJSON . Map.mapKeysWith const (S8.unpack . unExeName)+instance FromJSON a => FromJSON (Map ExeName a) where+ parseJSON = fmap (Map.mapKeysWith const (ExeName . encodeUtf8)) . parseJSON++-- | A simplified version of the 'BuildPlan' + cabal file.+data MiniBuildPlan = MiniBuildPlan+ { mbpGhcVersion :: !Version+ , mbpPackages :: !(Map PackageName MiniPackageInfo)+ }+ deriving (Generic, Show, Eq)+instance Binary.Binary MiniBuildPlan++-- | Information on a single package for the 'MiniBuildPlan'.+data MiniPackageInfo = MiniPackageInfo+ { mpiVersion :: !Version+ , mpiFlags :: !(Map FlagName Bool)+ , mpiPackageDeps :: !(Set PackageName)+ , mpiToolDeps :: !(Set ByteString)+ -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the+ -- executable name, the package name, or something else. We have to guess+ -- based on what's available, which is why we store this is an unwrapped+ -- 'ByteString'.+ , mpiExes :: !(Set ExeName)+ -- ^ Executables provided by this package+ , mpiHasLibrary :: !Bool+ -- ^ Is there a library present?+ }+ deriving (Generic, Show, Eq)+instance Binary.Binary MiniPackageInfo
+ src/Stack/Types/Config.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}++-- | The Config type.++module Stack.Types.Config where++import Control.Applicative ((<|>))+import Control.Exception+import Control.Monad (liftM)+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.Binary (Binary)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Hashable (Hashable)+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 Path+import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)+import Stack.Types.Docker+import Stack.Types.FlagName+import Stack.Types.PackageIdentifier+import Stack.Types.PackageName+import Stack.Types.Version+import System.Process.Read (EnvOverride)++-- | The top-level Stackage configuration.+data Config =+ Config {configStackRoot :: !(Path Abs Dir)+ -- ^ ~/.stack more often than not+ ,configDocker :: !DockerOpts+ ,configEnvOverride :: !(EnvSettings -> IO EnvOverride)+ -- ^ Environment variables to be passed to external tools+ ,configLocalPrograms :: !(Path Abs Dir)+ -- ^ Path containing local installations (mainly GHC)+ ,configConnectionCount :: !Int+ -- ^ How many concurrent connections are allowed when downloading+ ,configHideTHLoading :: !Bool+ -- ^ Hide the Template Haskell "Loading package ..." messages from the+ -- console+ ,configPlatform :: !Platform+ -- ^ The platform we're building for, used in many directory names+ ,configLatestSnapshotUrl :: !Text+ -- ^ URL for a JSON file containing information on the latest+ -- snapshots available.+ ,configPackageIndices :: ![PackageIndex]+ -- ^ Information on package indices. This is left biased, meaning that+ -- packages in an earlier index will shadow those in a later index.+ --+ -- Warning: if you override packages in an index vs what's available+ -- upstream, you may correct your compiled snapshots, as different+ -- projects may have different definitions of what pkg-ver means! This+ -- feature is primarily intended for adding local packages, not+ -- overriding. Overriding is better accomplished by adding to your+ -- list of packages.+ --+ -- Note that indices specified in a later config file will override+ -- previous indices, /not/ extend them.+ --+ -- Using an assoc list instead of a Map to keep track of priority+ }++-- | Information on a single package index+data PackageIndex = PackageIndex+ { indexName :: !IndexName+ , indexLocation :: !IndexLocation+ , indexDownloadPrefix :: !Text+ -- ^ URL prefix for downloading packages+ , indexGpgVerify :: !Bool+ -- ^ GPG-verify the package index during download. Only applies to Git+ -- repositories for now.+ , indexRequireHashes :: !Bool+ -- ^ Require that hashes and package size information be available for packages in this index+ }+ deriving Show+instance FromJSON PackageIndex where+ parseJSON = withObject "PackageIndex" $ \o -> do+ name <- o .: "name"+ prefix <- o .: "download-prefix"+ mgit <- o .:? "git"+ mhttp <- o .:? "http"+ loc <-+ case (mgit, mhttp) of+ (Nothing, Nothing) -> fail $+ "Must provide either Git or HTTP URL for " +++ T.unpack (indexNameText name)+ (Just git, Nothing) -> return $ ILGit git+ (Nothing, Just http) -> return $ ILHttp http+ (Just git, Just http) -> return $ ILGitHttp git http+ gpgVerify <- o .:? "gpg-verify" .!= False+ reqHashes <- o .:? "require-hashes" .!= False+ return PackageIndex+ { indexName = name+ , indexLocation = loc+ , indexDownloadPrefix = prefix+ , indexGpgVerify = gpgVerify+ , indexRequireHashes = reqHashes+ }++-- | Unique name for a package index+newtype IndexName = IndexName { unIndexName :: ByteString }+ deriving (Show, Eq, Ord, Hashable, Binary)+indexNameText :: IndexName -> Text+indexNameText = decodeUtf8 . unIndexName+instance ToJSON IndexName where+ toJSON = toJSON . indexNameText+instance FromJSON IndexName where+ parseJSON = withText "IndexName" $ \t ->+ case parseRelDir (T.unpack t) of+ Left e -> fail $ "Invalid index name: " ++ show e+ Right _ -> return $ IndexName $ encodeUtf8 t++-- | Location of the package index. This ensures that at least one of Git or+-- HTTP is available.+data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text+ deriving (Show, Eq, Ord)++-- | Controls which version of the environment is used+data EnvSettings = EnvSettings+ { esIncludeLocals :: !Bool+ -- ^ include local project bin directory, GHC_PACKAGE_PATH, etc+ , esIncludeGhcPackagePath :: !Bool+ -- ^ include the GHC_PACKAGE_PATH variable+ }+ deriving (Show, Eq, Ord)++-- | A superset of 'Config' adding information on how to build code. The reason+-- for this breakdown is because we will need some of the information from+-- 'Config' in order to determine the values here.+data BuildConfig = BuildConfig+ { bcConfig :: !Config+ , bcResolver :: !Resolver+ -- ^ How we resolve which dependencies to install given a set of+ -- packages.+ , 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+ , bcExtraDeps :: !(Map PackageName Version)+ -- ^ Extra dependencies specified in configuration.+ --+ -- These dependencies will not be installed to a shared location, and+ -- will override packages provided by the resolver.+ , bcRoot :: !(Path Abs Dir)+ -- ^ Directory containing the project's stack.yaml file+ , bcStackYaml :: !(Path Abs File)+ -- ^ Location of the stack.yaml file.+ --+ -- Note: if the STACK_YAML environment variable is used, this may be+ -- different from bcRoot </> "stack.yaml"+ , bcFlags :: !(Map PackageName (Map FlagName Bool))+ -- ^ Per-package flag overrides+ }++-- | Value returned by 'Stack.Config.loadConfig'.+data LoadConfig m = LoadConfig+ { lcConfig :: !Config+ -- ^ Top-level Stack configuration.+ , lcLoadBuildConfig :: !(NoBuildConfigStrategy -> m BuildConfig)+ -- ^ Action to load the remaining 'BuildConfig'.+ , lcProjectRoot :: !(Maybe (Path Abs Dir))+ -- ^ The project root directory, if in a project.+ }++data NoBuildConfigStrategy+ = ThrowException+ | CreateConfig+ | ExecStrategy+ deriving (Show, Eq, Ord)++-- | 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@.+ , projectExtraDeps :: !(Map PackageName Version)+ -- ^ Components of the package list referring to package/version combos,+ -- see: https://github.com/fpco/stack/issues/41+ , projectFlags :: !(Map PackageName (Map FlagName Bool))+ -- ^ Per-package flag overrides+ , projectResolver :: !Resolver+ -- ^ How we resolve which dependencies to use+ }+ deriving Show++instance ToJSON Project where+ toJSON p = object+ [ "packages" .= projectPackages p+ , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)+ , "flags" .= projectFlags p+ , "resolver" .= projectResolver p+ ]++-- | How we resolve which dependencies to install given a set of packages.+data Resolver+ = ResolverSnapshot SnapName+ -- ^ Use an official snapshot from the Stackage project, either an LTS+ -- Haskell or Stackage Nightly++ | ResolverGhc {-# UNPACK #-} !MajorVersion+ -- ^ Require a specific GHC major version, but otherwise provide no build+ -- plan. Intended for use cases where end user wishes to specify all upstream+ -- dependencies manually, such as using a dependency solver.+ deriving (Show)++instance ToJSON Resolver where+ toJSON = toJSON . renderResolver+instance FromJSON Resolver where+ parseJSON = withText "Resolver" $+ either (fail . show) return . parseResolver++-- | Convert a Resolver into its @Text@ representation, as will be used by JSON/YAML+renderResolver :: Resolver -> Text+renderResolver (ResolverSnapshot name) = renderSnapName name+renderResolver (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y]++-- | Try to parse a @Resolver@, using same format as JSON/YAML/'renderResolver'+parseResolver :: MonadThrow m => Text -> m Resolver+parseResolver t =+ case parseSnapName t of+ Right x -> return $ ResolverSnapshot x+ Left _ ->+ case parseGhc of+ Just m -> return $ ResolverGhc m+ Nothing -> throwM $ ParseResolverException t+ where+ parseGhc = T.stripPrefix "ghc-" t >>= parseMajorVersionFromString . T.unpack++-- | Class for environment values which have access to the stack root+class HasStackRoot env where+ getStackRoot :: env -> Path Abs Dir+ default getStackRoot :: HasConfig env => env -> Path Abs Dir+ getStackRoot = configStackRoot . getConfig+ {-# INLINE getStackRoot #-}++-- | Class for environment values which have a Platform+class HasPlatform env where+ getPlatform :: env -> Platform+ default getPlatform :: HasConfig env => env -> Platform+ getPlatform = configPlatform . getConfig+ {-# INLINE getPlatform #-}+instance HasPlatform Platform where+ getPlatform = id++-- | Class for environment values that can provide a 'Config'.+class (HasStackRoot env, HasPlatform env) => HasConfig env where+ getConfig :: env -> Config+ default getConfig :: HasBuildConfig env => env -> Config+ getConfig = bcConfig . getBuildConfig+ {-# INLINE getConfig #-}+instance HasStackRoot Config+instance HasPlatform Config+instance HasConfig Config where+ getConfig = id+ {-# INLINE getConfig #-}++-- | Class for environment values that can provide a 'BuildConfig'.+class HasConfig env => HasBuildConfig env where+ getBuildConfig :: env -> BuildConfig+instance HasStackRoot BuildConfig+instance HasPlatform BuildConfig+instance HasConfig BuildConfig+instance HasBuildConfig BuildConfig where+ getBuildConfig = id+ {-# INLINE getBuildConfig #-}++-- An uninterpreted representation of configuration options.+-- Configurations may be "cascaded" using mappend (left-biased).+data ConfigMonoid =+ ConfigMonoid+ { configMonoidDockerOpts :: !DockerOptsMonoid+ -- ^ Docker options.+ , configMonoidConnectionCount :: !(Maybe Int)+ -- ^ See: 'configConnectionCount'+ , configMonoidHideTHLoading :: !(Maybe Bool)+ -- ^ See: 'configHideTHLoading'+ , configMonoidLatestSnapshotUrl :: !(Maybe Text)+ -- ^ See: 'configLatestSnapshotUrl'+ , configMonoidPackageIndices :: !(Maybe [PackageIndex])+ -- ^ See: 'configPackageIndices'+ }+ deriving Show++instance Monoid ConfigMonoid where+ mempty = ConfigMonoid+ { configMonoidDockerOpts = mempty+ , configMonoidConnectionCount = Nothing+ , configMonoidHideTHLoading = Nothing+ , configMonoidLatestSnapshotUrl = Nothing+ , configMonoidPackageIndices = Nothing+ }+ mappend l r = ConfigMonoid+ { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r+ , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r+ , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r+ , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r+ , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r+ }++instance FromJSON ConfigMonoid where+ parseJSON =+ withObject "ConfigMonoid" $+ \obj ->+ do configMonoidDockerOpts <- obj .:? T.pack "docker" .!= mempty+ configMonoidConnectionCount <- obj .:? "connection-count"+ configMonoidHideTHLoading <- obj .:? "hide-th-loading"+ configMonoidLatestSnapshotUrl <- obj .:? "latest-snapshot-url"+ configMonoidPackageIndices <- obj .:? "package-indices"+ return ConfigMonoid {..}++data ConfigException+ = ParseResolverException Text+ | NoProjectConfigFound (Path Abs Dir)+ 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."+ ]+ show (NoProjectConfigFound dir) = concat+ [ "Unable to find a stack.yaml file in the current directory ("+ , toFilePath dir+ , ") or its ancestors"+ ]+instance Exception ConfigException++-- | Helper function to ask the environment and apply getConfig+askConfig :: (MonadReader env m, HasConfig env) => m Config+askConfig = liftM getConfig ask++-- | Get the URL to request the information on the latest snapshots+askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text+askLatestSnapshotUrl = asks (configLatestSnapshotUrl . getConfig)++-- | Root for a specific package index+configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir)+configPackageIndexRoot (IndexName name) = do+ config <- asks getConfig+ dir <- parseRelDir $ S8.unpack name+ return (configStackRoot config </> $(mkRelDir "indices") </> dir)++-- | Location of the 00-index.cache file+configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)+configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot++-- | Location of the 00-index.tar file+configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)+configPackageIndex = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot++-- | Location of the 00-index.tar.gz file+configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)+configPackageIndexGz = liftM (</> $(mkRelFile "00-index.tar.gz")) . configPackageIndexRoot++-- | Location of a package tarball+configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File)+configPackageTarball iname ident = do+ root <- configPackageIndexRoot iname+ name <- parseRelDir $ packageNameString $ packageIdentifierName ident+ ver <- parseRelDir $ versionString $ packageIdentifierVersion ident+ base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz"+ return (root </> $(mkRelDir "packages") </> name </> ver </> base)++-- | 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"))++-- | File containing the profiling cache, see "Stack.PackageDump"+configProfilingCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)+configProfilingCache = liftM (</> $(mkRelFile "profiling-cache.bin")) configProjectWorkDir++-- | Relative directory for the platform identifier+platformRelDir :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir)+platformRelDir = asks getPlatform >>= parseRelDir . Distribution.Text.display++-- | Path to .shake files.+configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+configShakeFilesDir = liftM (</> $(mkRelDir "shake")) configProjectWorkDir++-- | Where to unpack packages for local build+configLocalUnpackDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+configLocalUnpackDir = liftM (</> $(mkRelDir "unpacked")) configProjectWorkDir++-- | Directory containing snapshots+snapshotsDir :: (MonadReader env m, HasConfig env, MonadThrow m) => m (Path Abs Dir)+snapshotsDir = do+ config <- asks getConfig+ platform <- platformRelDir+ return $ configStackRoot config </> $(mkRelDir "snapshots") </> platform++-- | Installation root for dependencies+installationRootDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+installationRootDeps = do+ snapshots <- snapshotsDir+ bc <- asks getBuildConfig+ name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc+ ghc <- parseRelDir $ versionString $ bcGhcVersion bc+ return $ snapshots </> name </> ghc++-- | Installation root for locals+installationRootLocal :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+installationRootLocal = do+ bc <- asks getBuildConfig+ name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc+ ghc <- parseRelDir $ versionString $ bcGhcVersion bc+ platform <- platformRelDir+ return $ configProjectWorkDir bc </> $(mkRelDir "install") </> platform </> name </> ghc++-- | Package database for installing dependencies into+packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+packageDatabaseDeps = do+ root <- installationRootDeps+ return $ root </> $(mkRelDir "pkgdb")++-- | Package database for installing local packages into+packageDatabaseLocal :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+packageDatabaseLocal = do+ root <- installationRootLocal+ return $ root </> $(mkRelDir "pkgdb")++-- | Directory for holding flag cache information+flagCacheLocal :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => m (Path Abs Dir)+flagCacheLocal = do+ root <- installationRootLocal+ return $ root </> $(mkRelDir "flag-cache")++-- | Where to store mini build plan caches+configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasStackRoot env, HasPlatform env)+ => SnapName+ -> m (Path Abs File)+configMiniBuildPlanCache name = do+ root <- asks getStackRoot+ platform <- platformRelDir+ file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"+ -- Yes, cached plans differ based on platform+ return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)++-- | Suffix applied to an installation root to get the bin dir+bindirSuffix :: Path Rel Dir+bindirSuffix = $(mkRelDir "bin")++-- | Get the extra bin directories (for the PATH). Puts more local first+--+-- Bool indicates whether or not to include the locals+extraBinDirs :: (MonadThrow m, MonadReader env m, HasBuildConfig env)+ => m (Bool -> [Path Abs Dir])+extraBinDirs = do+ deps <- installationRootDeps+ local <- installationRootLocal+ return $ \locals -> if locals+ then [local </> bindirSuffix, deps </> bindirSuffix]+ else [deps </> bindirSuffix]++-- | Get the minimal environment override, useful for just calling external+-- processes like git or ghc+getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride+getMinimalEnvOverride = do+ config <- asks getConfig+ liftIO $ configEnvOverride config EnvSettings+ { esIncludeLocals = False+ , esIncludeGhcPackagePath = False+ }
+ src/Stack/Types/Docker.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-}++-- | Docker types.++module Stack.Types.Docker where++import Control.Applicative+import Data.Aeson+import Data.Monoid+import Data.Text (Text)+import Path++-- | Docker configuration.+data DockerOpts = DockerOpts+ {dockerEnable :: !Bool+ -- ^ Is using Docker enabled?+ ,dockerImage :: !String+ -- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag.+ ,dockerRegistryLogin :: !Bool+ -- ^ Does registry require login for pulls?+ ,dockerRegistryUsername :: !(Maybe String)+ -- ^ Optional username for Docker registry.+ ,dockerRegistryPassword :: !(Maybe String)+ -- ^ Optional password for Docker registry.+ ,dockerAutoPull :: !Bool+ -- ^ Automatically pull new images.+ ,dockerDetach :: !Bool+ -- ^ Whether to run a detached container+ ,dockerPersist :: !Bool+ -- ^ Create a persistent container (don't remove it when finished). Implied by+ -- `dockerDetach`.+ ,dockerContainerName :: !(Maybe String)+ -- ^ Container name to use, only makes sense from command-line with `dockerPersist`+ -- or `dockerDetach`.+ ,dockerRunArgs :: ![String]+ -- ^ Arguments to pass directly to @docker run@.+ ,dockerMount :: ![Mount]+ -- ^ Volumes to mount in the container.+ ,dockerPassHost :: !Bool+ -- ^ Pass Docker daemon connection information into container.+ ,dockerDatabasePath :: !(Path Abs File)+ -- ^ Location of image usage database.+ }+ deriving (Show)++-- | An uninterpreted representation of docker options.+-- Configurations may be "cascaded" using mappend (left-biased).+data DockerOptsMonoid = DockerOptsMonoid+ {dockerMonoidExists :: !(Maybe Bool)+ -- ^ Does a @docker:@ section exist in the top-level (usually project) config?+ ,dockerMonoidEnable :: !(Maybe Bool)+ -- ^ Is using Docker enabled?+ ,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)+ -- ^ Docker repository name (e.g. @fpco/dev@ or @fpco/dev:lts-2.8@)+ ,dockerMonoidRegistryLogin :: !(Maybe Bool)+ -- ^ Does registry require login for pulls?+ ,dockerMonoidRegistryUsername :: !(Maybe String)+ -- ^ Optional username for Docker registry.+ ,dockerMonoidRegistryPassword :: !(Maybe String)+ -- ^ Optional password for Docker registry.+ ,dockerMonoidAutoPull :: !(Maybe Bool)+ -- ^ Automatically pull new images.+ ,dockerMonoidDetach :: !(Maybe Bool)+ -- ^ Whether to run a detached container+ ,dockerMonoidPersist :: !(Maybe Bool)+ -- ^ Create a persistent container (don't remove it when finished). Implied by+ -- `dockerDetach`.+ ,dockerMonoidContainerName :: !(Maybe String)+ -- ^ Container name to use, only makes sense from command-line with `dockerPersist`+ -- or `dockerDetach`.+ ,dockerMonoidRunArgs :: ![String]+ -- ^ Arguments to pass directly to @docker run@+ ,dockerMonoidMount :: ![Mount]+ -- ^ Volumes to mount in the container+ ,dockerMonoidPassHost :: !(Maybe Bool)+ -- ^ Pass Docker daemon connection information into container.+ ,dockerMonoidDatabasePath :: !(Maybe String)+ -- ^ Location of image usage database.+ }+ deriving (Show)++-- | Decode uninterpreted docker options from JSON/YAML.+instance FromJSON DockerOptsMonoid where+ parseJSON = withObject "DockerOptsMonoid"+ (\o -> do dockerMonoidExists <- pure (Just True)+ dockerMonoidEnable <- o .:? dockerEnableArgName+ dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o .: dockerImageArgName) <|>+ ((Just . DockerMonoidRepo) <$> o .: dockerRepoArgName) <|>+ pure Nothing+ dockerMonoidRegistryLogin <- o .:? dockerRegistryLoginArgName+ dockerMonoidRegistryUsername <- o .:? dockerRegistryUsernameArgName+ dockerMonoidRegistryPassword <- o .:? dockerRegistryPasswordArgName+ dockerMonoidAutoPull <- o .:? dockerAutoPullArgName+ dockerMonoidDetach <- o .:? dockerDetachArgName+ dockerMonoidPersist <- o .:? dockerPersistArgName+ dockerMonoidContainerName <- o .:? dockerContainerNameArgName+ dockerMonoidRunArgs <- o .:? dockerRunArgsArgName .!= []+ dockerMonoidMount <- o .:? dockerMountArgName .!= []+ dockerMonoidPassHost <- o .:? dockerPassHostArgName+ dockerMonoidDatabasePath <- o .:? dockerDatabasePathArgName+ return DockerOptsMonoid{..})++-- | Left-biased combine Docker options+instance Monoid DockerOptsMonoid where+ mempty = DockerOptsMonoid+ {dockerMonoidExists = Just False+ ,dockerMonoidEnable = Nothing+ ,dockerMonoidRepoOrImage = Nothing+ ,dockerMonoidRegistryLogin = Nothing+ ,dockerMonoidRegistryUsername = Nothing+ ,dockerMonoidRegistryPassword = Nothing+ ,dockerMonoidAutoPull = Nothing+ ,dockerMonoidDetach = Nothing+ ,dockerMonoidPersist = Nothing+ ,dockerMonoidContainerName = Nothing+ ,dockerMonoidRunArgs = []+ ,dockerMonoidMount = []+ ,dockerMonoidPassHost = Nothing+ ,dockerMonoidDatabasePath = Nothing+ }+ mappend l r = DockerOptsMonoid+ {dockerMonoidExists = dockerMonoidExists l <|> dockerMonoidExists r+ ,dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r+ ,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r+ ,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r+ ,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r+ ,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r+ ,dockerMonoidAutoPull = dockerMonoidAutoPull l <|> dockerMonoidAutoPull r+ ,dockerMonoidDetach = dockerMonoidDetach l <|> dockerMonoidDetach r+ ,dockerMonoidPersist = dockerMonoidPersist l <|> dockerMonoidPersist r+ ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r+ ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l+ ,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l+ ,dockerMonoidPassHost = dockerMonoidPassHost l <|> dockerMonoidPassHost r+ ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r+ }++-- | Docker volume mount.+data Mount = Mount String String++-- | For optparse-applicative.+instance Read Mount where+ readsPrec _ s =+ case break (== ':') s of+ (a,':':b) -> [(Mount a b,"")]+ (a,[]) -> [(Mount a a,"")]+ _ -> fail "Invalid value for Docker mount (expect '/host/path:/container/path')"++-- | Show instance.+instance Show Mount where+ show (Mount a b) = if a == b+ then a+ else concat [a,":",b]++-- | For YAML.+instance FromJSON Mount where+ parseJSON v = fmap read (parseJSON v)++-- | Options for Docker repository or image.+data DockerMonoidRepoOrImage+ = DockerMonoidRepo String+ | DockerMonoidImage String+ deriving (Show)++-- | Docker enable argument name.+dockerEnableArgName :: Text+dockerEnableArgName = "enable"++-- | Docker repo arg argument name.+dockerRepoArgName :: Text+dockerRepoArgName = "repo"++-- | Docker image argument name.+dockerImageArgName :: Text+dockerImageArgName = "image"++-- | Docker registry login argument name.+dockerRegistryLoginArgName :: Text+dockerRegistryLoginArgName = "registry-login"++-- | Docker registry username argument name.+dockerRegistryUsernameArgName :: Text+dockerRegistryUsernameArgName = "registry-username"++-- | Docker registry password argument name.+dockerRegistryPasswordArgName :: Text+dockerRegistryPasswordArgName = "registry-password"++-- | Docker auto-pull argument name.+dockerAutoPullArgName :: Text+dockerAutoPullArgName = "auto-pull"++-- | Docker detach argument name.+dockerDetachArgName :: Text+dockerDetachArgName = "detach"++-- | Docker run args argument name.+dockerRunArgsArgName :: Text+dockerRunArgsArgName = "run-args"++-- | Docker mount argument name.+dockerMountArgName :: Text+dockerMountArgName = "mount"++-- | Docker container name argument name.+dockerContainerNameArgName :: Text+dockerContainerNameArgName = "container-name"++-- | Docker persist argument name.+dockerPersistArgName :: Text+dockerPersistArgName = "persist"++-- | Docker pass host argument name.+dockerPassHostArgName :: Text+dockerPassHostArgName = "pass-host"++-- | Docker database path argument name.+dockerDatabasePathArgName :: Text+dockerDatabasePathArgName = "database-path"
+ src/Stack/Types/FlagName.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}++-- | Names for flags.++module Stack.Types.FlagName+ (FlagName+ ,FlagNameParseFail(..)+ ,flagNameParser+ ,parseFlagName+ ,parseFlagNameFromString+ ,flagNameString+ ,flagNameText+ ,fromCabalFlagName+ ,toCabalFlagName+ ,mkFlagName)+ where++import Control.Applicative+import Control.Monad.Catch+import Data.Aeson+import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Combinators+import Data.Binary (Binary)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Char (isLetter)+import Data.Data+import Data.Hashable+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Distribution.PackageDescription as Cabal+import GHC.Generics+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- | A parse fail.+data FlagNameParseFail+ = FlagNameParseFail ByteString+ deriving (Typeable)+instance Exception FlagNameParseFail+instance Show FlagNameParseFail where+ show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs++-- | A flag name.+newtype FlagName =+ FlagName ByteString+ deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary)++instance Lift FlagName where+ lift (FlagName n) =+ appE (conE 'FlagName)+ (stringE (S8.unpack n))++instance Show FlagName where+ show (FlagName n) = S8.unpack n++instance FromJSON FlagName where+ parseJSON j =+ do s <- parseJSON j+ case parseFlagNameFromString s of+ Nothing ->+ fail ("Couldn't parse flag name: " ++ s)+ Just ver -> return ver++-- | Attoparsec parser for a flag name from bytestring.+flagNameParser :: Parser FlagName+flagNameParser =+ fmap (FlagName . S8.pack)+ (appending (many1 (satisfy isLetter))+ (concating (many (alternating+ (pured (satisfy isAlphaNum))+ (appending (pured (satisfy separator))+ (pured (satisfy isAlphaNum)))))))+ where separator c = c == '-' || c == '_'+ isAlphaNum c = isLetter c || isDigit c++-- | Make a flag name.+mkFlagName :: String -> Q Exp+mkFlagName s =+ case parseFlagNameFromString s of+ Nothing -> error ("Invalid flag name: " ++ show s)+ Just pn -> [|pn|]++-- | Convenient way to parse a flag name from a bytestring.+parseFlagName :: MonadThrow m => ByteString -> m FlagName+parseFlagName x = go x+ where go =+ either (const (throwM (FlagNameParseFail x))) return .+ parseOnly (flagNameParser <* endOfInput)++-- | Migration function.+parseFlagNameFromString :: MonadThrow m => String -> m FlagName+parseFlagNameFromString =+ parseFlagName . S8.pack++-- | Produce a string representation of a flag name.+flagNameString :: FlagName -> String+flagNameString (FlagName n) = S8.unpack n++-- | Produce a string representation of a flag name.+flagNameText :: FlagName -> Text+flagNameText (FlagName n) = T.decodeUtf8 n++-- | Convert from a Cabal flag name.+fromCabalFlagName :: Cabal.FlagName -> FlagName+fromCabalFlagName (Cabal.FlagName name) =+ let !x = S8.pack name+ in FlagName x++-- | Convert to a Cabal flag name.+toCabalFlagName :: FlagName -> Cabal.FlagName+toCabalFlagName (FlagName name) =+ let !x = S8.unpack name+ in Cabal.FlagName x++instance ToJSON a => ToJSON (Map FlagName a) where+ toJSON = toJSON . Map.mapKeysWith const flagNameText+instance FromJSON a => FromJSON (Map FlagName a) where+ parseJSON val = do+ m <- parseJSON val+ fmap Map.fromList $ mapM go $ Map.toList m+ where+ go (k, v) = fmap (, v) $ either (fail . show) return $ parseFlagNameFromString k
+ src/Stack/Types/GhcPkgId.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | A ghc-pkg id.++module Stack.Types.GhcPkgId+ (GhcPkgId+ ,ghcPkgIdParser+ ,parseGhcPkgId+ ,ghcPkgIdString+ ,ghcPkgIdPackageIdentifier)+ where++import Control.Applicative+import Control.Monad.Catch+import Data.Aeson+import Data.Attoparsec.ByteString.Char8+import Data.Binary (Binary)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Char (isLetter)+import Data.Data+import Data.Hashable+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics+import Prelude -- Fix AMP warning+import Stack.Types.PackageIdentifier++-- | A parse fail.+data GhcPkgIdParseFail+ = GhcPkgIdParseFail ByteString+ deriving Typeable+instance Show GhcPkgIdParseFail where+ show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs+instance Exception GhcPkgIdParseFail++-- | A ghc-pkg package identifier.+data GhcPkgId =+ GhcPkgId !PackageIdentifier+ !ByteString+ deriving (Eq,Ord,Data,Typeable,Generic)++instance Hashable GhcPkgId+instance Binary GhcPkgId++instance Show GhcPkgId where+ show = show . ghcPkgIdString++instance FromJSON GhcPkgId where+ parseJSON = withText "GhcPkgId" $ \t ->+ case parseGhcPkgId $ encodeUtf8 t of+ Left e -> fail $ show (e, t)+ Right x -> return x++instance ToJSON GhcPkgId where+ toJSON g =+ toJSON (ghcPkgIdString g)++-- | Convenient way to parse a package name from a bytestring.+parseGhcPkgId :: MonadThrow m => ByteString -> m GhcPkgId+parseGhcPkgId x = go x+ where go =+ either (const (throwM (GhcPkgIdParseFail x))) return .+ parseOnly (ghcPkgIdParser <* endOfInput)++-- | A parser for a package-version-hash pair.+ghcPkgIdParser :: Parser GhcPkgId+ghcPkgIdParser =+ do ident <- packageIdentifierParser+ _ <- char8 '-'+ h <- many1 (satisfy isAlphaNum)+ let !bytes = S8.pack h+ return (GhcPkgId ident bytes)+ where isAlphaNum c = isLetter c || isDigit c++-- | Get a string representation of GHC package id.+ghcPkgIdString :: GhcPkgId -> String+ghcPkgIdString (GhcPkgId ident x) =+ packageIdentifierString ident ++ "-" ++ S8.unpack x++-- | Get the package identifier of the GHC package id.+ghcPkgIdPackageIdentifier :: GhcPkgId -> PackageIdentifier+ghcPkgIdPackageIdentifier (GhcPkgId ident _) = ident
+ src/Stack/Types/Internal.hs view
@@ -0,0 +1,34 @@+-- | Internal types to the library.++module Stack.Types.Internal where++import Control.Monad.Logger (LogLevel)+import Network.HTTP.Client.Conduit (Manager,HasHttpManager(..))+import Stack.Types.Config++-- | Monadic environment.+data Env config =+ Env {envConfig :: !config+ ,envLogLevel :: !LogLevel+ ,envManager :: !Manager}++instance HasStackRoot config => HasStackRoot (Env config) where+ getStackRoot = getStackRoot . envConfig+instance HasPlatform config => HasPlatform (Env config) where+ getPlatform = getPlatform . envConfig+instance HasConfig config => HasConfig (Env config) where+ getConfig = getConfig . envConfig+instance HasBuildConfig config => HasBuildConfig (Env config) where+ getBuildConfig = getBuildConfig . envConfig++instance HasHttpManager (Env config) where+ getHttpManager = envManager++class HasLogLevel r where+ getLogLevel :: r -> LogLevel++instance HasLogLevel (Env config) where+ getLogLevel = envLogLevel++instance HasLogLevel LogLevel where+ getLogLevel = id
+ src/Stack/Types/PackageIdentifier.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS -fno-warn-unused-do-bind #-}++-- | Package identifier (name-version).++module Stack.Types.PackageIdentifier+ (PackageIdentifier(..)+ ,toTuple+ ,fromTuple+ ,parsePackageIdentifier+ ,parsePackageIdentifierFromString+ ,packageIdentifierVersion+ ,packageIdentifierName+ ,packageIdentifierParser+ ,packageIdentifierString+ ,packageIdentifierText)+ where++import Control.Applicative+import Control.DeepSeq+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.Aeson+import Data.Attoparsec.ByteString.Char8+import Data.Binary (Binary)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Data+import Data.Hashable+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics+import Prelude hiding (FilePath)+import Stack.Types.PackageName+import Stack.Types.Version++-- | A parse fail.+data PackageIdentifierParseFail+ = PackageIdentifierParseFail ByteString+ deriving (Typeable)+instance Show PackageIdentifierParseFail where+ show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs+instance Exception PackageIdentifierParseFail++-- | A pkg-ver combination.+data PackageIdentifier =+ PackageIdentifier !PackageName+ !Version+ deriving (Eq,Ord,Generic,Data,Typeable)++instance NFData PackageIdentifier where+ rnf (PackageIdentifier !p !v) =+ seq (rnf p) (rnf v)++instance Hashable PackageIdentifier+instance Binary PackageIdentifier++instance Show PackageIdentifier where+ show = show . packageIdentifierString++instance ToJSON PackageIdentifier where+ toJSON = toJSON . packageIdentifierString+instance FromJSON PackageIdentifier where+ parseJSON = withText "PackageIdentifier" $ \t ->+ case parsePackageIdentifier $ encodeUtf8 t of+ Left e -> fail $ show (e, t)+ Right x -> return x++-- | Convert from a package identifier to a tuple.+toTuple :: PackageIdentifier -> (PackageName,Version)+toTuple (PackageIdentifier n v) = (n,v)++-- | Convert from a tuple to a package identifier.+fromTuple :: (PackageName,Version) -> PackageIdentifier+fromTuple (n,v) = PackageIdentifier n v++-- | Get the version part of the identifier.+packageIdentifierVersion :: PackageIdentifier -> Version+packageIdentifierVersion (PackageIdentifier _ ver) = ver++-- | Get the name part of the identifier.+packageIdentifierName :: PackageIdentifier -> PackageName+packageIdentifierName (PackageIdentifier name _) = name++-- | A parser for a package-version pair.+packageIdentifierParser :: Parser PackageIdentifier+packageIdentifierParser =+ do name <- packageNameParser+ char8 '-'+ version <- versionParser+ return (PackageIdentifier name version)++-- | Convenient way to parse a package identifier from a bytestring.+parsePackageIdentifier :: MonadThrow m => ByteString -> m PackageIdentifier+parsePackageIdentifier x = go x+ where go =+ either (const (throwM (PackageIdentifierParseFail x))) return .+ parseOnly (packageIdentifierParser <* endOfInput)++-- | Migration function.+parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier+parsePackageIdentifierFromString =+ parsePackageIdentifier . S8.pack++-- | Get a string representation of the package identifier; name-ver.+packageIdentifierString :: PackageIdentifier -> String+packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v++-- | Get a Text representation of the package identifier; name-ver.+packageIdentifierText :: PackageIdentifier -> Text+packageIdentifierText = T.pack . packageIdentifierString
+ src/Stack/Types/PackageName.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}++-- | Names for packages.++module Stack.Types.PackageName+ (PackageName+ ,PackageNameParseFail(..)+ ,packageNameParser+ ,parsePackageName+ ,parsePackageNameFromString+ ,packageNameByteString+ ,packageNameString+ ,packageNameText+ ,fromCabalPackageName+ ,toCabalPackageName+ ,parsePackageNameFromFilePath+ ,mkPackageName)+ where++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Monad.Catch+import Data.Aeson+import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.Combinators+import Data.Binary (Binary)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Char (isLetter)+import Data.Data+import Data.Hashable+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Distribution.Package as Cabal+import GHC.Generics+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Path++-- | A parse fail.+data PackageNameParseFail+ = PackageNameParseFail ByteString+ | CabalFileNameParseFail FilePath+ deriving (Typeable)+instance Exception PackageNameParseFail+instance Show PackageNameParseFail where+ show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs+ show (CabalFileNameParseFail fp) = "Invalid file path for cabal file: " ++ fp++-- | A package name.+newtype PackageName =+ PackageName ByteString+ deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData)++instance Lift PackageName where+ lift (PackageName n) =+ appE (conE 'PackageName)+ (stringE (S8.unpack n))++instance Show PackageName where+ show (PackageName n) = S8.unpack n++instance ToJSON PackageName where+ toJSON = toJSON . packageNameText+instance FromJSON PackageName where+ parseJSON j =+ do s <- parseJSON j+ case parsePackageNameFromString s of+ Nothing ->+ fail ("Couldn't parse package name: " ++ s)+ Just ver -> return ver++-- | Attoparsec parser for a package name from bytestring.+packageNameParser :: Parser PackageName+packageNameParser =+ fmap (PackageName . S8.pack)+ (appending (many1 (satisfy isAlphaNum))+ (concating (many (alternating+ (pured (satisfy isAlphaNum))+ (appending (pured (satisfy (== '-')))+ (pured (satisfy isLetter)))))))+ where+ isAlphaNum c = isLetter c || isDigit c++-- | Make a package name.+mkPackageName :: String -> Q Exp+mkPackageName s =+ case parsePackageNameFromString s of+ Nothing -> error ("Invalid package name: " ++ show s)+ Just pn -> [|pn|]++-- | Convenient way to parse a package name from a bytestring.+parsePackageName :: MonadThrow m => ByteString -> m PackageName+parsePackageName x = go x+ where go =+ either (const (throwM (PackageNameParseFail x))) return .+ parseOnly (packageNameParser <* endOfInput)++-- | Migration function.+parsePackageNameFromString :: MonadThrow m => String -> m PackageName+parsePackageNameFromString =+ parsePackageName . S8.pack++-- | Produce a bytestring representation of a package name.+packageNameByteString :: PackageName -> ByteString+packageNameByteString (PackageName n) = n++-- | Produce a string representation of a package name.+packageNameString :: PackageName -> String+packageNameString (PackageName n) = S8.unpack n++-- | Produce a string representation of a package name.+packageNameText :: PackageName -> Text+packageNameText (PackageName n) = T.decodeUtf8 n++-- | Convert from a Cabal package name.+fromCabalPackageName :: Cabal.PackageName -> PackageName+fromCabalPackageName (Cabal.PackageName name) =+ let !x = S8.pack name+ in PackageName x++-- | Convert to a Cabal package name.+toCabalPackageName :: PackageName -> Cabal.PackageName+toCabalPackageName (PackageName name) =+ let !x = S8.unpack name+ in Cabal.PackageName x++-- | Parse a package name from a file path.+parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName+parsePackageNameFromFilePath fp =+ clean (toFilePath (filename fp)) >>= parsePackageNameFromString+ where clean = liftM reverse . strip . reverse+ strip ('l':'a':'b':'a':'c':'.':xs) = return xs+ strip _ = throwM (CabalFileNameParseFail (toFilePath fp))++instance ToJSON a => ToJSON (Map PackageName a) where+ toJSON = toJSON . Map.mapKeysWith const packageNameText+instance FromJSON a => FromJSON (Map PackageName a) where+ parseJSON val = do+ m <- parseJSON val+ fmap Map.fromList $ mapM go $ Map.toList m+ where+ go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k
+ src/Stack/Types/StackT.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | The monad used for the command-line executable @stack@.++module Stack.Types.StackT+ (StackT+ ,StackLoggingT+ ,runStackT+ ,runStackLoggingT+ ,newTLSManager)+ where++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import qualified Data.ByteString.Char8 as S8+import Data.Char+import Data.Text (Text)+import Data.Time+import Language.Haskell.TH.Syntax (Loc(..))+import Network.HTTP.Client.Conduit (HasHttpManager(..))+import Network.HTTP.Conduit+import Prelude -- Fix AMP warning+import Stack.Types.Internal+import System.Log.FastLogger++#ifndef MIN_VERSION_time+#define MIN_VERSION_time(x, y, z) 0+#endif+#if !MIN_VERSION_time(1, 5, 0)+import System.Locale+#endif++--------------------------------------------------------------------------------+-- Main StackT monad transformer++-- | The monad used for the executable @stack@.+newtype StackT config m a =+ StackT {unStackT :: ReaderT (Env config) m a}+ deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadCatch,MonadMask,MonadTrans)++deriving instance (MonadBase b m) => MonadBase b (StackT config m)++instance MonadBaseControl b m => MonadBaseControl b (StackT config m) where+ type StM (StackT config m) a = ComposeSt (StackT config) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance MonadTransControl (StackT config) where+ type StT (StackT config) a = StT (ReaderT (Env config)) a+ liftWith = defaultLiftWith StackT unStackT+ restoreT = defaultRestoreT StackT++-- | Takes the configured log level into account.+instance (MonadIO m) => MonadLogger (StackT config m) where+ monadLoggerLog = loggerFunc++-- | 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)++--------------------------------------------------------------------------------+-- Logging only StackLoggingT monad transformer++-- | 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)++deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m)++instance MonadBaseControl b m => MonadBaseControl b (StackLoggingT m) where+ type StM (StackLoggingT m) a = ComposeSt StackLoggingT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance MonadTransControl StackLoggingT where+ type StT StackLoggingT a = StT (ReaderT (LogLevel,Manager)) a+ liftWith = defaultLiftWith StackLoggingT unStackLoggingT+ restoreT = defaultRestoreT StackLoggingT++-- | Takes the configured log level into account.+instance (MonadIO m) => MonadLogger (StackLoggingT m) where+ monadLoggerLog = loggerFunc++instance HasLogLevel (LogLevel,Manager) where+ getLogLevel = fst++instance HasHttpManager (LogLevel,Manager) where+ getHttpManager = snd++-- | Run the logging monad.+runStackLoggingT :: MonadIO m+ => Manager -> LogLevel -> StackLoggingT m a -> m a+runStackLoggingT manager logLevel m =+ runReaderT (unStackLoggingT m)+ (logLevel,manager)++-- | Convenience for getting a 'Manager'+newTLSManager :: MonadIO m => m Manager+newTLSManager = liftIO $ newManager conduitManagerSettings++--------------------------------------------------------------------------------+-- Logging functionality++-- | Logging function takes the log level into account.+loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)+ => Loc -> Text -> LogLevel -> msg -> m ()+loggerFunc loc _src level msg =+ do maxLogLevel <- asks getLogLevel+ when (level >= maxLogLevel)+ (liftIO (do out <- getOutput maxLogLevel+ S8.putStrLn (S8.pack out)))+ where getOutput maxLogLevel =+ do date <- getDate+ l <- getLevel+ lc <- getLoc+ return (date ++ l ++ S8.unpack (fromLogStr (toLogStr msg)) ++ lc)+ where getDate+ | maxLogLevel <= LevelDebug =+ do now <- getCurrentTime+ return (formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now +++ ": ")+ | otherwise = return ""+ getLevel+ | maxLogLevel <= LevelDebug =+ return ("[" +++ map toLower (drop 5 (show level)) +++ "] ")+ | otherwise = return ""+ getLoc+ | maxLogLevel <= LevelDebug =+ return (" @(" ++ fileLocStr ++ ")")+ | otherwise = return ""+ fileLocStr =+ (loc_package loc) +++ ':' :+ (loc_module loc) +++ ' ' :+ (loc_filename loc) +++ ':' :+ (line loc) +++ ':' :+ (char loc)+ where line = show . fst . loc_start+ char = show . snd . loc_start
+ src/Stack/Types/Version.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Versions for packages.++module Stack.Types.Version+ (Version+ ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper+ ,MajorVersion (..)+ ,getMajorVersion+ ,fromMajorVersion+ ,parseMajorVersionFromString+ ,versionParser+ ,parseVersion+ ,parseVersionFromString+ ,versionString+ ,versionText+ ,toCabalVersion+ ,fromCabalVersion+ ,mkVersion+ ,versionRangeText+ ,withinRange)+ where++import Control.Applicative+import Control.DeepSeq+import Control.Monad.Catch+import Data.Aeson+import Data.Attoparsec.ByteString.Char8+import Data.Binary (Binary)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Data+import Data.Hashable+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector.Binary ()+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as V+import Data.Word+import Distribution.Text (disp)+import qualified Distribution.Version as Cabal+import GHC.Generics+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Prelude -- Fix warning: Word in Prelude from base-4.8.+import Text.PrettyPrint (render)++-- | A parse fail.+data VersionParseFail =+ VersionParseFail ByteString+ | NotAMajorVersion Version+ deriving (Typeable)+instance Exception VersionParseFail+instance Show VersionParseFail where+ show (VersionParseFail bs) = "Invalid version: " ++ show bs+ show (NotAMajorVersion v) = concat+ [ "Not a major version: "+ , versionString v+ , ", expecting exactly two numbers (e.g. 7.10)"+ ]++-- | A package version.+newtype Version =+ Version {unVersion :: Vector Word}+ deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData)++-- | The first two components of a version.+data MajorVersion = MajorVersion !Word !Word+ deriving (Typeable, Eq, Ord)+instance Show MajorVersion where+ show (MajorVersion x y) = concat [show x, ".", show y]+instance ToJSON MajorVersion where+ toJSON = toJSON . fromMajorVersion++-- | Parse major version from @String@+parseMajorVersionFromString :: MonadThrow m => String -> m MajorVersion+parseMajorVersionFromString s = do+ Version v <- parseVersionFromString s+ if V.length v == 2+ then return $ getMajorVersion (Version v)+ else throwM $ NotAMajorVersion (Version v)++instance FromJSON MajorVersion where+ parseJSON = withText "MajorVersion"+ $ either (fail . show) return+ . parseMajorVersionFromString+ . T.unpack+instance FromJSON a => FromJSON (Map MajorVersion a) where+ parseJSON val = do+ m <- parseJSON val+ fmap Map.fromList $ mapM go $ Map.toList m+ where+ go (k, v) = do+ k' <- either (fail . show) return $ parseMajorVersionFromString k+ return (k', v)++-- | Returns the first two components, defaulting to 0 if not present+getMajorVersion :: Version -> MajorVersion+getMajorVersion (Version v) =+ case V.length v of+ 0 -> MajorVersion 0 0+ 1 -> MajorVersion (V.head v) 0+ _ -> MajorVersion (V.head v) (v V.! 1)++-- | Convert a two-component version into a @Version@+fromMajorVersion :: MajorVersion -> Version+fromMajorVersion (MajorVersion x y) = Version $ V.fromList [x, y]++instance Hashable Version where+ hashWithSalt i = hashWithSalt i . V.toList . unVersion++instance Lift Version where+ lift (Version n) =+ appE (conE 'Version)+ (appE (varE 'V.fromList)+ (listE (map (litE . IntegerL . fromIntegral)+ (V.toList n))))++instance Show Version where+ show (Version v) =+ intercalate "."+ (map show (V.toList v))++instance ToJSON Version where+ toJSON = toJSON . versionText+instance FromJSON Version where+ parseJSON j =+ do s <- parseJSON j+ case parseVersionFromString s of+ Nothing ->+ fail ("Couldn't parse package version: " ++ s)+ Just ver -> return ver++-- | Attoparsec parser for a package version from bytestring.+versionParser :: Parser Version+versionParser =+ do ls <- ((:) <$> num <*> many num')+ let !v = V.fromList ls+ return (Version v)+ where num = decimal+ num' = point *> num+ point = satisfy (== '.')++-- | Convenient way to parse a package version from a bytestring.+parseVersion :: MonadThrow m => ByteString -> m Version+parseVersion x = go x+ where go =+ either (const (throwM (VersionParseFail x))) return .+ parseOnly (versionParser <* endOfInput)++-- | Migration function.+parseVersionFromString :: MonadThrow m => String -> m Version+parseVersionFromString =+ parseVersion . S8.pack++-- | Get a string representation of a package version.+versionString :: Version -> String+versionString (Version v) =+ intercalate "."+ (map show (V.toList v))++-- | Get a string representation of a package version.+versionText :: Version -> Text+versionText (Version v) =+ T.intercalate+ "."+ (map (T.pack . show)+ (V.toList v))++-- | Convert to a Cabal version.+toCabalVersion :: Version -> Cabal.Version+toCabalVersion (Version v) =+ Cabal.Version (map fromIntegral (V.toList v)) []++-- | Convert from a Cabal version.+fromCabalVersion :: Cabal.Version -> Version+fromCabalVersion (Cabal.Version vs _) =+ let !v = V.fromList (map fromIntegral vs)+ in Version v++-- | Make a package version.+mkVersion :: String -> Q Exp+mkVersion s =+ case parseVersionFromString s of+ Nothing -> error ("Invalid package version: " ++ show s)+ Just pn -> [|pn|]++-- | Display a version range+versionRangeText :: Cabal.VersionRange -> Text+versionRangeText = T.pack . render . disp++-- | Check if a version is within a version range.+withinRange :: Version -> Cabal.VersionRange -> Bool+withinRange v r = toCabalVersion v `Cabal.withinRange` r
+ src/System/Process/PagerEditor.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}++-- | Run external pagers (@$PAGER@, @less@, @more@) and editors (@$VISUAL@,+-- @$EDITOR@, @nano@, @pico@, @vi@).+module System.Process.PagerEditor+ (-- * Pager+ pageWriter+ ,pageByteString+ ,pageBuilder+ ,pageFile+ ,pageString+ ,PagerException(..)+ -- * Editor+ ,editFile+ ,editReaderWriter+ ,editByteString+ ,editString+ ,EditorException(..))+ where++import Control.Exception (try,IOException,throwIO,Exception)+import Data.ByteString.Lazy (ByteString,hPut,readFile)+import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder)+import Data.Typeable (Typeable)+import System.Directory (findExecutable)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe)+ ,CreateProcess(std_in, close_fds, delegate_ctlc))+import System.IO (hClose,Handle,hPutStr,readFile,withFile,IOMode(WriteMode),stdout)+import System.IO.Temp (withSystemTempDirectory)++-- | Run pager, providing a function that writes to the pager's input.+pageWriter :: (Handle -> IO ()) -> IO ()+pageWriter writer =+ do mpager <- lookupEnv "PAGER" `orElse`+ findExecutable "less" `orElse`+ findExecutable "more"+ case mpager of+ Just pager ->+ do (Just h,_,_,procHandle) <- createProcess (shell pager)+ {std_in = CreatePipe+ ,close_fds = True+ ,delegate_ctlc = True}+ (_::Either IOException ()) <- try (do writer h+ hClose h)+ exit <- waitForProcess procHandle+ case exit of+ ExitSuccess -> return ()+ ExitFailure n -> throwIO (PagerExitFailure pager n)+ return ()+ Nothing -> writer stdout++-- | Run pager to display a lazy ByteString.+pageByteString :: ByteString -> IO ()+pageByteString = pageWriter . flip hPut++-- | Run pager to display a ByteString-Builder.+pageBuilder :: Builder -> IO ()+pageBuilder = pageWriter . flip hPutBuilder++-- | Run pager to display contents of a file.+pageFile :: FilePath -> IO ()+pageFile p = pageByteString =<< Data.ByteString.Lazy.readFile p++-- | Run pager to display a string.+pageString :: String -> IO ()+pageString = pageBuilder . stringUtf8++-- | Run editor to edit a file.+editFile :: FilePath -> IO ()+editFile path =+ do meditor <- lookupEnv "VISUAL" `orElse`+ lookupEnv "EDITOR" `orElse`+ findExecutable "nano" `orElse`+ findExecutable "pico" `orElse`+ findExecutable "vi"+ case meditor of+ Just editor ->+ do (_,_,_,procHandle) <- createProcess (proc "sh" ["-c", editor ++ " \"$1\"", "sh", path])+ {close_fds = True,delegate_ctlc = True}+ exitCode <- waitForProcess procHandle+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure n -> throwIO (EditorExitFailure editor n)+ Nothing -> throwIO EditorNotFound++-- | Run editor, providing functions to write and read the file contents.+editReaderWriter :: forall a. String -> (Handle -> IO ()) -> (FilePath -> IO a) -> IO a+editReaderWriter filename writer reader =+ withSystemTempDirectory ""+ (\p -> do let p' = p </> filename+ withFile p' WriteMode writer+ editFile p'+ reader p')++-- | Run editor on a ByteString.+editByteString :: String -> ByteString -> IO ByteString+editByteString f s = editReaderWriter f (flip hPut s) Data.ByteString.Lazy.readFile++-- | Run editor on a String.+editString :: String -> String -> IO String+editString f s = editReaderWriter f (flip hPutStr s) System.IO.readFile++-- | Short-circuit first Just.+orElse :: (Monad m) => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+orElse a b = do m <- a+ case m of+ Just _ -> return m+ Nothing -> b++-- | Exception running pager.+data PagerException = PagerNotFound+ | PagerExitFailure FilePath Int+ deriving Typeable+instance Show PagerException where+ show PagerNotFound = "No pager found (tried $PAGER, `less`, and `more`.)"+ show (PagerExitFailure p n) = "Pager (`" ++ p ++ "') exited with non-zero status: " ++ show n+instance Exception PagerException++-- | Exception running editor.+data EditorException = EditorNotFound+ | EditorExitFailure FilePath Int+ deriving Typeable+instance Show EditorException where+ show EditorNotFound = "No editor found (tried $VISUAL, $PAGER, `nano`, `pico`, and `vi`.)"+ show (EditorExitFailure p n) = "Editor (`" ++ p ++ "') exited with non-zero status: " ++ show n+instance Exception EditorException
+ src/System/Process/Read.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Reading from external processes.++module System.Process.Read+ (callProcess+ ,readProcessStdout+ ,tryProcessStdout+ ,sinkProcessStdout+ ,runIn+ ,EnvOverride+ ,unEnvOverride+ ,mkEnvOverride+ ,envHelper+ ,doesExecutableExist+ ,findExecutable+ ,getEnvOverride)+ where++import Control.Applicative+import Control.Arrow ((***), first)+import Control.Concurrent.Async (Concurrently (..))+import Control.Exception+import Control.Monad (join, liftM)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logError)+import qualified Data.ByteString as S+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Conduit.Process hiding (callProcess)+import Data.Foldable (forM_)+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+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.Environment (getEnvironment)+import System.Exit (exitWith)++-- | Override the environment received by a child process+data EnvOverride = EnvOverride+ { eoTextMap :: Map Text Text+ , eoStringList :: [(String, String)]+ , eoPath :: [FilePath]+ , eoExeCache :: IORef (Map FilePath (Either FindExecutableException (Path Abs File)))+ , eoExeExtension :: String+ }++-- | Get the environment variables from @EnvOverride@+unEnvOverride :: EnvOverride -> Map Text Text+unEnvOverride = eoTextMap++-- | Create a new @EnvOverride@+mkEnvOverride :: MonadIO m+ => Platform+ -> Map Text Text+ -> m EnvOverride+mkEnvOverride platform tm' = do+ ref <- liftIO $ newIORef Map.empty+ return EnvOverride+ { eoTextMap = tm+ , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm+ , eoPath = maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)+ , eoExeCache = ref+ , eoExeExtension = if isWindows then ".exe" else ""+ }+ where+ -- Fix case insensitivity of the PATH environment variable on Windows.+ tm+ | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'+ | otherwise = tm'++ -- Don't use CPP so that the Windows code path is at least type checked+ -- regularly+ isWindows =+ case platform of+ Platform _ Windows -> True+ _ -> False++-- | Helper conversion function+envHelper :: EnvOverride -> Maybe [(String, String)]+envHelper = Just . eoStringList++-- | Try to produce a strict 'S.ByteString' from the stdout of a+-- process.+tryProcessStdout :: (MonadIO m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m (Either ProcessExitedUnsuccessfully S.ByteString)+tryProcessStdout wd menv name args = do+ liftIO (try (readProcessStdout wd menv name args))++-- | Produce a strict 'S.ByteString' from the stdout of a+-- process. Throws a 'ProcessExitedUnsuccessfully' exception if the+-- process fails.+readProcessStdout :: (MonadIO m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m S.ByteString+readProcessStdout wd menv name args =+ 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++-- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer.+sinkProcessStdout :: (MonadIO m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> 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)+ 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)))+ 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 ()++-- | 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++-- | Find the complete path for the executable+findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File))+findExecutable eo name = liftIO $ do+ m <- readIORef $ eoExeCache eo+ epath <- case Map.lookup name m of+ Just epath -> return epath+ Nothing -> do+ let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo)+ loop (dir:dirs) = do+ let fp = dir FP.</> name ++ eoExeExtension eo+ exists <- doesFileExist fp+ if exists+ then do+ fp' <- canonicalizePath fp >>= parseAbsFile+ return $ return fp'+ else loop dirs+ epath <- loop $ eoPath eo+ !() <- atomicModifyIORef (eoExeCache eo) $ \m' ->+ (Map.insert name epath m', ())+ return epath+ return $ either throwM return epath++-- | Load up an EnvOverride from the standard environment+getEnvOverride :: MonadIO m => Platform -> m EnvOverride+getEnvOverride platform =+ liftIO $+ getEnvironment >>=+ mkEnvOverride platform+ . Map.fromList . map (T.pack *** T.pack)++data FindExecutableException+ = NoPathFound+ | ExecutableNotFound String [FilePath]+ deriving Typeable+instance Exception FindExecutableException+instance Show FindExecutableException where+ show NoPathFound = "PATH not found in EnvOverride"+ show (ExecutableNotFound name path) = concat+ [ "Executable named "+ , name+ , " not found on path: "+ , show path+ ]
+ src/main/Main.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++-- | Main stack tool entry point.++module Main where++import Control.Exception+import Control.Monad (join)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger+import Control.Monad.Reader (asks)+import Data.Char (toLower)+import Data.List+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Network.HTTP.Client+import Options.Applicative.Builder.Extra+import Options.Applicative.Simple+import Options.Applicative.Types (readerAsk)+import Path (toFilePath)+import qualified Paths_stack as Meta+import Plugins+import Plugins.Commands+import Stack.Build+import Stack.Build.Types+import Stack.Config+import Stack.Constants+import qualified Stack.Docker as Docker+import Stack.Fetch+import Stack.GhcPkg (envHelper)+import qualified Stack.PackageIndex+import Stack.Path+import Stack.Setup+import Stack.Types+import Stack.Types.StackT+import System.Environment (getArgs, getProgName)+import System.Exit+import System.FilePath (searchPathSeparator)+import System.IO (stderr)+import qualified System.Process as P+import qualified System.Process.Read++-- | Commandline dispatcher.+main :: IO ()+main =+ do plugins <- findPlugins (T.pack stackProgName)+ tryRunPlugin plugins+ Docker.checkVersions+ progName <- getProgName+ args <- getArgs+ execExtraHelp args+ dockerHelpOptName+ (Docker.dockerOptsParser True)+ ("Only showing --" ++ Docker.dockerCmdName ++ "* options.")+ (level,run) <-+ simpleOptions+ $(simpleVersion Meta.version)+ "stack - The Haskell Tool Stack"+ ""+ (extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> globalOpts)+ (do addCommand "build"+ "Build the project(s) in this directory/configuration"+ (buildCmd DoNothing)+ buildOpts+ addCommand "test"+ "Build and test the project(s) in this directory/configuration"+ (buildCmd DoTests)+ buildOpts+ addCommand "bench"+ "Build and benchmark the project(s) in this directory/configuration"+ (buildCmd DoBenchmarks)+ buildOpts+ addCommand "haddock"+ "Generate haddocks for the project(s) in this directory/configuration"+ (buildCmd DoHaddock)+ buildOpts+ addCommand "setup"+ "Get the appropriate ghc for your project"+ setupCmd+ setupParser+ addCommand "unpack"+ "Unpack one or more packages locally"+ unpackCmd+ (some $ strArgument $ metavar "PACKAGE")+ addCommand "update"+ "Update the package index"+ updateCmd+ (pure ())+ addCommand "exec"+ "Execute a command"+ execCmd+ ((,)+ <$> strArgument (metavar "[--] CMD")+ <*> many (strArgument (metavar "ARGS")))+ addCommand "ghc"+ "Run ghc"+ execCmd+ ((,)+ <$> pure "ghc"+ <*> many (strArgument (metavar "ARGS")))+ addCommand "ghci"+ "Run ghci"+ execCmd+ ((,)+ <$> pure "ghci"+ <*> many (strArgument (metavar "ARGS")))+ addCommand "runghc"+ "Run runghc"+ execCmd+ ((,)+ <$> pure "runghc"+ <*> many (strArgument (metavar "ARGS")))+ addCommand "clean"+ "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"+ (do addCommand "ghc"+ "Print path to the ghc executable in use"+ pathCmd+ (pure PathGhc)+ addCommand "log"+ "Print path to the log directory in use"+ pathCmd+ (pure PathLog)+ addCommand "package-db"+ "Print the package databases in use"+ pathCmd+ (pure PathPackageDb))+ addSubCommands+ Docker.dockerCmdName+ "Subcommands specific to Docker use"+ (do addCommand Docker.dockerPullCmdName+ "Pull latest version of Docker image from registry"+ dockerPullCmd+ (pure ())+ addCommand "reset"+ "Reset the Docker sandbox"+ dockerResetCmd+ (flag False True (long "keep-home" <>+ help "Do not delete sandbox's home directory"))+ addCommand Docker.dockerCleanupCmdName+ "Clean up Docker images and containers"+ dockerCleanupCmd+ dockerCleanupOpts+ addCommand "exec"+ "Execute a command in a Docker container without setting up Haskell environment first"+ dockerExecCmd+ ((,) <$> strArgument (metavar "[--] CMD")+ <*> many (strArgument (metavar "ARGS"))))+ commandsFromPlugins plugins pluginShouldHaveRun)+ run level `catch` \e -> do+ -- This special handler stops "stack: " from being printed before the+ -- exception+ case fromException e of+ Just ec -> exitWith ec+ Nothing -> do+ print e+ exitFailure+ where+ dockerHelpOptName = Docker.dockerCmdName ++ "-help"+++pathCmd :: PathArg -> GlobalOpts -> IO ()+pathCmd pathArg go@GlobalOpts{..} = do+ (manager,lc) <- loadConfigWithOpts go+ buildConfig <- runStackLoggingT manager globalLogLevel (lcLoadBuildConfig lc ExecStrategy)+ runStackT manager globalLogLevel buildConfig (pathString pathArg) >>= putStrLn+++-- Try to run a plugin+tryRunPlugin :: Plugins -> IO ()+tryRunPlugin plugins = do+ args <- getArgs+ case dropWhile (List.isPrefixOf "-") args of+ ((T.pack -> name):args')+ | isJust (lookupPlugin plugins name) -> do+ callPlugin plugins name args' `catch` onPluginErr+ exitSuccess+ _ -> return ()+-- TODO(danburton): use logger+onPluginErr :: PluginException -> IO ()+onPluginErr (PluginNotFound _ name) = do+ T.hPutStr stderr $ "Stack plugin not found: " <> name+ exitFailure+onPluginErr (PluginExitFailure _ i) = do+ exitWith (ExitFailure i)++-- TODO(danburton): improve this, although it should never happen+pluginShouldHaveRun :: Plugin -> GlobalOpts -> IO ()+pluginShouldHaveRun _plugin _globalOpts = do+ fail "Plugin should have run"+++data SetupCmdOpts = SetupCmdOpts+ { scoGhcVersion :: !(Maybe Version)+ , scoForceReinstall :: !Bool+ }++setupParser :: Parser SetupCmdOpts+setupParser = SetupCmdOpts+ <$> (optional $ argument readVersion (metavar "VERSION"))+ <*> boolFlags False+ "reinstall"+ "Reinstall GHC, even if available (implies no-system-ghc)"+ idm+ where+ readVersion = do+ s <- readerAsk+ case parseVersionFromString s of+ Nothing -> readerError $ "Invalid version: " ++ s+ Just x -> return x++setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()+setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do+ (manager,lc) <- loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $+ Docker.rerunWithOptionalContainer+ (lcConfig lc)+ (lcProjectRoot lc)+ (runStackLoggingT manager globalLogLevel $ do+ (ghc, mstack) <-+ case scoGhcVersion of+ Just v -> return (v, Nothing)+ Nothing -> do+ bc <- lcLoadBuildConfig lc ThrowException+ return (bcGhcVersion bc, Just $ bcStackYaml bc)+ mpaths <- runStackT manager globalLogLevel (lcConfig lc) $ ensureGHC SetupOpts+ { soptsInstallIfMissing = True+ , soptsUseSystem = globalSystemGhc && not scoForceReinstall+ , soptsExpected = ghc+ , soptsStackYaml = mstack+ , soptsForceReinstall = scoForceReinstall+ }+ case mpaths of+ Nothing -> $logInfo "GHC on PATH would be used"+ Just paths -> $logInfo $ "Would add the following to PATH: "+ <> T.pack (intercalate [searchPathSeparator] paths)+ )++withBuildConfig :: GlobalOpts+ -> NoBuildConfigStrategy+ -> StackT BuildConfig IO ()+ -> IO ()+withBuildConfig go@GlobalOpts{..} strat inner = do+ (manager, lc) <- loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $+ 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++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+ s <- readerAsk+ case parsePackageNameFromString s of+ Nothing -> readerError $ "Invalid package name: " ++ s+ Just x -> return x++-- | Parser for package:[-]flag+readFlag :: ReadM (Map PackageName (Map FlagName Bool))+readFlag = do+ s <- readerAsk+ case break (== ':') s of+ (pn, ':':mflag) -> do+ pn' <-+ case parsePackageNameFromString pn of+ Nothing -> readerError $ "Invalid package name: " ++ pn+ Just x -> return x+ let (b, flagS) =+ case mflag of+ '-':x -> (False, x)+ _ -> (True, mflag)+ flagN <-+ case parseFlagNameFromString flagS of+ Nothing -> readerError $ "Invalid flag name: " ++ flagS+ Just x -> return x+ return $ Map.singleton pn' $ Map.singleton flagN b+ _ -> readerError "Must have a colon"++-- | Build the project.+buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()+buildCmd finalAction opts go@GlobalOpts{..} = withBuildConfig go CreateConfig $+ Stack.Build.build opts { boptsFinalAction = finalAction }++-- | Unpack packages to the filesystem+unpackCmd :: [String] -> GlobalOpts -> IO ()+unpackCmd names go@GlobalOpts{..} = do+ (manager,lc) <- loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $+ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $+ runStackT manager globalLogLevel (lcConfig lc) $ do+ menv <- getMinimalEnvOverride+ Stack.Fetch.unpackPackages menv "." names++-- | Update the package index+updateCmd :: () -> GlobalOpts -> IO ()+updateCmd () go@GlobalOpts{..} = do+ (manager,lc) <- loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $+ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $+ runStackT manager globalLogLevel (lcConfig lc) $+ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices++-- | Execute a command+execCmd :: (String, [String]) -> GlobalOpts -> IO ()+execCmd (cmd, args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do+ config <- asks getConfig+ liftIO $ do+ menv <- configEnvOverride config+ EnvSettings+ { esIncludeLocals = True+ , esIncludeGhcPackagePath = True+ }+ cmd' <- join $ System.Process.Read.findExecutable menv cmd+ let cp = (P.proc (toFilePath cmd') args)+ { P.env = envHelper menv+ , P.delegate_ctlc = True+ }++ (Nothing, Nothing, Nothing, ph) <- P.createProcess cp+ ec <- P.waitForProcess ph+ exitWith ec++-- | Pull the current Docker image.+dockerPullCmd :: () -> GlobalOpts -> IO ()+dockerPullCmd _ go@GlobalOpts{..} = do+ (manager,lc) <- liftIO $ loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ Docker.pull (lcConfig lc)++-- | Reset the Docker sandbox.+dockerResetCmd :: Bool -> GlobalOpts -> IO ()+dockerResetCmd keepHome go@GlobalOpts{..} = do+ (manager,lc) <- liftIO (loadConfigWithOpts go)+ runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ Docker.reset (lcProjectRoot lc) keepHome++-- | Cleanup Docker images and containers.+dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()+dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do+ (manager,lc) <- liftIO $ loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ Docker.cleanup (lcConfig lc) cleanupOpts++-- | Execute a command+dockerExecCmd :: (String, [String]) -> GlobalOpts -> IO ()+dockerExecCmd (cmd,args) go@GlobalOpts{..} = do+ (manager,lc) <- liftIO $ loadConfigWithOpts go+ runStackLoggingT manager globalLogLevel $ Docker.preventInContainer $+ Docker.rerunCmdWithRequiredContainer (lcConfig lc)+ (lcProjectRoot lc)+ (return (cmd,args,lcConfig lc))++-- | Parser for build arguments.+buildOpts :: Parser BuildOpts+buildOpts = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>+ optimize <*> finalAction <*> dryRun <*> ghcOpts <*> flags+ where optimize =+ maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm+ target =+ fmap (Left . map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help "If none specified, use all packages defined in current directory")))+ libProfiling =+ boolFlags False+ "library-profiling"+ "library profiling for TARGETs and all its dependencies"+ idm+ exeProfiling =+ boolFlags False+ "executable-profiling"+ "library profiling for TARGETs and all its dependencies"+ idm+ finalAction = pure DoNothing+ dryRun = flag False True (long "dry-run" <>+ help "Don't build anything, just prepare to")+ ghcOpts =+ many (fmap T.pack+ (strOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHC")))++ flags =+ fmap (Map.unionsWith Map.union) $ many+ (option readFlag+ ( long "flag"+ <> metavar "PACKAGE:[-]FLAG"+ <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)"+ ))++-- | Parser for docker cleanup arguments.+dockerCleanupOpts :: Parser Docker.CleanupOpts+dockerCleanupOpts =+ Docker.CleanupOpts <$>+ (flag' Docker.CleanupInteractive+ (short 'i' <>+ long "interactive" <>+ help "Show cleanup plan in editor and allow changes (default)") <|>+ flag' Docker.CleanupImmediate+ (short 'y' <>+ long "immediate" <>+ help "Immediately execute cleanup plan") <|>+ flag' Docker.CleanupDryRun+ (short 'n' <>+ long "dry-run" <>+ help "Display cleanup plan but do not execute") <|>+ pure Docker.CleanupInteractive) <*>+ opt (Just 14) "known-images" "LAST-USED" <*>+ opt Nothing "unknown-images" "CREATED" <*>+ opt (Just 0) "dangling-images" "CREATED" <*>+ opt Nothing "stopped-containers" "CREATED" <*>+ opt Nothing "running-containers" "CREATED"+ where opt def' name mv =+ fmap Just+ (option auto+ (long name <>+ metavar (mv ++ "-DAYS-AGO") <>+ help ("Remove " +++ toDescr name +++ " " +++ map toLower (toDescr mv) +++ " N days ago" +++ case def' of+ Just n -> " (default " ++ show n ++ ")"+ Nothing -> ""))) <|>+ flag' Nothing+ (long ("no-" ++ name) <>+ help ("Do not remove " +++ toDescr name +++ case def' of+ Just _ -> ""+ Nothing -> " (default)")) <|>+ pure def'+ toDescr = map (\c -> if c == '-' then ' ' else c)++-- | Parser for global command-line options.+globalOpts :: Parser GlobalOpts+globalOpts =+ 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+logLevelOpt =+ fmap parse+ (strOption (long "verbosity" <>+ metavar "VERBOSITY" <>+ help "Verbosity: silent, error, warn, info, debug")) <|>+ flag defaultLogLevel+ verboseLevel+ (short 'v' <>+ help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\""))+ where verboseLevel = LevelDebug+ showLevel l =+ case l of+ LevelDebug -> "debug"+ LevelInfo -> "info"+ LevelWarn -> "warn"+ LevelError -> "error"+ LevelOther x -> T.unpack x+ parse s =+ case s of+ "debug" -> LevelDebug+ "info" -> LevelInfo+ "warn" -> LevelWarn+ "error" -> LevelError+ _ -> LevelOther (T.pack s)++-- | Default logging level should be something useful but not crazy.+defaultLogLevel :: LogLevel+defaultLogLevel = LevelInfo++-- | Parsed global command-line options.+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+-- throughout this module.+loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))+loadConfigWithOpts GlobalOpts{..} = do+ manager <- newTLSManager+ lc <- runStackLoggingT+ manager+ globalLogLevel+ (loadConfig globalConfigMonoid)+ return (manager,lc)
+ src/main/Plugins.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Dynamically look up available executables.+module Plugins+ ( Plugin+ , pluginPrefix+ , pluginName+ , pluginSummary+ , pluginProc++ , Plugins+ , findPlugins+ , listPlugins+ , lookupPlugin+ , callPlugin++ , PluginException (..)+ ) where++import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT, get, put)+import Data.Conduit+import Data.Hashable (Hashable)+import Data.HashSet (HashSet)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Conduit.List as CL+import Data.Conduit.Lift (evalStateC)+import qualified Data.List as L+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Monoid+import System.Directory+import System.Process (CreateProcess, proc, readProcessWithExitCode, createProcess, waitForProcess)+import System.FilePath ((</>), getSearchPath, splitExtension)+import System.Exit (ExitCode (..))++-- | Represents a runnable plugin.+-- Plugins must be discovered via `findPlugins`.+data Plugin = Plugin+ { _pluginPrefix :: !Text+ , _pluginName :: !Text+ , _pluginSummary :: !Text+ }+ deriving (Show)++-- | The program being plugged into.+pluginPrefix :: Plugin -> Text+pluginPrefix = _pluginPrefix++-- | The name of this plugin (without the prefix).+pluginName :: Plugin -> Text+pluginName = _pluginName++-- | A summary of what this plugin does+pluginSummary :: Plugin -> Text+pluginSummary = _pluginSummary++-- | Describes how to create a process out of a plugin and arguments.+-- You may use Data.Process and Data.Conduit.Process+-- to manage the process's stdin, stdout, and stderr in various ways.+pluginProc :: Plugin -> [String] -> CreateProcess+pluginProc = proc . pluginProcessName++-- Not exported+pluginProcessName :: Plugin -> String+pluginProcessName p = unpack $ pluginPrefix p <> "-" <> pluginName p+++-- | Represents the plugins available to a given program.+-- See: `findPlugins`.+data Plugins = Plugins+ { _pluginsPrefix :: !Text+ , _pluginsMap :: !(HashMap Text Plugin)+ }+ deriving (Show)+++-- | Find the plugins for a given program by inspecting everything on the PATH.+-- Any program that is prefixed with the given name and responds+-- to the `--summary` flag by writing one line to stdout+-- is considered a plugin.+findPlugins :: Text -> IO Plugins+findPlugins t = fmap (Plugins t)+ $ discoverPlugins t+ $$ awaitForever (toPlugin t)+ =$ CL.fold insertPlugin HashMap.empty+ where+ insertPlugin m p = HashMap.insert (pluginName p) p m++toPlugin :: (MonadIO m) => Text -> Text -> Producer m Plugin+toPlugin prefix name = do+ let proc' = unpack $ prefix <> "-" <> name+ (exit, out, _err) <- liftIO $ readProcessWithExitCode proc' ["--summary"] ""+ case exit of+ ExitSuccess -> case T.lines (pack out) of+ [summary] -> yield $ Plugin+ { _pluginPrefix = prefix+ , _pluginName = name+ , _pluginSummary = summary+ }+ _ -> return ()+ _ -> return ()+++-- | Things that can go wrong when using `callPlugin`.+data PluginException+ = PluginNotFound !Plugins !Text+ | PluginExitFailure !Plugin !Int+ deriving (Show, Typeable)+instance Exception PluginException++-- | Look up a particular plugin by name.+lookupPlugin :: Plugins -> Text -> Maybe Plugin+lookupPlugin ps t = HashMap.lookup t $ _pluginsMap ps++-- | List the available plugins.+listPlugins :: Plugins -> [Plugin]+listPlugins = HashMap.elems . _pluginsMap++-- | A convenience wrapper around lookupPlugin and pluginProc.+-- Handles stdin, stdout, and stderr are all inherited by the plugin.+-- Throws PluginException.+callPlugin :: (MonadIO m, MonadThrow m)+ => Plugins -> Text -> [String] -> m ()+callPlugin ps name args = case lookupPlugin ps name of+ Nothing -> throwM $ PluginNotFound ps name+ Just plugin -> do+ exit <- liftIO $ do+ (_, _, _, process) <- createProcess $ pluginProc plugin args+ waitForProcess process+ case exit of+ ExitFailure i -> throwM $ PluginExitFailure plugin i+ ExitSuccess -> return ()+++discoverPlugins :: MonadIO m => Text -> Producer m Text+discoverPlugins t+ = getPathDirs+ $= clNub -- unique dirs on path+ $= awaitForever (executablesPrefixed $ unpack $ t <> "-")+ $= CL.map pack+ $= clNub -- unique executables++executablesPrefixed :: (MonadIO m) => FilePath -> FilePath -> Producer m FilePath+executablesPrefixed prefix dir+ = pathToContents dir+ $= CL.filter (L.isPrefixOf prefix)+ $= clFilterM (fileExistsIn dir)+ $= clFilterM (isExecutableIn dir)+ $= CL.mapMaybe (L.stripPrefix prefix . dropExeExt)++-- | Drop the .exe extension if present+dropExeExt :: FilePath -> FilePath+dropExeExt fp+ | y == ".exe" = x+ | otherwise = fp+ where+ (x, y) = splitExtension fp++getPathDirs :: (MonadIO m) => Producer m FilePath+getPathDirs = liftIO getSearchPath >>= mapM_ yield++pathToContents :: (MonadIO m) => FilePath -> Producer m FilePath+pathToContents dir = do+ exists <- liftIO $ doesDirectoryExist dir+ when exists $ do+ contents <- liftIO $ getDirectoryContents dir+ CL.sourceList contents++fileExistsIn :: (MonadIO m) => FilePath -> FilePath -> m Bool+fileExistsIn dir file = liftIO $ doesFileExist $ dir </> file++isExecutableIn :: (MonadIO m) => FilePath -> FilePath -> m Bool+isExecutableIn dir file = liftIO $ do+ perms <- getPermissions $ dir </> file+ return (executable perms)++clFilterM :: Monad m => (a -> m Bool) -> Conduit a m a+clFilterM pred' = awaitForever $ \a -> do+ predPassed <- lift $ pred' a+ when predPassed $ yield a++clNub :: (Monad m, Eq a, Hashable a)+ => Conduit a m a+clNub = evalStateC HashSet.empty clNubState++clNubState :: (Monad m, Eq a, Hashable a)+ => Conduit a (StateT (HashSet a) m) a+clNubState = awaitForever $ \a -> do+ seen <- lift get+ unless (HashSet.member a seen) $ do+ lift $ put $ HashSet.insert a seen+ yield a
+ src/main/Plugins/Commands.hs view
@@ -0,0 +1,27 @@+-- | Using Plugins with SimpleOptions+module Plugins.Commands+ ( commandsFromPlugins+ , commandFromPlugin+ , findPlugins+ , PluginException(..)+ ) where++import Control.Monad.Trans.Either (EitherT)+import Control.Monad.Trans.Writer (Writer)+import Data.Text (unpack)+import Plugins+import Options.Applicative.Simple++-- | Generate the "commands" argument to simpleOptions+-- based on available plugins.+commandsFromPlugins :: Plugins -> (Plugin -> a) -> EitherT a (Writer (Mod CommandFields a)) ()+commandsFromPlugins plugins f =+ mapM_ (\p -> commandFromPlugin p (f p)) (listPlugins plugins)++-- | Convert a single plugin into a command.+commandFromPlugin :: Plugin -> a -> EitherT a (Writer (Mod CommandFields a)) ()+commandFromPlugin plugin a = addCommand+ (unpack $ pluginName plugin)+ (unpack $ pluginSummary plugin)+ (const a)+ (pure ())
+ src/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ src/test/Stack/BuildPlanSpec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.BuildPlanSpec where++import Stack.BuildPlan+import Control.Monad.Logger+import Control.Exception hiding (try)+import Control.Monad.Catch (try)+import Data.Monoid+import qualified Data.Map as Map+import qualified Data.Set as Set+import Network.HTTP.Conduit (Manager)+import System.Directory+import System.IO.Temp+import System.Environment+import Test.Hspec+import Stack.Config+import Stack.Types+import Stack.Types.StackT++data T = T+ { manager :: Manager+ }++setup :: IO T+setup = do+ manager <- newTLSManager+ unsetEnv "STACK_YAML"+ return T{..}++teardown :: T -> IO ()+teardown _ = return ()++main :: IO ()+main = hspec spec++spec :: Spec+spec = beforeAll setup $ afterAll teardown $ do+ let logLevel = LevelDebug+ let loadConfig' m = runStackLoggingT m logLevel (loadConfig mempty)+ let loadBuildConfigRest m = runStackLoggingT m logLevel+ let inTempDir action = do+ currentDirectory <- getCurrentDirectory+ withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do+ let enterDir = setCurrentDirectory tempDir+ let exitDir = setCurrentDirectory currentDirectory+ bracket_ enterDir exitDir action+ it "finds missing transitive dependencies #159" $ \T{..} -> inTempDir $ do+ -- Note: this test is somewhat fragile, depending on packages on+ -- Hackage remaining in a certain state. If it fails, confirm that+ -- github still depends on failure.+ writeFile "stack.yaml" "resolver: lts-2.9"+ LoadConfig{..} <- loadConfig' manager+ bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig ThrowException)+ runStackT manager logLevel bconfig $ do+ menv <- getMinimalEnvOverride+ mbp <- loadMiniBuildPlan $ LTS 2 9+ eres <- try $ resolveBuildPlan+ menv+ mbp+ (const False)+ (Map.fromList+ [ ($(mkPackageName "github"), Set.empty)+ ])+ case eres of+ Left (UnknownPackages _ unknown _) -> do+ case Map.lookup $(mkPackageName "github") unknown of+ Nothing -> error "doesn't list github as unknown"+ Just _ -> return ()++ {- Currently not implemented, see: https://github.com/fpco/stack/issues/159#issuecomment-107809418+ case Map.lookup $(mkPackageName "failure") unknown of+ Nothing -> error "failure not listed"+ Just _ -> return ()+ -}+ _ -> error $ "Unexpected result from resolveBuildPlan: " ++ show eres+ return ()++ describe "shadowMiniBuildPlan" $ do+ let version = $(mkVersion "1.0.0") -- unimportant for this test+ pn = either throw id . parsePackageNameFromString+ mkMPI deps = MiniPackageInfo+ { mpiVersion = version+ , mpiFlags = Map.empty+ , mpiPackageDeps = Set.fromList $ map pn $ words deps+ , mpiToolDeps = Set.empty+ , mpiExes = Set.empty+ , mpiHasLibrary = True+ }+ go x y = (pn x, mkMPI y)+ resourcet = go "resourcet" ""+ conduit = go "conduit" "resourcet"+ conduitExtra = go "conduit-extra" "conduit"+ text = go "text" ""+ attoparsec = go "attoparsec" "text"+ aeson = go "aeson" "text attoparsec"+ mkMBP pkgs = MiniBuildPlan+ { mbpGhcVersion = version+ , mbpPackages = Map.fromList pkgs+ }+ mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson]+ test name input shadowed output extra =+ it name $ const $+ shadowMiniBuildPlan input (Set.fromList $ map pn $ words shadowed)+ `shouldBe` (output, Map.fromList extra)+ test "no shadowing" mbpAll "" mbpAll []+ test "shadow something that isn't there" mbpAll "does-not-exist" mbpAll []+ test "shadow a leaf" mbpAll "conduit-extra"+ (mkMBP [resourcet, conduit, text, attoparsec, aeson])+ []+ test "shadow direct dep" mbpAll "conduit"+ (mkMBP [resourcet, text, attoparsec, aeson])+ [conduitExtra]+ test "shadow deep dep" mbpAll "resourcet"+ (mkMBP [text, attoparsec, aeson])+ [conduit, conduitExtra]+ test "shadow deep dep and leaf" mbpAll "resourcet aeson"+ (mkMBP [text, attoparsec])+ [conduit, conduitExtra]+ test "shadow deep dep and direct dep" mbpAll "resourcet conduit"+ (mkMBP [text, attoparsec, aeson])+ [conduitExtra]
+ src/test/Stack/ConfigSpec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.ConfigSpec where++import Control.Applicative+import Control.Monad.Logger+import Control.Exception+import Data.Maybe+import Data.Monoid+import Network.HTTP.Conduit (Manager)+import Path+--import System.FilePath+import System.Directory+import System.IO.Temp+import System.Environment+import Test.Hspec++import Stack.Config+import Stack.Types.Config+import Stack.Types.StackT++sampleConfig :: String+sampleConfig =+ "resolver: lts-2.10\n" +++ "packages: ['.']\n"++stackDotYaml :: Path Rel File+stackDotYaml = $(mkRelFile "stack.yaml")++data T = T+ { manager :: Manager+ }++setup :: IO T+setup = do+ manager <- newTLSManager+ unsetEnv "STACK_YAML"+ return T{..}++teardown :: T -> IO ()+teardown _ = return ()++spec :: Spec+spec = beforeAll setup $ afterAll teardown $ do+ let logLevel = LevelDebug+ -- TODO(danburton): not use inTempDir+ let inTempDir action = do+ currentDirectory <- getCurrentDirectory+ withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do+ let enterDir = setCurrentDirectory tempDir+ let exitDir = setCurrentDirectory currentDirectory+ bracket_ enterDir exitDir action+ -- TODO(danburton): a safer version of this?+ let withEnvVar name newValue action = do+ originalValue <- fromMaybe "" <$> lookupEnv name+ let setVar = setEnv name newValue+ let resetVar = setEnv name originalValue+ bracket_ setVar resetVar action+++ describe "loadConfig" $ do+ let loadConfig' m = runStackLoggingT m logLevel (loadConfig mempty)+ let loadBuildConfigRest m = runStackLoggingT m logLevel+ -- TODO(danburton): make sure parent dirs also don't have config file+ it "works even if no config file exists" $ \T{..} -> example $ do+ _config <- loadConfig' manager+ return ()++ it "works with a blank config file" $ \T{..} -> inTempDir $ do+ writeFile (toFilePath stackDotYaml) ""+ -- TODO(danburton): more specific test for exception+ loadConfig' manager `shouldThrow` anyException++ it "finds the config file in a parent directory" $ \T{..} -> inTempDir $ do+ writeFile (toFilePath stackDotYaml) sampleConfig+ parentDir <- getCurrentDirectory >>= parseAbsDir+ let childDir = "child"+ createDirectory childDir+ setCurrentDirectory childDir+ LoadConfig{..} <- loadConfig' manager+ BuildConfig{..} <- loadBuildConfigRest manager+ (lcLoadBuildConfig ThrowException)+ bcRoot `shouldBe` parentDir++ it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do+ withSystemTempDirectory "config-is-here" $ \dirFilePath -> do+ dir <- parseAbsDir dirFilePath+ let stackYamlFp = toFilePath (dir </> stackDotYaml)+ writeFile stackYamlFp sampleConfig+ withEnvVar "STACK_YAML" stackYamlFp $ do+ LoadConfig{..} <- loadConfig' manager+ BuildConfig{..} <- loadBuildConfigRest manager+ (lcLoadBuildConfig ThrowException)+ bcRoot `shouldBe` dir++ it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do+ parentDir <- getCurrentDirectory >>= parseAbsDir+ let childRel = $(mkRelDir "child")+ yamlRel = childRel </> $(mkRelFile "some-other-name.config")+ yamlAbs = parentDir </> yamlRel+ createDirectoryIfMissing True $ toFilePath $ parent yamlAbs+ writeFile (toFilePath yamlAbs) "resolver: ghc-7.8"+ withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do+ LoadConfig{..} <- loadConfig' manager+ BuildConfig{..} <- loadBuildConfigRest manager+ (lcLoadBuildConfig ThrowException)+ bcStackYaml `shouldBe` yamlAbs
+ src/test/Stack/PackageDumpSpec.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Stack.PackageDumpSpec where++import Data.Conduit+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import Control.Monad.Trans.Resource (runResourceT)+import Stack.PackageDump+import Stack.Types+import Test.Hspec+import Test.Hspec.QuickCheck+import System.Process.Read+import Control.Monad.Logger+import Distribution.System (buildPlatform)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "eachSection" $ do+ let test name content expected = it name $ do+ actual <- yield content $$ eachSection CL.consume =$ CL.consume+ actual `shouldBe` expected+ test+ "unix line endings"+ "foo\nbar\n---\nbaz---\nbin\n---\n"+ [ ["foo", "bar"]+ , ["baz---", "bin"]+ ]+ test+ "windows line endings"+ "foo\r\nbar\r\n---\r\nbaz---\r\nbin\r\n---\r\n"+ [ ["foo", "bar"]+ , ["baz---", "bin"]+ ]++ it "eachPair" $ do+ let bss =+ [ "key1: val1"+ , "key2: val2a"+ , " val2b"+ , "key3:"+ , "key4:"+ , " val4a"+ , " val4b"+ ]+ sink k = fmap (k, ) CL.consume+ actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume+ actual `shouldBe`+ [ ("key1", ["val1"])+ , ("key2", ["val2a", "val2b"])+ , ("key3", [])+ , ("key4", ["val4a", "val4b"])+ ]++ describe "conduitDumpPackage" $ do+ it "ghc 7.8" $ do+ haskell2010:_ <- runResourceT+ $ CB.sourceFile "test/package-dump/ghc-7.8.txt"+ $$ conduitDumpPackage+ =$ CL.consume+ ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"+ depends <- mapM parseGhcPkgId+ [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"+ , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"+ , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37"+ ]+ haskell2010 `shouldBe` DumpPackage+ { dpGhcPkgId = ghcPkgId+ , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"]+ , dpDepends = depends+ , dpLibraries = ["HShaskell2010-1.1.2.0"]+ , dpProfiling = ()+ }++ it "ghc 7.10" $ do+ haskell2010:_ <- runResourceT+ $ CB.sourceFile "test/package-dump/ghc-7.10.txt"+ $$ conduitDumpPackage+ =$ CL.consume+ ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"+ depends <- mapM parseGhcPkgId+ [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"+ , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"+ , "bin-package-db-0.0.0.0-708fc7d634a370b311371a5bcde40b62"+ , "bytestring-0.10.6.0-0909f8f31271f3d75749190bf2ee35db"+ , "containers-0.5.6.2-2114032c163425cc264e6e1169dc2f6d"+ , "directory-1.2.2.0-b4959b472d9eee380c6b32291ade29e0"+ , "filepath-1.4.0.0-40d643aa87258c186441a1f8f3e13ca6"+ , "hoopl-3.10.0.2-8c8dfc4c3140e5f7c982da224c3cb1f0"+ , "hpc-0.6.0.2-ac9064885aa8cb08a93314222939ead4"+ , "process-1.2.3.0-3b1e9bca6ac38225806ff7bbf3f845b1"+ , "template-haskell-2.10.0.0-e895139a0ffff267d412e3d0191ce93b"+ , "time-1.5.0.1-e17a9220d438435579d2914e90774246"+ , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f"+ , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f"+ ]+ haskell2010 `shouldBe` DumpPackage+ { dpGhcPkgId = ghcPkgId+ , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"]+ , dpDepends = depends+ , dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"]+ , dpProfiling = ()+ }++ it "ghcPkgDump + addProfiling" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do+ menv' <- getEnvOverride buildPlatform+ menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv'+ pcache <- newProfilingCache+ ghcPkgDump menv Nothing+ $ conduitDumpPackage+ =$ addProfiling pcache+ =$ CL.sinkNull++ it "sinkMatching" $ do+ menv' <- getEnvOverride buildPlatform+ menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv'+ pcache <- newProfilingCache+ m <- runNoLoggingT $ ghcPkgDump menv Nothing+ $ conduitDumpPackage+ =$ addProfiling pcache+ =$ sinkMatching False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1"))+ case Map.lookup $(mkPackageName "base") m of+ Nothing -> error "base not present"+ Just _ -> return ()+ Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing+ Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing++ describe "pruneDeps" $ do+ it "sanity check" $ do+ let prunes =+ [ ((1, 'a'), [])+ , ((1, 'b'), [])+ , ((2, 'a'), [(1, 'b')])+ , ((2, 'b'), [(1, 'a')])+ , ((3, 'a'), [(1, 'c')])+ , ((4, 'a'), [(2, 'a')])+ ]+ actual = fmap fst $ pruneDeps fst fst snd bestPrune prunes+ actual `shouldBe` Map.fromList+ [ (1, (1, 'b'))+ , (2, (2, 'a'))+ , (4, (4, 'a'))+ ]++ prop "invariant holds" $ \prunes ->+ checkDepsPresent prunes $ fmap fst $ pruneDeps fst fst snd bestPrune prunes++type PruneCheck = ((Int, Char), [(Int, Char)])++bestPrune :: PruneCheck -> PruneCheck -> PruneCheck+bestPrune x y+ | fst x > fst y = x+ | otherwise = y++checkDepsPresent :: [PruneCheck] -> Map Int (Int, Char) -> Bool+checkDepsPresent prunes selected =+ all hasDeps $ Set.toList allIds+ where+ depMap = Map.fromList prunes+ allIds = Set.fromList $ Map.elems selected++ hasDeps ident =+ case Map.lookup ident depMap of+ Nothing -> error "checkDepsPresent: missing in depMap"+ Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds
+ src/test/Test.hs view
@@ -0,0 +1,5 @@+import Test.Hspec (hspec)+import Spec (spec)++main :: IO ()+main = hspec spec
stack.cabal view
@@ -1,14 +1,196 @@ name: stack-version: 0.0.0+version: 0.0.1 synopsis: The Haskell Tool Stack-license: MIT+description: Please see the README.md for usage information, and+ the wiki on Github for more details. Also, note that+ the API for the library is not currently stable, and may+ change significantly, even between minor releases. It is+ currently only intended for use by the executable.+license: BSD3 license-file: LICENSE-author: Dan Burton-maintainer: danburton.email@gmail.com+author: Chris Done+maintainer: chrisdone@fpcomplete.com+category: Development build-type: Simple cabal-version: >=1.10+extra-source-files: README.md ChangeLog.md+homepage: https://github.com/commercialhaskell/stack + -- Glob would be nice, but apparently Cabal doesn't support it:+ -- cabal: filepath wildcard 'test/package-dump/*.txt' does not match any files.+ -- Happened during cabal sdist+ test/package-dump/ghc-7.8.txt+ test/package-dump/ghc-7.10.txt++library+ hs-source-dirs: src/+ ghc-options: -Wall -pgmPcpphs -optP--cpp+ exposed-modules: Options.Applicative.Builder.Extra+ Stack.BuildPlan+ Stack.Config+ Stack.Constants+ Stack.Docker+ Stack.Docker.GlobalDB+ Stack.Fetch+ Stack.GhcPkg+ Stack.Package+ Stack.PackageDump+ Stack.PackageIndex+ Stack.Path+ Stack.Setup+ Stack.Types+ Stack.Types.Internal+ Stack.Types.BuildPlan+ Stack.Types.Config+ Stack.Types.Docker+ Stack.Types.FlagName+ Stack.Types.GhcPkgId+ Stack.Types.PackageIdentifier+ Stack.Types.PackageName+ Stack.Types.Version+ Stack.Types.StackT+ Stack.Build+ Stack.Build.Cache+ Stack.Build.ConstructPlan+ Stack.Build.Execute+ Stack.Build.Installed+ Stack.Build.Source+ Stack.Build.Types+ Stack.Build.Doc+ System.Process.Read+ Network.HTTP.Download.Verified+ other-modules: Network.HTTP.Download+ Control.Concurrent.Execute+ Path.Find+ Path.IO+ System.Process.PagerEditor+ Paths_stack+ 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+ , bifunctors >= 4.2.1+ , binary >= 0.7+ , base64-bytestring+ , bytestring+ , conduit >= 1.2.4+ , conduit-extra >= 1.1.7.1+ , containers >= 0.5.5.1+ , cryptohash >= 0.11.6+ , cryptohash-conduit+ , directory >= 1.2.1.0+ , enclosed-exceptions+ , exceptions >= 0.8.0.2+ , fast-logger >= 2.3.1+ , filepath >= 1.3.0.2+ , hashable >= 1.2.3.2+ , http-client >= 0.4.9+ , http-client-tls >= 0.2.2+ , http-conduit+ , http-types >= 0.8.6+ , lifted-base+ , monad-control+ , monad-logger >= 0.3.13.1+ , monad-loops >= 0.4.2.1+ , mtl >= 2.1.3.1+ , old-locale >= 1.0.0.6+ , optparse-applicative+ , path >= 0.5.0+ , persistent >= 2.1.2+ , persistent-sqlite >= 2.1.4+ , persistent-template >= 2.1.1+ , pretty+ , process >= 1.2.0.0+ , resourcet >= 1.1.4.1+ , safe >= 0.3+ , stm >= 2.4.4+ , streaming-commons >= 0.1.10.0+ , tar >= 0.4.1.0+ , template-haskell+ , temporary >= 1.2.0.3+ , text >= 1.2.0.4+ , time >= 1.4.2+ , transformers >= 0.3.0.0+ , transformers-base >= 0.4.4+ , unordered-containers >= 0.2.5.1+ , vector >= 0.10.12.3+ , vector-binary-instances+ , void >= 0.7+ , yaml >= 0.8.10.1+ , zlib >= 0.5.4.2+ , deepseq+ if !os(windows)+ build-depends: unix >= 2.7.0.1+ build-tools: cpphs+ default-language: Haskell2010+ executable stack- main-is: Main.hs- build-depends: base >=4.8 && <5+ hs-source-dirs: src/main+ main-is: Main.hs+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ other-modules: Plugins+ Plugins.Commands++ build-depends: base >=4.7 && < 5+ , bytestring >= 0.10.4.0+ , containers+ , exceptions+ , filepath+ , http-conduit >= 2.1.5+ , monad-logger >= 0.3.13.1+ , mtl >= 2.1.3.1+ , old-locale >= 1.0.0.6+ , optparse-applicative >= 0.11.0.2+ , optparse-simple >= 0.0.3+ , path+ , process+ , resourcet >= 1.1.4.1+ , stack+ , text >= 1.2.0.4+ , either+ , directory+ , split+ , unordered-containers+ , hashable+ , conduit+ , transformers+ , http-client default-language: Haskell2010++test-suite stack-test+ type: exitcode-stdio-1.0+ hs-source-dirs: src/test+ main-is: Test.hs+ other-modules: Spec+ , Stack.BuildPlanSpec+ , Stack.ConfigSpec+ , Stack.PackageDumpSpec+ ghc-options: -Wall -threaded+ build-depends: base >=4.7 && <5+ , hspec+ , containers+ , directory+ , exceptions+ , filepath+ , path+ , temporary+ , stack+ , monad-logger+ , http-conduit+ , cryptohash+ , transformers+ , conduit+ , conduit-extra+ , resourcet+ , Cabal+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/commercialhaskell/stack