diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.0.1 + +* First public release, beta quality diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 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. diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "The Haskell Tool Stack" diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,75 @@ +## The Haskell Tool Stack + +[![Build Status](https://travis-ci.org/commercialhaskell/stack.svg?branch=master)](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. + + + +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. diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Execute.hs @@ -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 diff --git a/src/Control/Monad/Logger/Sticky.hs b/src/Control/Monad/Logger/Sticky.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Logger/Sticky.hs @@ -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 ' ') diff --git a/src/Data/Attoparsec/Combinators.hs b/src/Data/Attoparsec/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Data/Attoparsec/Combinators.hs @@ -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 diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/VersionTagged.hs @@ -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 diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Extra.hs @@ -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 diff --git a/src/Data/Set/Monad.hs b/src/Data/Set/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Monad.hs @@ -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 diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Download.hs @@ -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 diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Download/Verified.hs @@ -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) diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Options/Applicative/Builder/Extra.hs @@ -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) diff --git a/src/Path/Find.hs b/src/Path/Find.hs new file mode 100644 --- /dev/null +++ b/src/Path/Find.hs @@ -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)) diff --git a/src/Path/IO.hs b/src/Path/IO.hs new file mode 100644 --- /dev/null +++ b/src/Path/IO.hs @@ -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)) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build.hs @@ -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 + -} +--} diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Cache.hs @@ -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)) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/ConstructPlan.hs @@ -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) diff --git a/src/Stack/Build/Doc.hs b/src/Stack/Build/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Doc.hs @@ -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) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Execute.hs @@ -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") diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Installed.hs @@ -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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Source.hs @@ -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) diff --git a/src/Stack/Build/Types.hs b/src/Stack/Build/Types.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Build/Types.hs @@ -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 diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs new file mode 100644 --- /dev/null +++ b/src/Stack/BuildPlan.hs @@ -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 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Config.hs @@ -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) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Constants.hs @@ -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" diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Docker.hs @@ -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 == "" -> (hash,[]) + | tag == "" -> (hash,[repo]) + | otherwise -> (hash,[repo ++ ":" ++ tag]) + _ -> throw (InvalidImagesOutputException line) + parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8 + where parseContainer line = + case words line of + hash:image:rest -> (hash,(image,last rest)) + _ -> throw (InvalidPSOutputException line) + buildPlan curTime + imagesLastUsed + imageRepos + danglingImageHashes + stoppedContainers + runningContainers + inspectMap = + do case dcAction opts of + CleanupInteractive -> + do buildStrLn + (concat + ["# STACK DOCKER CLEANUP PLAN" + ,"\n#" + ,"\n# When you leave the editor, the lines in this plan will be processed." + ,"\n#" + ,"\n# Lines that begin with 'R' denote an image or container that will be." + ,"\n# removed. You may change the first character to/from 'R' to remove/keep" + ,"\n# and image or container that would otherwise be kept/removed." + ,"\n#" + ,"\n# To cancel the cleanup, delete all lines in this file." + ,"\n#" + ,"\n# By default, the following images/containers will be removed:" + ,"\n#"]) + buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used" + buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created" + buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created" + buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created" + buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created" + buildStrLn + (concat + ["#" + ,"\n# The default plan can be adjusted using command-line arguments." + ,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] ++ + " --help' for details." + ,"\n#"]) + _ -> buildStrLn + (unlines + ["# Lines that begin with 'R' denote an image or container that will be." + ,"# removed."]) + buildSection "KNOWN IMAGES (pulled/used by stack)" + imagesLastUsed + buildKnownImage + buildSection "UNKNOWN IMAGES (not managed by stack)" + (sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m) + imageRepos + imagesLastUsed))) + buildUnknownImage + buildSection "DANGLING IMAGES (no named references and not depended on by other images)" + (sortCreated (map (,()) danglingImageHashes)) + buildDanglingImage + buildSection "STOPPED CONTAINERS" + (sortCreated stoppedContainers) + (buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts)) + buildSection "RUNNING CONTAINERS" + (sortCreated runningContainers) + (buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts)) + where + buildDefault accessor description = + case accessor opts of + Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".") + Nothing -> return () + sortCreated 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] diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Docker/GlobalDB.hs @@ -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)]) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Fetch.hs @@ -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 diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/src/Stack/GhcPkg.hs @@ -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") diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Package.hs @@ -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 _ = "" + +-- | 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 diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs new file mode 100644 --- /dev/null +++ b/src/Stack/PackageDump.hs @@ -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 diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/src/Stack/PackageIndex.hs @@ -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) diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Path.hs @@ -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" diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Setup.hs @@ -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." diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types.hs @@ -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 diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/BuildPlan.hs @@ -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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Config.hs @@ -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 + } diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Docker.hs @@ -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" diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/FlagName.hs @@ -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 diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/GhcPkgId.hs @@ -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 diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Internal.hs @@ -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 diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/PackageIdentifier.hs @@ -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 diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/PackageName.hs @@ -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 diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/StackT.hs @@ -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 diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Version.hs @@ -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 diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/PagerEditor.hs @@ -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 diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Read.hs @@ -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 + ] diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -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) diff --git a/src/main/Plugins.hs b/src/main/Plugins.hs new file mode 100644 --- /dev/null +++ b/src/main/Plugins.hs @@ -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 diff --git a/src/main/Plugins/Commands.hs b/src/main/Plugins/Commands.hs new file mode 100644 --- /dev/null +++ b/src/main/Plugins/Commands.hs @@ -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 ()) diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Stack/BuildPlanSpec.hs @@ -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] diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Stack/ConfigSpec.hs @@ -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 diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Stack/PackageDumpSpec.hs @@ -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 diff --git a/src/test/Test.hs b/src/test/Test.hs new file mode 100644 --- /dev/null +++ b/src/test/Test.hs @@ -0,0 +1,5 @@ +import Test.Hspec (hspec) +import Spec (spec) + +main :: IO () +main = hspec spec diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -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