From 99f7fa83377322aa2dc5bb9a31d28b82409a75cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Thu, 22 Oct 2015 18:00:35 +0200 Subject: [PATCH 01/56] Added config parsing for nix-shell execution environment --- src/Stack/Config.hs | 2 + src/Stack/Config/ExecEnv.hs | 69 +++ src/Stack/ExecEnv/NixShell.hs | 923 ++++++++++++++++++++++++++++++++++ src/Stack/Types.hs | 1 + src/Stack/Types/Config.hs | 8 + src/Stack/Types/ExecEnv.hs | 155 ++++++ src/main/Main.hs | 3 +- stack.cabal | 4 + stack.yaml | 1 + 9 files changed, 1165 insertions(+), 1 deletion(-) create mode 100644 src/Stack/Config/ExecEnv.hs create mode 100644 src/Stack/ExecEnv/NixShell.hs create mode 100644 src/Stack/Types/ExecEnv.hs diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 058a65aa56..40a935532e 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -68,6 +68,7 @@ import Safe (headMay) import Stack.BuildPlan import Stack.Constants import Stack.Config.Docker +import Stack.Config.ExecEnv import qualified Stack.Image as Image import Stack.Init import Stack.Types @@ -143,6 +144,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts + configExecEnv <- execEnvOptsFromMonoid mproject configStackRoot configMonoidExecEnvOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform diff --git a/src/Stack/Config/ExecEnv.hs b/src/Stack/Config/ExecEnv.hs new file mode 100644 index 0000000000..aca80d2b81 --- /dev/null +++ b/src/Stack/Config/ExecEnv.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-} + +-- | Docker configuration +module Stack.Config.ExecEnv where + +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.Catch (throwM, MonadThrow) +import Data.List (find) +import Data.Maybe +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Path +import Stack.Types + +-- | Interprets DockerOptsMonoid options. +execEnvOptsFromMonoid + :: MonadThrow m + => Maybe Project -> Path Abs Dir -> ExecEnvOptsMonoid -> m ExecEnvOpts +execEnvOptsFromMonoid mproject stackRoot ExecEnvOptsMonoid{..} = do + let execEnvType = + if fromMaybe execEnvMonoidDefaultEnable execEnvMonoidEnable + then Just NixShellExecEnv + else Nothing + execEnvPackages = execEnvMonoidPackages + {- dockerContainerName = emptyToNothing dockerMonoidContainerName + dockerRunArgs = dockerMonoidRunArgs + dockerMount = dockerMonoidMount + dockerEnv = dockerMonoidEnv + dockerDatabasePath <- + case dockerMonoidDatabasePath of + Nothing -> return $ stackRoot $(mkRelFile "docker.db") + Just fp -> + case parseAbsFile fp of + Left e -> throwM (InvalidDatabasePathException e) + Right p -> return p + dockerStackExe <- + case dockerMonoidStackExe of + Just e -> liftM Just (parseDockerStackExe e) + Nothing -> return Nothing -} + return ExecEnvOpts{..} + +{- where emptyToNothing Nothing = Nothing + emptyToNothing (Just s) | null s = Nothing + | otherwise = Just s + +-- | Exceptions thrown by Stack.Docker.Config. +data StackNixConfigException + = ResolverNotSupportedException String + -- ^ Only LTS resolvers are supported for default image tag. + | InvalidDatabasePathException SomeException + -- ^ Invalid global database path. + deriving (Typeable) + +-- | Exception instance for StackDockerConfigException. +instance Exception StackDockerConfigException + +-- | Show instance for StackDockerConfigException. +instance Show StackDockerConfigException where + show (ResolverNotSupportedException resolver) = + concat + [ "Resolver not supported for Docker images:\n " + , resolver + , "\nUse an LTS resolver, or set the '" + , T.unpack dockerImageArgName + , "' explicitly, in your configuration file."] + show (InvalidDatabasePathException ex) = + concat ["Invalid database path: ", show ex] +-} diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs new file mode 100644 index 0000000000..69405e2f49 --- /dev/null +++ b/src/Stack/ExecEnv/NixShell.hs @@ -0,0 +1,923 @@ +{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns, + OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskell, + TupleSections #-} + +-- | Run commands in a nix-shell +module Stack.ExecEnv.NixShell + (cleanup + ,CleanupOpts(..) + ,CleanupAction(..) + ,dockerCleanupCmdName + ,dockerCmdName + ,dockerPullCmdName + ,execWithOptionalContainer + ,preventInContainer + ,pull + ,reexecWithOptionalContainer + ,reset + ,reExecArgName + ,M + ) where + +import Control.Applicative +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.Catch (MonadThrow,throwM,MonadCatch,MonadMask) +import Control.Monad.IO.Class (MonadIO,liftIO) +import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) +import Control.Monad.Reader (MonadReader,asks) +import Control.Monad.Writer (execWriter,runWriter,tell) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) +import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Char (isSpace,toUpper,isAscii,isDigit) +import Data.Conduit.List (sinkNull) +import Data.List (dropWhileEnd,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) +import Data.List.Extra (trim) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) +import Data.Typeable (Typeable) +import Data.Version (showVersion) +import Distribution.System (Platform (Platform), Arch (X86_64), OS (Linux)) +import Distribution.Text (display) +import Network.HTTP.Client.Conduit (HasHttpManager) +import Path +import Path.Extra (toFilePathNoTrailingSep) +import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists) +import qualified Paths_stack as Meta +import Prelude -- Fix redundant import warnings +import Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar) +import Stack.Docker.GlobalDB +import Stack.Types +import Stack.Types.Internal +import Stack.Setup (ensureDockerStackExe) +import System.Directory (canonicalizePath, getModificationTime) +import System.Environment (lookupEnv,getProgName, getArgs,getExecutablePath) +import System.Exit (exitSuccess, exitWith) +import System.FilePath (takeBaseName) +import System.IO (stderr,stdin,stdout,hIsTerminalDevice) +import System.Process.PagerEditor (editByteString) +import System.Process.Read +import System.Process.Run +import System.Process (CreateProcess(delegate_ctlc)) +import Text.Printf (printf) + +#ifndef WINDOWS +import Control.Monad.Trans.Control (liftBaseWith) +import System.Posix.Signals +#endif + +-- | If Docker is enabled, re-runs the currently running OS command in a Docker container. +-- Otherwise, runs the inner action. +-- +-- This takes an optional release action which should be taken IFF control is +-- transfering away from the current process to the intra-container one. The main use +-- for this is releasing a lock. After launching reexecution, the host process becomes +-- nothing but an manager for the call into docker and thus may not hold the lock. +reexecWithOptionalContainer + :: M env m + => Maybe (Path Abs Dir) + -> Maybe (m ()) + -> IO () + -> Maybe (m ()) + -> Maybe (m ()) + -> m () +reexecWithOptionalContainer mprojectRoot = + execWithOptionalContainer mprojectRoot getCmdArgs + where + getCmdArgs envOverride imageInfo = do + config <- asks getConfig + args <- + fmap + (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) + (liftIO getArgs) + case dockerStackExe (configDocker config) of + Just DockerStackExeHost + | configPlatform config == dockerContainerPlatform -> + fmap (cmdArgs args) (liftIO getExecutablePath) + | otherwise -> throwM UnsupportedStackExeHostPlatformException + Just DockerStackExeImage -> do + progName <- liftIO getProgName + return (takeBaseName progName, args, [], []) + Just (DockerStackExePath path) -> + fmap + (cmdArgs args) + (liftIO $ canonicalizePath (toFilePath path)) + Just DockerStackExeDownload -> exeDownload args + Nothing + | configPlatform config == dockerContainerPlatform -> do + (exePath,exeTimestamp,misCompatible) <- + liftIO $ + do exePath <- liftIO getExecutablePath + exeTimestamp <- liftIO (getModificationTime exePath) + isKnown <- + liftIO $ + getDockerImageExe + config + (iiId imageInfo) + exePath + exeTimestamp + return (exePath, exeTimestamp, isKnown) + case misCompatible of + Just True -> do + return (cmdArgs args exePath) + Just False -> do + exeDownload args + Nothing -> do + e <- + try $ + sinkProcessStderrStdout + Nothing + envOverride + "docker" + [ "run" + , "-v" + , exePath ++ ":" ++ "/tmp/stack" + , iiId imageInfo + , "/tmp/stack" + , "--version"] + sinkNull + sinkNull + let compatible = + case e of + Left (ProcessExitedUnsuccessfully _ _) -> + False + Right _ -> True + liftIO $ + setDockerImageExe + config + (iiId imageInfo) + exePath + exeTimestamp + compatible + if compatible + then return (cmdArgs args exePath) + else exeDownload args + Nothing + | otherwise -> do + exeDownload args + exeDownload args = + fmap + (cmdArgs args . toFilePath) + (ensureDockerStackExe dockerContainerPlatform) + cmdArgs args exePath = + let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] + in (mountPath, args, [], [Mount exePath mountPath]) + +-- | If Docker is enabled, re-runs the OS command returned by the second argument in a +-- Docker container. Otherwise, runs the inner action. +-- +-- This takes an optional release action just like `reexecWithOptionalContainer`. +execWithOptionalContainer + :: M env m + => Maybe (Path Abs Dir) + -> (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) + -> Maybe (m ()) + -> IO () + -> Maybe (m ()) + -> Maybe (m ()) + -> m () +execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease = + do config <- asks getConfig + inContainer <- getInContainer + isReExec <- asks getReExec + if | inContainer && not isReExec && (isJust mbefore || isJust mafter) -> + throwM OnlyOnHostException + | inContainer -> + liftIO (do inner + exitSuccess) + | not (dockerEnable (configDocker config)) -> + do fromMaybeAction mbefore + liftIO inner + fromMaybeAction mafter + liftIO exitSuccess + | otherwise -> + do fromMaybeAction mrelease + runContainerAndExit + getCmdArgs + mprojectRoot + (fromMaybeAction mbefore) + (fromMaybeAction mafter) + where + fromMaybeAction Nothing = return () + fromMaybeAction (Just hook) = hook + +-- | Error if running in a container. +preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m () +preventInContainer inner = + do inContainer <- getInContainer + if inContainer + then throwM OnlyOnHostException + else inner + +-- | 'True' if we are currently running inside a Docker container. +getInContainer :: (MonadIO m) => m Bool +getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar) + +-- | Run a command in a new Docker container, then exit the process. +runContainerAndExit :: M env m + => (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) + -> Maybe (Path Abs Dir) + -> m () + -> m () + -> m () +runContainerAndExit getCmdArgs + mprojectRoot + before + after = + do config <- asks getConfig + let docker = configDocker config + envOverride <- getEnvOverride (configPlatform config) + checkDockerVersion envOverride + (dockerHost,dockerCertPath,bamboo,jenkins) <- + liftIO ((,,,) <$> lookupEnv "DOCKER_HOST" + <*> lookupEnv "DOCKER_CERT_PATH" + <*> lookupEnv "bamboo_buildKey" + <*> lookupEnv "JENKINS_HOME") + let isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost + userEnvVars <- + if fromMaybe (not isRemoteDocker) (dockerSetUser docker) + then do + uidOut <- readProcessStdout Nothing envOverride "id" ["-u"] + gidOut <- readProcessStdout Nothing envOverride "id" ["-g"] + return + [ "-e","WORK_UID=" ++ dropWhileEnd isSpace (decodeUtf8 uidOut) + , "-e","WORK_GID=" ++ dropWhileEnd isSpace (decodeUtf8 gidOut) ] + else return [] + isStdoutTerminal <- asks getTerminal + (isStdinTerminal,isStderrTerminal) <- + liftIO ((,) <$> hIsTerminalDevice stdin + <*> hIsTerminalDevice stderr) + pwd <- getWorkingDir + when (isRemoteDocker && + maybe False (isInfixOf "boot2docker") dockerCertPath) + ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") + let image = dockerImage docker + maybeImageInfo <- inspect envOverride image + imageInfo <- case maybeImageInfo of + Just ii -> return ii + Nothing + | dockerAutoPull docker -> + do pullImage envOverride docker image + mii2 <- inspect envOverride image + case mii2 of + Just ii2 -> return ii2 + Nothing -> throwM (InspectFailedException image) + | otherwise -> throwM (NotPulledException image) + (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride imageInfo + let imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo)) + sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) + 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 = not (dockerDetach docker) && + isStdinTerminal && + isStdoutTerminal && + isStderrTerminal + keepStdinOpen = not (dockerDetach docker) && + -- Workaround for https://github.com/docker/docker/issues/12319 + (isTerm || (isNothing bamboo && isNothing jenkins)) + liftIO + (do updateDockerImageLastUsed config + (iiId imageInfo) + (toFilePath projectRoot) + + mapM_ createTree + (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ + sandboxSubdirs])) + containerID <- (trim . decodeUtf8) <$> readDockerProcess + envOverride + (concat + [["create" + ,"--net=host" + ,"-e",inContainerEnvVar ++ "=1" + ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot + ,"-e","WORK_WD=" ++ toFilePathNoTrailingSep pwd + ,"-e","WORK_HOME=" ++ toFilePathNoTrailingSep sandboxRepoDir + ,"-e","WORK_ROOT=" ++ toFilePathNoTrailingSep projectRoot + ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot + ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot + ,"-v",toFilePathNoTrailingSep sandboxSandboxDir ++ ":" ++ toFilePathNoTrailingSep sandboxDir + ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxRepoDir + ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ + toFilePathNoTrailingSep (sandboxRepoDir $(mkRelDir ("." ++ stackProgName ++ "/")))] + ,userEnvVars + ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars + ,concatMap sandboxSubdirArg sandboxSubdirs + ,concatMap mountArg (extraMount ++ dockerMount docker) + ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker) + ,case dockerContainerName docker of + Just name -> ["--name=" ++ name] + Nothing -> [] + ,["-t" | isTerm] + ,["-i" | keepStdinOpen] + ,dockerRunArgs docker + ,[image] + ,[cmnd] + ,args]) + before +#ifndef WINDOWS + runInBase <- liftBaseWith $ \run -> return (void . run) + oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen] + ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do + let sigHandler = runInBase (readProcessNull Nothing envOverride "docker" + ["kill","--signal=" ++ show sigOut,containerID]) + oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing + return (sigIn, oldHandler) +#endif + e <- try (callProcess' + (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) + Nothing + envOverride + "docker" + (concat [["start"] + ,["-a" | not (dockerDetach docker)] + ,["-i" | keepStdinOpen] + ,[containerID]])) +#ifndef WINDOWS + forM_ oldHandlers $ \(sig,oldHandler) -> + liftIO $ installHandler sig oldHandler Nothing +#endif + unless (dockerPersist docker || dockerDetach docker) + (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID]) + case e of + Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) + Right () -> do after + liftIO exitSuccess + where + lookupImageEnv name vars = + case lookup name vars of + Just ('=':val) -> Just val + _ -> Nothing + mountArg (Mount host container) = ["-v",host ++ ":" ++ container] + sandboxSubdirArg subdir = ["-v",toFilePathNoTrailingSep subdir++ ":" ++ toFilePathNoTrailingSep subdir] + projectRoot = fromMaybeProjectRoot mprojectRoot + +-- | Clean-up old docker images and containers. +cleanup :: M env m + => CleanupOpts -> m () +cleanup opts = + do config <- asks getConfig + envOverride <- getEnvOverride (configPlatform config) + checkDockerVersion envOverride + let runDocker = readDockerProcess envOverride + imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] + danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] + runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"] + restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"] + exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"] + pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"] + let imageRepos = parseImagesOut imagesOut + danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut) + runningContainers = parseContainersOut runningContainersOut ++ + parseContainersOut restartingContainersOut + stoppedContainers = parseContainersOut exitedContainersOut ++ + parseContainersOut pausedContainersOut + inspectMap <- inspects envOverride + (Map.keys imageRepos ++ + danglingImageHashes ++ + map fst stoppedContainers ++ + map fst runningContainers) + (imagesLastUsed,curTime) <- + liftIO ((,) <$> getDockerImagesLastUsed config + <*> getZonedTime) + let planWriter = buildPlan curTime + imagesLastUsed + imageRepos + danglingImageHashes + stoppedContainers + runningContainers + inspectMap + plan = toLazyByteString (execWriter planWriter) + plan' <- case dcAction opts of + CleanupInteractive -> + liftIO (editByteString (intercalate "-" [stackProgName + ,dockerCmdName + ,dockerCleanupCmdName + ,"plan"]) + plan) + CleanupImmediate -> return plan + CleanupDryRun -> do liftIO (LBS.hPut stdout plan) + return LBS.empty + mapM_ (performPlanLine envOverride) + (reverse (filter filterPlanLine (lines (LBS.unpack plan')))) + allImageHashesOut <- runDocker ["images","-aq","--no-trunc"] + liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut))) + where + filterPlanLine line = + case line of + c:_ | isSpace c -> False + _ -> True + performPlanLine envOverride line = + case filter (not . null) (words (takeWhile (/= '#') line)) of + [] -> return () + (c:_):t:v:_ -> + do args <- if | toUpper c == 'R' && t == imageStr -> + do $logInfo (concatT ["Removing image: '",v,"'"]) + return ["rmi",v] + | toUpper c == 'R' && t == containerStr -> + do $logInfo (concatT ["Removing container: '",v,"'"]) + return ["rm","-f",v] + | otherwise -> throwM (InvalidCleanupCommandException line) + e <- try (readDockerProcess envOverride args) + case e of + Left (ReadProcessException _ _ _ _) -> + $logError (concatT ["Could not remove: '",v,"'"]) + Left e' -> throwM e' + Right _ -> return () + _ -> throwM (InvalidCleanupCommandException line) + parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8 + where parseImageRepo :: String -> (String, [String]) + parseImageRepo line = + case words line of + repo:tag:hash:_ + | repo == "" -> (hash,[]) + | tag == "" -> (hash,[repo]) + | otherwise -> (hash,[repo ++ ":" ++ tag]) + _ -> throw (InvalidImagesOutputException line) + parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8 + where parseContainer line = + case words line of + hash:image:rest -> (hash,(image,last rest)) + _ -> throw (InvalidPSOutputException line) + buildPlan curTime + imagesLastUsed + imageRepos + danglingImageHashes + stoppedContainers + runningContainers + inspectMap = + do case dcAction opts of + CleanupInteractive -> + do buildStrLn + (concat + ["# STACK DOCKER CLEANUP PLAN" + ,"\n#" + ,"\n# When you leave the editor, the lines in this plan will be processed." + ,"\n#" + ,"\n# Lines that begin with 'R' denote an image or container that will be." + ,"\n# removed. You may change the first character to/from 'R' to remove/keep" + ,"\n# and image or container that would otherwise be kept/removed." + ,"\n#" + ,"\n# To cancel the cleanup, delete all lines in this file." + ,"\n#" + ,"\n# By default, the following images/containers will be removed:" + ,"\n#"]) + buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used" + buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created" + buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created" + buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created" + buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created" + buildStrLn + (concat + ["#" + ,"\n# The default plan can be adjusted using command-line arguments." + ,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] ++ + " --help' for details." + ,"\n#"]) + _ -> buildStrLn + (unlines + ["# Lines that begin with 'R' denote an image or container that will be." + ,"# removed."]) + buildSection "KNOWN IMAGES (pulled/used by stack)" + imagesLastUsed + buildKnownImage + buildSection "UNKNOWN IMAGES (not managed by stack)" + (sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m) + imageRepos + imagesLastUsed))) + buildUnknownImage + buildSection "DANGLING IMAGES (no named references and not depended on by other images)" + (sortCreated (map (,()) danglingImageHashes)) + buildDanglingImage + buildSection "STOPPED CONTAINERS" + (sortCreated stoppedContainers) + (buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts)) + buildSection "RUNNING CONTAINERS" + (sortCreated runningContainers) + (buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts)) + where + buildDefault accessor description = + case accessor opts of + Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".") + Nothing -> return () + sortCreated 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 disp = (name ++ " (image: " ++ image ++ ")") + buildTime containerStr removeAge created disp + buildInspect hash + return True + buildProject (lastUsedTime, projectPath) = + buildInfo ("Last used " ++ + showDaysAgo lastUsedTime ++ + " in " ++ + projectPath) + buildInspect hash = + case Map.lookup hash inspectMap of + Just (Inspect{iiCreated,iiVirtualSize}) -> + buildInfo ("Created " ++ + showDaysAgo iiCreated ++ + maybe "" + (\s -> " (size: " ++ + printf "%g" (fromIntegral s / 1024.0 / 1024.0 :: Float) ++ + "M)") + iiVirtualSize) + Nothing -> return () + showDays days = + case days of + 0 -> "today" + 1 -> "yesterday" + n -> show n ++ " days ago" + showDaysAgo oldTime = showDays (daysAgo oldTime) + daysAgo oldTime = + let ZonedTime (LocalTime today _) zone = curTime + LocalTime oldDay _ = utcToLocalTime zone oldTime + in diffDays today oldDay + buildImageTime = buildTime imageStr + buildTime t removeAge time disp = + case removeAge of + Just d | daysAgo time >= d -> buildStrLn ("R " ++ t ++ " " ++ disp) + _ -> buildKeep t disp + buildKeep t d = buildStrLn (" " ++ t ++ " " ++ d) + buildKeepImage = buildKeep imageStr + buildSectionHead s = buildStrLn ("\n#\n# " ++ s ++ "\n#\n") + buildInfo = buildStrLn . (" # " ++) + buildStrLn l = do buildStr l + tell (charUtf8 '\n') + buildStr = tell . stringUtf8 + + imageStr = "image" + containerStr = "container" + +-- | Inspect Docker image or container. +inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) + => EnvOverride -> String -> m (Maybe Inspect) +inspect envOverride image = + do results <- inspects envOverride [image] + case Map.toList results of + [] -> return Nothing + [(_,i)] -> return (Just i) + _ -> throwM (InvalidInspectOutputException "expect a single result") + +-- | Inspect multiple Docker images and/or containers. +inspects :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + => EnvOverride -> [String] -> m (Map String Inspect) +inspects _ [] = return Map.empty +inspects envOverride images = + do maybeInspectOut <- + try (readDockerProcess envOverride ("inspect" : images)) + case maybeInspectOut of + Right inspectOut -> + -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8 + case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of + Left msg -> throwM (InvalidInspectOutputException msg) + Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) + Left (ReadProcessException _ _ _ _) -> return Map.empty + Left e -> throwM e + +-- | Pull latest version of configured Docker image from registry. +pull :: M env m => m () +pull = + do config <- asks getConfig + let docker = configDocker config + envOverride <- getEnvOverride (configPlatform config) + checkDockerVersion envOverride + pullImage envOverride docker (dockerImage docker) + +-- | Pull Docker image from registry. +pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) + => EnvOverride -> DockerOpts -> String -> m () +pullImage envOverride docker image = + do $logInfo (concatT ["Pulling image from registry: '",image,"'"]) + when (dockerRegistryLogin docker) + (do $logInfo "You may need to log in." + callProcess + Nothing + envOverride + "docker" + (concat + [["login"] + ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) + ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) + ,[takeWhile (/= '/') image]])) + e <- 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, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + => EnvOverride -> m () +checkDockerVersion envOverride = + do dockerExists <- doesExecutableExist envOverride "docker" + unless dockerExists (throwM DockerNotInstalledException) + dockerVersionOut <- readDockerProcess envOverride ["--version"] + case words (decodeUtf8 dockerVersionOut) of + (_:_:v:_) -> + case parseVersionFromString (dropWhileEnd (not . isDigit) v) of + Just v' + | v' < minimumDockerVersion -> + throwM (DockerTooOldException minimumDockerVersion v') + | v' `elem` prohibitedDockerVersions -> + throwM (DockerVersionProhibitedException prohibitedDockerVersions v') + | otherwise -> + return () + _ -> throwM InvalidVersionOutputException + _ -> throwM InvalidVersionOutputException + where minimumDockerVersion = $(mkVersion "1.3.0") + prohibitedDockerVersions = [$(mkVersion "1.2.0")] + +-- | 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 <- dirExists path + when isRootDir + (do (lsd,lsf) <- listDirectory path + forM_ lsd + (\d -> unless (dirname d `elem` excludeDirs) + (removeTree d)) + forM_ lsf + (\f -> unless (filename f `elem` excludeFiles) + (removeFile f))) + +-- | Produce a strict 'S.ByteString' from the stdout of a +-- process. Throws a 'ReadProcessException' exception if the +-- process fails. Logs process's stderr using @$logError@. +readDockerProcess + :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + => EnvOverride -> [String] -> m BS.ByteString +readDockerProcess envOverride args = + readProcessStdout Nothing envOverride "docker" args + +-- | 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/") + +-- | Convenience function to decode ByteString to String. +decodeUtf8 :: BS.ByteString -> String +decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs)) + +-- | Convenience function constructing message for @$log*@. +concatT :: [String] -> Text +concatT = T.pack . concat + +-- | Fail with friendly error if project root not set. +fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir +fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) + +-- | Environment variable that contains the sandbox ID. +sandboxIDEnvVar :: String +sandboxIDEnvVar = "DOCKER_SANDBOX_ID" + +-- | Environment variable used to indicate stack is running in container. +inContainerEnvVar :: String +inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] + +-- | Command-line argument for "docker" +dockerCmdName :: String +dockerCmdName = "docker" + +-- | Command-line argument for @docker pull@. +dockerPullCmdName :: String +dockerPullCmdName = "pull" + +-- | Command-line argument for @docker cleanup@. +dockerCleanupCmdName :: String +dockerCleanupCmdName = "cleanup" + +-- | Command-line option for @--internal-re-exec@. +reExecArgName :: String +reExecArgName = "internal-re-exec-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. + | CannotDetermineProjectRootException + -- ^ Can't determine the project root (where to put docker sandbox). + | DockerNotInstalledException + -- ^ @docker --version@ failed. + | UnsupportedStackExeHostPlatformException + -- ^ Using host stack-exe on unsupported platform. + deriving (Typeable) + +-- | Exception instance for StackDockerException. +instance Exception StackDockerException + +-- | Show instance for StackDockerException. +instance Show StackDockerException where + show DockerMustBeEnabledException = + concat ["Docker must be enabled in your configuration file to use this command."] + show OnlyOnHostException = + "This command must be run on host OS (not in a Docker container)." + show (InspectFailedException image) = + concat ["'docker inspect' failed for image after pull: ",image,"."] + show (NotPulledException image) = + concat ["The Docker image referenced by your configuration file" + ," has not\nbeen downloaded:\n " + ,image + ,"\n\nRun '" + ,unwords [stackProgName, dockerCmdName, dockerPullCmdName] + ,"' to download it, then try again."] + show (InvalidCleanupCommandException line) = + concat ["Invalid line in cleanup commands: '",line,"'."] + show (InvalidImagesOutputException line) = + concat ["Invalid 'docker images' output line: '",line,"'."] + show (InvalidPSOutputException line) = + concat ["Invalid 'docker ps' output line: '",line,"'."] + show (InvalidInspectOutputException msg) = + concat ["Invalid 'docker inspect' output: ",msg,"."] + show (PullFailedException image) = + concat ["Could not pull Docker image:\n " + ,image + ,"\nThere may not be an image on the registry for your resolver's LTS version in\n" + ,"your configuration file."] + show (DockerTooOldException minVersion haveVersion) = + concat ["Minimum docker version '" + ,versionString minVersion + ,"' is required (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 CannotDetermineProjectRootException = + "Cannot determine project root directory for Docker sandbox." + show DockerNotInstalledException = + "Cannot find 'docker' in PATH. Is Docker installed?" + show UnsupportedStackExeHostPlatformException = concat + [ "Using host's " + , stackProgName + , " executable in Docker container is only supported on " + , display dockerContainerPlatform + , " platform" ] + +-- | Platform that Docker containers run +dockerContainerPlatform :: Platform +dockerContainerPlatform = Platform X86_64 Linux + +-- | A shortcut +type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m + ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m) diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs index 89260c124b..80d1d46f70 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -12,6 +12,7 @@ import Stack.Types.PackageName as X import Stack.Types.Version as X import Stack.Types.Config as X import Stack.Types.Docker as X +import Stack.Types.ExecEnv as X import Stack.Types.Image as X import Stack.Types.Build as X import Stack.Types.Package as X diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index de083750d1..c80083ea16 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -55,6 +55,7 @@ import qualified Paths_stack as Meta import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import Stack.Types.Compiler import Stack.Types.Docker +import Stack.Types.ExecEnv import Stack.Types.FlagName import Stack.Types.Image import Stack.Types.PackageIdentifier @@ -74,6 +75,8 @@ data Config = -- ^ Path to user configuration file (usually ~/.stack/config.yaml) ,configDocker :: !DockerOpts -- ^ Docker configuration + ,configExecEnv :: !ExecEnvOpts + -- ^ Execution environment (e.g nix-shell) configuration ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools ,configLocalProgramsBase :: !(Path Abs Dir) @@ -585,6 +588,8 @@ data ConfigMonoid = ConfigMonoid { configMonoidDockerOpts :: !DockerOptsMonoid -- ^ Docker options. + , configMonoidExecEnvOpts :: !ExecEnvOptsMonoid + -- ^ Options for the execution environment (nix-shell or container) , configMonoidConnectionCount :: !(Maybe Int) -- ^ See: 'configConnectionCount' , configMonoidHideTHLoading :: !(Maybe Bool) @@ -651,6 +656,7 @@ data ConfigMonoid = instance Monoid ConfigMonoid where mempty = ConfigMonoid { configMonoidDockerOpts = mempty + , configMonoidExecEnvOpts = mempty , configMonoidConnectionCount = Nothing , configMonoidHideTHLoading = Nothing , configMonoidLatestSnapshotUrl = Nothing @@ -684,6 +690,7 @@ instance Monoid ConfigMonoid where } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r + , configMonoidExecEnvOpts = configMonoidExecEnvOpts l <> configMonoidExecEnvOpts r , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r @@ -726,6 +733,7 @@ instance FromJSON (ConfigMonoid, [JSONWarning]) where parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) + configMonoidExecEnvOpts <- jsonSubWarnings (obj ..:? "nix-shell" ..!= mempty) configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName diff --git a/src/Stack/Types/ExecEnv.hs b/src/Stack/Types/ExecEnv.hs new file mode 100644 index 0000000000..026e9bc18e --- /dev/null +++ b/src/Stack/Types/ExecEnv.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-} + +-- | Docker types. + +module Stack.Types.ExecEnv where + +import Control.Applicative +import Control.Monad +import Control.Monad.Catch (MonadThrow) +import Data.Aeson.Extended +import Data.Monoid +import Data.Text (Text) +import Path + +import Stack.Types.PackageName + +-- | Which ExecEnv are we using? +data ExecEnvType = NixShellExecEnv | DockerContainerExecEnv + deriving (Show, Eq) + +-- | Docker configuration. +data ExecEnvOpts = ExecEnvOpts + {execEnvType :: !(Maybe ExecEnvType) + -- ^ Are we using a special execution environment? (Docker or Nix-Shell) + ,execEnvPackages :: ![PackageName] + -- ^ The system packages to be installed in the environment before it runs +-- ,dockerContainerName :: !(Maybe String) + -- ^ Container name to use, only makes sense from command-line with `dockerPersist` + -- or `dockerDetach`. +-- ,execEnvRunArgs :: ![String] + -- ^ Arguments to pass directly to @docker run@. +-- ,dockerEnv :: ![String] + -- ^ Environment variables to set in the container. +-- ,dockerDatabasePath :: !(Path Abs File) + -- ^ Location of image usage database. +-- ,dockerStackExe :: !(Maybe DockerStackExe) + -- ^ Location of container-compatible stack executable + } + deriving (Show) + +-- | An uninterpreted representation of stack execution environment options. +-- Configurations may be "cascaded" using mappend (left-biased). +data ExecEnvOptsMonoid = ExecEnvOptsMonoid + {execEnvMonoidDefaultEnable :: !Bool + -- ^ Should nix-shell be defaulted to enabled (does @execenv:@ section exist in the config)? + ,execEnvMonoidEnable :: !(Maybe Bool) + -- ^ Is using nix-shell enabled? + ,execEnvMonoidPackages :: ![PackageName] +-- ,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@ +-- ,dockerMonoidEnv :: ![String] + -- ^ Environment variables to set in the container +-- ,dockerMonoidDatabasePath :: !(Maybe String) + -- ^ Location of image usage database. +-- ,dockerMonoidStackExe :: !(Maybe String) + -- ^ Location of container-compatible stack executable + } + deriving (Show) + +-- | Decode uninterpreted docker options from JSON/YAML. +instance FromJSON (ExecEnvOptsMonoid, [JSONWarning]) where + parseJSON = withObjectWarnings "DockerOptsMonoid" + (\o -> do execEnvMonoidDefaultEnable <- pure True + execEnvMonoidEnable <- o ..:? execEnvEnableArgName + execEnvMonoidPackages <- o ..:? execEnvPackagesArgName ..!= [] +-- dockerMonoidContainerName <- o ..:? dockerContainerNameArgName +-- dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] +-- dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= [] +-- dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName +-- dockerMonoidStackExe <- o ..:? dockerStackExeArgName + return ExecEnvOptsMonoid{..}) + +-- | Left-biased combine Docker options +instance Monoid ExecEnvOptsMonoid where + mempty = ExecEnvOptsMonoid + {execEnvMonoidDefaultEnable = False + ,execEnvMonoidEnable = Nothing + ,execEnvMonoidPackages = [] +-- ,dockerMonoidContainerName = Nothing +-- ,dockerMonoidRunArgs = [] +-- ,dockerMonoidEnv = [] +-- ,dockerMonoidDatabasePath = Nothing +-- ,dockerMonoidStackExe = Nothing + } + mappend l r = ExecEnvOptsMonoid + {execEnvMonoidDefaultEnable = execEnvMonoidDefaultEnable l || execEnvMonoidDefaultEnable r + ,execEnvMonoidEnable = execEnvMonoidEnable l <|> execEnvMonoidEnable r + ,execEnvMonoidPackages = execEnvMonoidPackages l <> execEnvMonoidPackages r +-- ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r +-- ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l +-- ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l +-- ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r +-- ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r + } + +{- -- | Where to get the `stack` executable to run in Docker containers +data DockerStackExe + = DockerStackExeDownload -- ^ Download from official bindist + | DockerStackExeHost -- ^ Host's `stack` (linux-x86_64 only) + | DockerStackExeImage -- ^ Docker image's `stack` (versions must match) + | DockerStackExePath (Path Abs File) -- ^ Executable at given path + deriving (Show) + +-- | Parse 'DockerStackExe'. +parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe +parseDockerStackExe t + | t == dockerStackExeDownloadVal = return DockerStackExeDownload + | t == dockerStackExeHostVal = return DockerStackExeHost + | t == dockerStackExeImageVal = return DockerStackExeImage + | otherwise = liftM DockerStackExePath (parseAbsFile t) +-} + +-- | ExecEnv enable argument name. +execEnvEnableArgName :: Text +execEnvEnableArgName = "enable" + +-- | ExecEnv system packages argument name. +execEnvPackagesArgName :: Text +execEnvPackagesArgName = "packages" +{- +-- | Docker run args argument name. +dockerRunArgsArgName :: Text +dockerRunArgsArgName = "run-args" + +-- | Docker environment variable argument name. +dockerEnvArgName :: Text +dockerEnvArgName = "env" + +-- | Docker container name argument name. +dockerContainerNameArgName :: Text +dockerContainerNameArgName = "container-name" + +-- | Docker database path argument name. +dockerDatabasePathArgName :: Text +dockerDatabasePathArgName = "database-path" + +-- | Docker database path argument name. +dockerStackExeArgName :: Text +dockerStackExeArgName = "stack-exe" + +-- | Value for @--docker-stack-exe=download@ +dockerStackExeDownloadVal :: String +dockerStackExeDownloadVal = "download" + +-- | Value for @--docker-stack-exe=host@ +dockerStackExeHostVal :: String +dockerStackExeHostVal = "host" + +-- | Value for @--docker-stack-exe=image@ +dockerStackExeImageVal :: String +dockerStackExeImageVal = "image" +-} diff --git a/src/main/Main.hs b/src/main/Main.hs index 54035d97c7..aa73882a24 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -57,6 +57,7 @@ import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot import Stack.Exec +import qualified Stack.ExecEnv.NixShell as Nix import Stack.Fetch import Stack.FileWatch import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) @@ -577,7 +578,7 @@ setupParser = SetupCmdOpts ) <*> (optional $ strOption (long "ghc-bindist" - <> metavar "URL" + <> metavar "URL" <> help "Alternate GHC binary distribution (requires custom --ghc-variant)" )) where diff --git a/stack.cabal b/stack.cabal index 343c25ccb3..aad998f761 100644 --- a/stack.cabal +++ b/stack.cabal @@ -53,12 +53,14 @@ library Stack.BuildPlan Stack.Config Stack.Config.Docker + Stack.Config.ExecEnv Stack.ConfigCmd Stack.Constants Stack.Coverage Stack.Docker Stack.Docker.GlobalDB Stack.Dot + Stack.ExecEnv.NixShell Stack.Fetch Stack.Exec Stack.FileWatch @@ -82,6 +84,7 @@ library Stack.Types.Compiler Stack.Types.Config Stack.Types.Docker + Stack.Types.ExecEnv Stack.Types.FlagName Stack.Types.GhcPkgId Stack.Types.Image @@ -158,6 +161,7 @@ library , http-conduit >= 2.1.7 , http-types >= 0.8.6 , lifted-base + , language-nix >= 2.0 , monad-control , monad-logger >= 0.3.13.1 , monad-loops >= 0.4.2.1 diff --git a/stack.yaml b/stack.yaml index a75523da6e..0474f0b2cc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ resolver: lts-3.7 extra-deps: - binary-tagged-0.1.1.0 +- language-nix-2.1 image: container: base: "fpco/ubuntu-with-libgmp:14.04" From 3dac5d9ff105e57d1a538f40dc9972acbeffe23c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Thu, 22 Oct 2015 18:30:45 +0200 Subject: [PATCH 02/56] Nix-shell: added option for initial env expr file --- src/Stack/Config/ExecEnv.hs | 1 + src/Stack/Types/ExecEnv.hs | 15 ++++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Stack/Config/ExecEnv.hs b/src/Stack/Config/ExecEnv.hs index aca80d2b81..c33a7c1675 100644 --- a/src/Stack/Config/ExecEnv.hs +++ b/src/Stack/Config/ExecEnv.hs @@ -23,6 +23,7 @@ execEnvOptsFromMonoid mproject stackRoot ExecEnvOptsMonoid{..} = do then Just NixShellExecEnv else Nothing execEnvPackages = execEnvMonoidPackages + execEnvInitFile = execEnvMonoidInitFile {- dockerContainerName = emptyToNothing dockerMonoidContainerName dockerRunArgs = dockerMonoidRunArgs dockerMount = dockerMonoidMount diff --git a/src/Stack/Types/ExecEnv.hs b/src/Stack/Types/ExecEnv.hs index 026e9bc18e..aa229cc386 100644 --- a/src/Stack/Types/ExecEnv.hs +++ b/src/Stack/Types/ExecEnv.hs @@ -21,9 +21,11 @@ data ExecEnvType = NixShellExecEnv | DockerContainerExecEnv -- | Docker configuration. data ExecEnvOpts = ExecEnvOpts {execEnvType :: !(Maybe ExecEnvType) - -- ^ Are we using a special execution environment? (Docker or Nix-Shell) + -- ^ Are we using a special execution environment? (Docker container, Nix-shell, chroot...) ,execEnvPackages :: ![PackageName] -- ^ The system packages to be installed in the environment before it runs + ,execEnvInitFile :: !(Maybe String) + -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) -- ,dockerContainerName :: !(Maybe String) -- ^ Container name to use, only makes sense from command-line with `dockerPersist` -- or `dockerDetach`. @@ -46,6 +48,9 @@ data ExecEnvOptsMonoid = ExecEnvOptsMonoid ,execEnvMonoidEnable :: !(Maybe Bool) -- ^ Is using nix-shell enabled? ,execEnvMonoidPackages :: ![PackageName] + -- ^ System packages to use (given to nix-shell) + ,execEnvMonoidInitFile :: !(Maybe String) + -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) -- ,dockerMonoidContainerName :: !(Maybe String) -- ^ Container name to use, only makes sense from command-line with `dockerPersist` -- or `dockerDetach`. @@ -66,6 +71,7 @@ instance FromJSON (ExecEnvOptsMonoid, [JSONWarning]) where (\o -> do execEnvMonoidDefaultEnable <- pure True execEnvMonoidEnable <- o ..:? execEnvEnableArgName execEnvMonoidPackages <- o ..:? execEnvPackagesArgName ..!= [] + execEnvMonoidInitFile <- o ..:? execEnvInitFileArgName -- dockerMonoidContainerName <- o ..:? dockerContainerNameArgName -- dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] -- dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= [] @@ -79,6 +85,7 @@ instance Monoid ExecEnvOptsMonoid where {execEnvMonoidDefaultEnable = False ,execEnvMonoidEnable = Nothing ,execEnvMonoidPackages = [] + ,execEnvMonoidInitFile = Nothing -- ,dockerMonoidContainerName = Nothing -- ,dockerMonoidRunArgs = [] -- ,dockerMonoidEnv = [] @@ -89,6 +96,7 @@ instance Monoid ExecEnvOptsMonoid where {execEnvMonoidDefaultEnable = execEnvMonoidDefaultEnable l || execEnvMonoidDefaultEnable r ,execEnvMonoidEnable = execEnvMonoidEnable l <|> execEnvMonoidEnable r ,execEnvMonoidPackages = execEnvMonoidPackages l <> execEnvMonoidPackages r + ,execEnvMonoidInitFile = execEnvMonoidInitFile l <|> execEnvMonoidInitFile r -- ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r -- ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l -- ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l @@ -120,6 +128,11 @@ execEnvEnableArgName = "enable" -- | ExecEnv system packages argument name. execEnvPackagesArgName :: Text execEnvPackagesArgName = "packages" + +-- | ExecEnv init env file path argument name. +execEnvInitFileArgName :: Text +execEnvInitFileArgName = "init-env-file" + {- -- | Docker run args argument name. dockerRunArgsArgName :: Text From 2df0c247f117569145212f8a452d87d846dd75dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 12:11:44 +0200 Subject: [PATCH 03/56] Adding branching in main (docker or nix) --- src/Stack/ExecEnv/NixShell.hs | 6 +++--- src/main/Main.hs | 14 +++++++++++++- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index 69405e2f49..18b336d300 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -13,7 +13,7 @@ module Stack.ExecEnv.NixShell ,execWithOptionalContainer ,preventInContainer ,pull - ,reexecWithOptionalContainer + ,reexecWithShell ,reset ,reExecArgName ,M @@ -82,7 +82,7 @@ import System.Posix.Signals -- transfering away from the current process to the intra-container one. The main use -- for this is releasing a lock. After launching reexecution, the host process becomes -- nothing but an manager for the call into docker and thus may not hold the lock. -reexecWithOptionalContainer +reexecWithShell :: M env m => Maybe (Path Abs Dir) -> Maybe (m ()) @@ -90,7 +90,7 @@ reexecWithOptionalContainer -> Maybe (m ()) -> Maybe (m ()) -> m () -reexecWithOptionalContainer mprojectRoot = +reexecWithShell mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where getCmdArgs envOverride imageInfo = do diff --git a/src/main/Main.hs b/src/main/Main.hs index aa73882a24..b3d5827c2f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -760,8 +760,20 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do go (inner' lk) + let isUsingNix = execEnvType (configExecEnv (lcConfig lc)) == Just NixShellExecEnv + -- for now we bypass docker if nix-shell is on + if isUsingNix + then do putStr "Nix packages used: " + print (execEnvPackages (configExecEnv (lcConfig lc))) + putStrLn "" + else putStrLn "...not using nix..." runStackTGlobal manager (lcConfig lc) go $ - Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter + if isUsingNix + then Nix.reexecWithShell (lcProjectRoot lc) mbefore (inner'' lk0) mafter + (Just $ liftIO $ + do lk' <- readIORef curLk + munlockFile lk') + else Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter (Just $ liftIO $ do lk' <- readIORef curLk munlockFile lk') From 162d80782a656ad1b23059d9b7c0b73a0e48e1a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 15:11:57 +0200 Subject: [PATCH 04/56] Stack launches a nix-shell --- src/Stack/ExecEnv/NixShell.hs | 165 +++++++++++++++++----------------- 1 file changed, 84 insertions(+), 81 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index 18b336d300..4b0a592fc9 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -4,17 +4,16 @@ -- | Run commands in a nix-shell module Stack.ExecEnv.NixShell - (cleanup - ,CleanupOpts(..) - ,CleanupAction(..) - ,dockerCleanupCmdName - ,dockerCmdName - ,dockerPullCmdName - ,execWithOptionalContainer - ,preventInContainer - ,pull + (--cleanup + --,CleanupOpts(..) + --,CleanupAction(..) + --,dockerCleanupCmdName + --,dockerCmdName + --,dockerPullCmdName + execWithShell + --,pull ,reexecWithShell - ,reset + --,reset ,reExecArgName ,M ) where @@ -75,7 +74,7 @@ import Control.Monad.Trans.Control (liftBaseWith) import System.Posix.Signals #endif --- | If Docker is enabled, re-runs the currently running OS command in a Docker container. +-- | If ExecEnv is enabled, re-runs the currently running OS command in a ExecEnv container. -- Otherwise, runs the inner action. -- -- This takes an optional release action which should be taken IFF control is @@ -91,16 +90,16 @@ reexecWithShell -> Maybe (m ()) -> m () reexecWithShell mprojectRoot = - execWithOptionalContainer mprojectRoot getCmdArgs + execWithShell mprojectRoot getCmdArgs where - getCmdArgs envOverride imageInfo = do + getCmdArgs envOverride {-imageInfo-} = do config <- asks getConfig args <- fmap (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) (liftIO getArgs) case dockerStackExe (configDocker config) of - Just DockerStackExeHost + {-Just DockerStackExeHost | configPlatform config == dockerContainerPlatform -> fmap (cmdArgs args) (liftIO getExecutablePath) | otherwise -> throwM UnsupportedStackExeHostPlatformException @@ -111,25 +110,25 @@ reexecWithShell mprojectRoot = fmap (cmdArgs args) (liftIO $ canonicalizePath (toFilePath path)) - Just DockerStackExeDownload -> exeDownload args - Nothing - | configPlatform config == dockerContainerPlatform -> do + Just DockerStackExeDownload -> exeDownload args-} + Nothing -> do + {-| configPlatform config == dockerContainerPlatform -> do-} (exePath,exeTimestamp,misCompatible) <- liftIO $ do exePath <- liftIO getExecutablePath exeTimestamp <- liftIO (getModificationTime exePath) - isKnown <- + {-isKnown <- liftIO $ getDockerImageExe config (iiId imageInfo) exePath - exeTimestamp - return (exePath, exeTimestamp, isKnown) + exeTimestamp-} + return (exePath, exeTimestamp, Just True {-isKnown-}) case misCompatible of Just True -> do return (cmdArgs args exePath) - Just False -> do + {-Just False -> do exeDownload args Nothing -> do e <- @@ -167,41 +166,42 @@ reexecWithShell mprojectRoot = exeDownload args = fmap (cmdArgs args . toFilePath) - (ensureDockerStackExe dockerContainerPlatform) + (ensureDockerStackExe dockerContainerPlatform)-} cmdArgs args exePath = let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] in (mountPath, args, [], [Mount exePath mountPath]) --- | If Docker is enabled, re-runs the OS command returned by the second argument in a --- Docker container. Otherwise, runs the inner action. +-- | If ExecEnv is enabled, re-runs the OS command returned by the second argument in a +-- ExecEnv container. Otherwise, runs the inner action. -- -- This takes an optional release action just like `reexecWithOptionalContainer`. -execWithOptionalContainer +execWithShell :: M env m => Maybe (Path Abs Dir) - -> (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) + -> (EnvOverride -> {-Inspect ->-} m (FilePath,[String],[(String,String)],[Mount])) -> Maybe (m ()) -> IO () -> Maybe (m ()) -> Maybe (m ()) -> m () -execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease = +execWithShell mprojectRoot getCmdArgs mbefore inner mafter mrelease = do config <- asks getConfig - inContainer <- getInContainer + inShell <- getInShell isReExec <- asks getReExec - if | inContainer && not isReExec && (isJust mbefore || isJust mafter) -> + let envType = execEnvType (configExecEnv config) + if | inShell && not isReExec && (isJust mbefore || isJust mafter) -> throwM OnlyOnHostException - | inContainer -> + | inShell -> liftIO (do inner exitSuccess) - | not (dockerEnable (configDocker config)) -> + | isNothing envType -> do fromMaybeAction mbefore liftIO inner fromMaybeAction mafter liftIO exitSuccess - | otherwise -> + | envType == Just NixShellExecEnv -> do fromMaybeAction mrelease - runContainerAndExit + runShellAndExit getCmdArgs mprojectRoot (fromMaybeAction mbefore) @@ -210,41 +210,57 @@ execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease fromMaybeAction Nothing = return () fromMaybeAction (Just hook) = hook --- | Error if running in a container. -preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m () -preventInContainer inner = - do inContainer <- getInContainer - if inContainer - then throwM OnlyOnHostException - else inner +runShellAndExit getCmdArgs mprojectRoot before after = do + config <- asks getConfig + envOverride <- getEnvOverride (configPlatform config) + (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} + let keepStdinOpen = False -- always closed + before + let fullArgs = (concat [["-p", "stack", "haskell.packages.lts-3_7.ghc"] + --,(map show (execEnvPackages (configExecEnv config))) + ,["--command"] + ,[(concat $ intersperse " " (cmnd:args))]]) + e <- try (callProcess' + (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) + Nothing + envOverride + "nix-shell" + fullArgs) + {-unless (dockerPersist docker || dockerDetach docker) + (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])-} + case e of + Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) + Right () -> do after + liftIO exitSuccess --- | 'True' if we are currently running inside a Docker container. -getInContainer :: (MonadIO m) => m Bool -getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar) --- | Run a command in a new Docker container, then exit the process. -runContainerAndExit :: M env m - => (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) +-- | 'True' if we are currently running inside a ExecEnv. +getInShell :: (MonadIO m) => m Bool +getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) +{- +-- | Run a command in a new ExecEnv, then exit the process. +runShellAndExit :: M env m + => (EnvOverride -> {-Inspect ->-} m (FilePath,[String],[(String,String)],[Mount])) -> Maybe (Path Abs Dir) -> m () -> m () -> m () -runContainerAndExit getCmdArgs - mprojectRoot - before - after = +runShellAndExit getCmdArgs + mprojectRoot + before + after = do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + --checkDockerVersion envOverride (dockerHost,dockerCertPath,bamboo,jenkins) <- liftIO ((,,,) <$> lookupEnv "DOCKER_HOST" <*> lookupEnv "DOCKER_CERT_PATH" <*> lookupEnv "bamboo_buildKey" <*> lookupEnv "JENKINS_HOME") - let isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost + let isRemoteExecEnv = maybe False (isPrefixOf "tcp://") dockerHost userEnvVars <- - if fromMaybe (not isRemoteDocker) (dockerSetUser docker) + if fromMaybe (not isRemoteExecEnv) (dockerSetUser docker) then do uidOut <- readProcessStdout Nothing envOverride "id" ["-u"] gidOut <- readProcessStdout Nothing envOverride "id" ["-g"] @@ -257,7 +273,7 @@ runContainerAndExit getCmdArgs liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) pwd <- getWorkingDir - when (isRemoteDocker && + when (isRemoteExecEnv && maybe False (isInfixOf "boot2docker") dockerCertPath) ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") let image = dockerImage docker @@ -272,7 +288,7 @@ runContainerAndExit getCmdArgs Just ii2 -> return ii2 Nothing -> throwM (InspectFailedException image) | otherwise -> throwM (NotPulledException image) - (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride imageInfo + (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} let imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo)) sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) sandboxIDDir <- parseRelDir (sandboxID ++ "/") @@ -329,28 +345,15 @@ runContainerAndExit getCmdArgs ,[cmnd] ,args]) before -#ifndef WINDOWS - runInBase <- liftBaseWith $ \run -> return (void . run) - oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen] - ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do - let sigHandler = runInBase (readProcessNull Nothing envOverride "docker" - ["kill","--signal=" ++ show sigOut,containerID]) - oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing - return (sigIn, oldHandler) -#endif e <- try (callProcess' (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) Nothing envOverride "docker" (concat [["start"] - ,["-a" | not (dockerDetach docker)] - ,["-i" | keepStdinOpen] + --,["-a" | not (dockerDetach docker)] + --,["-i" | keepStdinOpen] ,[containerID]])) -#ifndef WINDOWS - forM_ oldHandlers $ \(sig,oldHandler) -> - liftIO $ installHandler sig oldHandler Nothing -#endif unless (dockerPersist docker || dockerDetach docker) (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID]) case e of @@ -697,7 +700,7 @@ removeDirectoryContents path excludeDirs excludeFiles = forM_ lsf (\f -> unless (filename f `elem` excludeFiles) (removeFile f))) - +-} -- | Produce a strict 'S.ByteString' from the stdout of a -- process. Throws a 'ReadProcessException' exception if the -- process fails. Logs process's stderr using @$logError@. @@ -706,7 +709,7 @@ readDockerProcess => EnvOverride -> [String] -> m BS.ByteString readDockerProcess envOverride args = readProcessStdout Nothing envOverride "docker" args - +{- -- | Subdirectories of the home directory to sandbox between GHC/Stackage versions. sandboxedHomeSubdirectories :: [Path Rel Dir] sandboxedHomeSubdirectories = @@ -717,23 +720,23 @@ sandboxedHomeSubdirectories = -- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir homeDirName = $(mkRelDir "_home/") - +-} -- | Convenience function to decode ByteString to String. decodeUtf8 :: BS.ByteString -> String decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs)) - +{- -- | Convenience function constructing message for @$log*@. concatT :: [String] -> Text concatT = T.pack . concat - +-} -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) - +{- -- | Environment variable that contains the sandbox ID. sandboxIDEnvVar :: String sandboxIDEnvVar = "DOCKER_SANDBOX_ID" - +-} -- | Environment variable used to indicate stack is running in container. inContainerEnvVar :: String inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] @@ -745,15 +748,15 @@ dockerCmdName = "docker" -- | Command-line argument for @docker pull@. dockerPullCmdName :: String dockerPullCmdName = "pull" - +{- -- | Command-line argument for @docker cleanup@. dockerCleanupCmdName :: String dockerCleanupCmdName = "cleanup" - +-} -- | Command-line option for @--internal-re-exec@. reExecArgName :: String reExecArgName = "internal-re-exec-version" - +{- -- | Options for 'cleanup'. data CleanupOpts = CleanupOpts { dcAction :: !CleanupAction @@ -797,7 +800,7 @@ instance FromJSON ImageConfig where parseJSON v = do o <- parseJSON v (ImageConfig <$> o .:? T.pack "Env" .!= []) - +-} -- | Exceptions thrown by Stack.Docker. data StackDockerException = DockerMustBeEnabledException From 97b1f9b249d36b958c2ffecc69e6e4ac268a7616 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 15:43:24 +0200 Subject: [PATCH 05/56] Some opts of nix-shell were forgotten --- src/Stack/ExecEnv/NixShell.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index 4b0a592fc9..7903f3eeae 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -216,16 +216,18 @@ runShellAndExit getCmdArgs mprojectRoot before after = do (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} let keepStdinOpen = False -- always closed before - let fullArgs = (concat [["-p", "stack", "haskell.packages.lts-3_7.ghc"] - --,(map show (execEnvPackages (configExecEnv config))) + let fullArgs = (concat [["--pure", "-p", "which", "stack", "haskell.packages.lts-3_7.ghc"] + ,(map show (execEnvPackages (configExecEnv config))) ,["--command"] - ,[(concat $ intersperse " " (cmnd:args))]]) + ,[(concat $ intersperse " " ("which":"stack;":cmnd:args))]]) + liftIO $ print fullArgs e <- try (callProcess' (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) Nothing envOverride "nix-shell" fullArgs) + liftIO $ putStrLn "Nix-shell process called." {-unless (dockerPersist docker || dockerDetach docker) (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])-} case e of From cee6f0b6b1ec899ffd8ade7854cac18d0c302ab8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 17:10:35 +0200 Subject: [PATCH 06/56] Hack: fixing stack version in arg and nix-shell no longer pure --- src/Stack/ExecEnv/NixShell.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index 7903f3eeae..e8d63624bf 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -96,7 +96,7 @@ reexecWithShell mprojectRoot = config <- asks getConfig args <- fmap - (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) + (("--" ++ reExecArgName ++ "=0.1.6.0") :) -- ++ showVersion Meta.version) :) (liftIO getArgs) case dockerStackExe (configDocker config) of {-Just DockerStackExeHost @@ -216,11 +216,10 @@ runShellAndExit getCmdArgs mprojectRoot before after = do (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} let keepStdinOpen = False -- always closed before - let fullArgs = (concat [["--pure", "-p", "which", "stack", "haskell.packages.lts-3_7.ghc"] + let fullArgs = (concat [["-p", "haskell.packages.lts-3_7.ghc"] ,(map show (execEnvPackages (configExecEnv config))) ,["--command"] - ,[(concat $ intersperse " " ("which":"stack;":cmnd:args))]]) - liftIO $ print fullArgs + ,[(concat $ intersperse " " ("stack --version;":"stack":args))]]) e <- try (callProcess' (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) Nothing From 6fbce2337532fe0151bfe7c7900ef79bc4dd374e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 19:18:09 +0200 Subject: [PATCH 07/56] Using ghc from nixpkgs.haskell.packages.lts-X_Y when possible --- src/Stack/ExecEnv/NixShell.hs | 43 ++++++++++++++++++++--------------- src/main/Main.hs | 27 +++++++++------------- 2 files changed, 36 insertions(+), 34 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index e8d63624bf..5a218271b4 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -83,20 +83,21 @@ import System.Posix.Signals -- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithShell :: M env m - => Maybe (Path Abs Dir) + => Resolver -- ^ Needed for installing ghc in the nix-shell + -> Maybe (Path Abs Dir) -> Maybe (m ()) -> IO () -> Maybe (m ()) -> Maybe (m ()) -> m () -reexecWithShell mprojectRoot = - execWithShell mprojectRoot getCmdArgs +reexecWithShell resolver mprojectRoot = + execWithShell resolver mprojectRoot getCmdArgs where getCmdArgs envOverride {-imageInfo-} = do config <- asks getConfig args <- fmap - (("--" ++ reExecArgName ++ "=0.1.6.0") :) -- ++ showVersion Meta.version) :) + (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) (liftIO getArgs) case dockerStackExe (configDocker config) of {-Just DockerStackExeHost @@ -168,7 +169,7 @@ reexecWithShell mprojectRoot = (cmdArgs args . toFilePath) (ensureDockerStackExe dockerContainerPlatform)-} cmdArgs args exePath = - let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] + let mountPath = exePath -- concat ["/opt/host/bin/", takeBaseName exePath] in (mountPath, args, [], [Mount exePath mountPath]) -- | If ExecEnv is enabled, re-runs the OS command returned by the second argument in a @@ -177,14 +178,15 @@ reexecWithShell mprojectRoot = -- This takes an optional release action just like `reexecWithOptionalContainer`. execWithShell :: M env m - => Maybe (Path Abs Dir) + => Resolver + -> Maybe (Path Abs Dir) -> (EnvOverride -> {-Inspect ->-} m (FilePath,[String],[(String,String)],[Mount])) -> Maybe (m ()) -> IO () -> Maybe (m ()) -> Maybe (m ()) -> m () -execWithShell mprojectRoot getCmdArgs mbefore inner mafter mrelease = +execWithShell resolver mprojectRoot getCmdArgs mbefore inner mafter mrelease = do config <- asks getConfig inShell <- getInShell isReExec <- asks getReExec @@ -201,7 +203,7 @@ execWithShell mprojectRoot getCmdArgs mbefore inner mafter mrelease = liftIO exitSuccess | envType == Just NixShellExecEnv -> do fromMaybeAction mrelease - runShellAndExit + runShellAndExit resolver getCmdArgs mprojectRoot (fromMaybeAction mbefore) @@ -210,25 +212,30 @@ execWithShell mprojectRoot getCmdArgs mbefore inner mafter mrelease = fromMaybeAction Nothing = return () fromMaybeAction (Just hook) = hook -runShellAndExit getCmdArgs mprojectRoot before after = do +runShellAndExit resolver getCmdArgs mprojectRoot before after = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config) - (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} - let keepStdinOpen = False -- always closed + (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride before - let fullArgs = (concat [["-p", "haskell.packages.lts-3_7.ghc"] - ,(map show (execEnvPackages (configExecEnv config))) + let ghcInNix = case resolver of + ResolverSnapshot (LTS x y) -> + "haskell.packages.lts-" ++ (show x) ++ "_" ++ (show y) ++ ".ghc" + _ -> "ghc" + nixpkgs = [ghcInNix] ++ (map show (execEnvPackages (configExecEnv config))) + fullArgs = (concat [["--pure", "-p"] + ,nixpkgs ,["--command"] - ,[(concat $ intersperse " " ("stack --version;":"stack":args))]]) + ,[(concat $ intersperse " " + ("export":(inContainerEnvVar++"=1"):";":cmnd:args))] + ]) + liftIO $ putStrLn $ "Using a nix-shell environment with nix packages: " ++ + (concat $ intersperse ", " nixpkgs) e <- try (callProcess' - (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) + (\cp -> cp { delegate_ctlc = False }) Nothing envOverride "nix-shell" fullArgs) - liftIO $ putStrLn "Nix-shell process called." - {-unless (dockerPersist docker || dockerDetach docker) - (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])-} case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) Right () -> do after diff --git a/src/main/Main.hs b/src/main/Main.hs index b3d5827c2f..ae6f818845 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -760,23 +760,18 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do go (inner' lk) - let isUsingNix = execEnvType (configExecEnv (lcConfig lc)) == Just NixShellExecEnv - -- for now we bypass docker if nix-shell is on - if isUsingNix - then do putStr "Nix packages used: " - print (execEnvPackages (configExecEnv (lcConfig lc))) - putStrLn "" - else putStrLn "...not using nix..." + reexecFn <- case execEnvType (configExecEnv (lcConfig lc)) of + Just NixShellExecEnv -> do + -- for now we bypass docker if nix-shell is on + resolver <- bcResolver <$> (runStackLoggingTGlobal manager go $ + lcLoadBuildConfig lc globalResolver) + return $ Nix.reexecWithShell resolver + _ -> return Docker.reexecWithOptionalContainer runStackTGlobal manager (lcConfig lc) go $ - if isUsingNix - then Nix.reexecWithShell (lcProjectRoot lc) mbefore (inner'' lk0) mafter - (Just $ liftIO $ - do lk' <- readIORef curLk - munlockFile lk') - else Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter - (Just $ liftIO $ - do lk' <- readIORef curLk - munlockFile lk') + reexecFn (lcProjectRoot lc) mbefore (inner'' lk0) mafter + (Just $ liftIO $ + do lk' <- readIORef curLk + munlockFile lk') cleanCmd :: () -> GlobalOpts -> IO () cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) From a36c7f94280d1d9801863f279ce7c9c5df9fff3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Yves=20Par=C3=A8s?= Date: Fri, 23 Oct 2015 19:52:33 +0200 Subject: [PATCH 08/56] Cleaning up the NixShell file --- src/Stack/Docker.hs | 1 + src/Stack/ExecEnv/NixShell.hs | 818 +--------------------------------- 2 files changed, 22 insertions(+), 797 deletions(-) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index dbfb903ba0..e1abf1ff1b 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -16,6 +16,7 @@ module Stack.Docker ,reexecWithOptionalContainer ,reset ,reExecArgName + ,StackDockerException(..) ) where import Control.Applicative diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index 5a218271b4..c14924bfd6 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -4,75 +4,38 @@ -- | Run commands in a nix-shell module Stack.ExecEnv.NixShell - (--cleanup - --,CleanupOpts(..) - --,CleanupAction(..) - --,dockerCleanupCmdName - --,dockerCmdName - --,dockerPullCmdName - execWithShell - --,pull + (execWithShell ,reexecWithShell - --,reset ,reExecArgName - ,M ) where import Control.Applicative import Control.Exception.Lifted import Control.Monad -import Control.Monad.Catch (MonadThrow,throwM,MonadCatch,MonadMask) +import Control.Monad.Catch (throwM,MonadCatch,MonadMask) import Control.Monad.IO.Class (MonadIO,liftIO) -import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) +import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader,asks) -import Control.Monad.Writer (execWriter,runWriter,tell) import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) -import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Char (isSpace,toUpper,isAscii,isDigit) -import Data.Conduit.List (sinkNull) -import Data.List (dropWhileEnd,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) -import Data.List.Extra (trim) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Char (toUpper) +import Data.List (intersperse) import Data.Maybe import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) -import Data.Typeable (Typeable) import Data.Version (showVersion) -import Distribution.System (Platform (Platform), Arch (X86_64), OS (Linux)) -import Distribution.Text (display) import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.Extra (toFilePathNoTrailingSep) -import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists) import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings -import Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar) -import Stack.Docker.GlobalDB +import Stack.Constants (stackProgName) +import Stack.Docker (StackDockerException(OnlyOnHostException)) import Stack.Types import Stack.Types.Internal -import Stack.Setup (ensureDockerStackExe) -import System.Directory (canonicalizePath, getModificationTime) -import System.Environment (lookupEnv,getProgName, getArgs,getExecutablePath) +import System.Environment (lookupEnv,getArgs,getExecutablePath) import System.Exit (exitSuccess, exitWith) -import System.FilePath (takeBaseName) -import System.IO (stderr,stdin,stdout,hIsTerminalDevice) -import System.Process.PagerEditor (editByteString) import System.Process.Read import System.Process.Run import System.Process (CreateProcess(delegate_ctlc)) -import Text.Printf (printf) -#ifndef WINDOWS -import Control.Monad.Trans.Control (liftBaseWith) -import System.Posix.Signals -#endif -- | If ExecEnv is enabled, re-runs the currently running OS command in a ExecEnv container. -- Otherwise, runs the inner action. @@ -93,84 +56,13 @@ reexecWithShell reexecWithShell resolver mprojectRoot = execWithShell resolver mprojectRoot getCmdArgs where - getCmdArgs envOverride {-imageInfo-} = do - config <- asks getConfig + getCmdArgs {-envOverride imageInfo-} = do args <- fmap (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) (liftIO getArgs) - case dockerStackExe (configDocker config) of - {-Just DockerStackExeHost - | configPlatform config == dockerContainerPlatform -> - fmap (cmdArgs args) (liftIO getExecutablePath) - | otherwise -> throwM UnsupportedStackExeHostPlatformException - Just DockerStackExeImage -> do - progName <- liftIO getProgName - return (takeBaseName progName, args, [], []) - Just (DockerStackExePath path) -> - fmap - (cmdArgs args) - (liftIO $ canonicalizePath (toFilePath path)) - Just DockerStackExeDownload -> exeDownload args-} - Nothing -> do - {-| configPlatform config == dockerContainerPlatform -> do-} - (exePath,exeTimestamp,misCompatible) <- - liftIO $ - do exePath <- liftIO getExecutablePath - exeTimestamp <- liftIO (getModificationTime exePath) - {-isKnown <- - liftIO $ - getDockerImageExe - config - (iiId imageInfo) - exePath - exeTimestamp-} - return (exePath, exeTimestamp, Just True {-isKnown-}) - case misCompatible of - Just True -> do - return (cmdArgs args exePath) - {-Just False -> do - exeDownload args - Nothing -> do - e <- - try $ - sinkProcessStderrStdout - Nothing - envOverride - "docker" - [ "run" - , "-v" - , exePath ++ ":" ++ "/tmp/stack" - , iiId imageInfo - , "/tmp/stack" - , "--version"] - sinkNull - sinkNull - let compatible = - case e of - Left (ProcessExitedUnsuccessfully _ _) -> - False - Right _ -> True - liftIO $ - setDockerImageExe - config - (iiId imageInfo) - exePath - exeTimestamp - compatible - if compatible - then return (cmdArgs args exePath) - else exeDownload args - Nothing - | otherwise -> do - exeDownload args - exeDownload args = - fmap - (cmdArgs args . toFilePath) - (ensureDockerStackExe dockerContainerPlatform)-} - cmdArgs args exePath = - let mountPath = exePath -- concat ["/opt/host/bin/", takeBaseName exePath] - in (mountPath, args, [], [Mount exePath mountPath]) + exePath <- liftIO getExecutablePath + return (exePath, args) -- | If ExecEnv is enabled, re-runs the OS command returned by the second argument in a -- ExecEnv container. Otherwise, runs the inner action. @@ -180,7 +72,7 @@ execWithShell :: M env m => Resolver -> Maybe (Path Abs Dir) - -> (EnvOverride -> {-Inspect ->-} m (FilePath,[String],[(String,String)],[Mount])) + -> ({-EnvOverride -> Inspect ->-} m (FilePath,[String])) --,[(String,String)],[Mount])) -> Maybe (m ()) -> IO () -> Maybe (m ()) @@ -211,11 +103,18 @@ execWithShell resolver mprojectRoot getCmdArgs mbefore inner mafter mrelease = where fromMaybeAction Nothing = return () fromMaybeAction (Just hook) = hook - + +runShellAndExit :: M env m + => Resolver + -> m (String, [String]) + -> t + -> m () + -> m () + -> m () runShellAndExit resolver getCmdArgs mprojectRoot before after = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config) - (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride + (cmnd,args) <- getCmdArgs before let ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> @@ -245,689 +144,14 @@ runShellAndExit resolver getCmdArgs mprojectRoot before after = do -- | 'True' if we are currently running inside a ExecEnv. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) -{- --- | Run a command in a new ExecEnv, then exit the process. -runShellAndExit :: M env m - => (EnvOverride -> {-Inspect ->-} m (FilePath,[String],[(String,String)],[Mount])) - -> Maybe (Path Abs Dir) - -> m () - -> m () - -> m () -runShellAndExit getCmdArgs - mprojectRoot - before - after = - do config <- asks getConfig - let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - --checkDockerVersion envOverride - (dockerHost,dockerCertPath,bamboo,jenkins) <- - liftIO ((,,,) <$> lookupEnv "DOCKER_HOST" - <*> lookupEnv "DOCKER_CERT_PATH" - <*> lookupEnv "bamboo_buildKey" - <*> lookupEnv "JENKINS_HOME") - let isRemoteExecEnv = maybe False (isPrefixOf "tcp://") dockerHost - userEnvVars <- - if fromMaybe (not isRemoteExecEnv) (dockerSetUser docker) - then do - uidOut <- readProcessStdout Nothing envOverride "id" ["-u"] - gidOut <- readProcessStdout Nothing envOverride "id" ["-g"] - return - [ "-e","WORK_UID=" ++ dropWhileEnd isSpace (decodeUtf8 uidOut) - , "-e","WORK_GID=" ++ dropWhileEnd isSpace (decodeUtf8 gidOut) ] - else return [] - isStdoutTerminal <- asks getTerminal - (isStdinTerminal,isStderrTerminal) <- - liftIO ((,) <$> hIsTerminalDevice stdin - <*> hIsTerminalDevice stderr) - pwd <- getWorkingDir - when (isRemoteExecEnv && - 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 envOverride docker image - mii2 <- inspect envOverride image - case mii2 of - Just ii2 -> return ii2 - Nothing -> throwM (InspectFailedException image) - | otherwise -> throwM (NotPulledException image) - (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride {-imageInfo-} - let imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo)) - sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) - 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 = not (dockerDetach docker) && - isStdinTerminal && - isStdoutTerminal && - isStderrTerminal - keepStdinOpen = not (dockerDetach docker) && - -- Workaround for https://github.com/docker/docker/issues/12319 - (isTerm || (isNothing bamboo && isNothing jenkins)) - liftIO - (do updateDockerImageLastUsed config - (iiId imageInfo) - (toFilePath projectRoot) - - mapM_ createTree - (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ - sandboxSubdirs])) - containerID <- (trim . decodeUtf8) <$> readDockerProcess - envOverride - (concat - [["create" - ,"--net=host" - ,"-e",inContainerEnvVar ++ "=1" - ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot - ,"-e","WORK_WD=" ++ toFilePathNoTrailingSep pwd - ,"-e","WORK_HOME=" ++ toFilePathNoTrailingSep sandboxRepoDir - ,"-e","WORK_ROOT=" ++ toFilePathNoTrailingSep projectRoot - ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot - ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot - ,"-v",toFilePathNoTrailingSep sandboxSandboxDir ++ ":" ++ toFilePathNoTrailingSep sandboxDir - ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxRepoDir - ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ - toFilePathNoTrailingSep (sandboxRepoDir $(mkRelDir ("." ++ stackProgName ++ "/")))] - ,userEnvVars - ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars - ,concatMap sandboxSubdirArg sandboxSubdirs - ,concatMap mountArg (extraMount ++ dockerMount docker) - ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker) - ,case dockerContainerName docker of - Just name -> ["--name=" ++ name] - Nothing -> [] - ,["-t" | isTerm] - ,["-i" | keepStdinOpen] - ,dockerRunArgs docker - ,[image] - ,[cmnd] - ,args]) - before - e <- try (callProcess' - (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) - Nothing - envOverride - "docker" - (concat [["start"] - --,["-a" | not (dockerDetach docker)] - --,["-i" | keepStdinOpen] - ,[containerID]])) - unless (dockerPersist docker || dockerDetach docker) - (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID]) - case e of - Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) - Right () -> do after - liftIO exitSuccess - where - lookupImageEnv name vars = - case lookup name vars of - Just ('=':val) -> Just val - _ -> Nothing - mountArg (Mount host container) = ["-v",host ++ ":" ++ container] - sandboxSubdirArg subdir = ["-v",toFilePathNoTrailingSep subdir++ ":" ++ toFilePathNoTrailingSep subdir] - projectRoot = fromMaybeProjectRoot mprojectRoot - --- | Clean-up old docker images and containers. -cleanup :: M env m - => CleanupOpts -> m () -cleanup opts = - do config <- asks getConfig - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride - let runDocker = readDockerProcess envOverride - imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] - danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] - runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"] - restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"] - exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"] - pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"] - let imageRepos = parseImagesOut imagesOut - danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut) - runningContainers = parseContainersOut runningContainersOut ++ - parseContainersOut restartingContainersOut - stoppedContainers = parseContainersOut exitedContainersOut ++ - parseContainersOut pausedContainersOut - inspectMap <- inspects envOverride - (Map.keys imageRepos ++ - danglingImageHashes ++ - map fst stoppedContainers ++ - map fst runningContainers) - (imagesLastUsed,curTime) <- - liftIO ((,) <$> getDockerImagesLastUsed config - <*> getZonedTime) - let planWriter = buildPlan curTime - imagesLastUsed - imageRepos - danglingImageHashes - stoppedContainers - runningContainers - inspectMap - plan = toLazyByteString (execWriter planWriter) - plan' <- case dcAction opts of - CleanupInteractive -> - liftIO (editByteString (intercalate "-" [stackProgName - ,dockerCmdName - ,dockerCleanupCmdName - ,"plan"]) - plan) - CleanupImmediate -> return plan - CleanupDryRun -> do liftIO (LBS.hPut stdout plan) - return LBS.empty - mapM_ (performPlanLine envOverride) - (reverse (filter filterPlanLine (lines (LBS.unpack plan')))) - allImageHashesOut <- runDocker ["images","-aq","--no-trunc"] - liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut))) - where - filterPlanLine line = - case line of - c:_ | isSpace c -> False - _ -> True - performPlanLine envOverride line = - case filter (not . null) (words (takeWhile (/= '#') line)) of - [] -> return () - (c:_):t:v:_ -> - do args <- if | toUpper c == 'R' && t == imageStr -> - do $logInfo (concatT ["Removing image: '",v,"'"]) - return ["rmi",v] - | toUpper c == 'R' && t == containerStr -> - do $logInfo (concatT ["Removing container: '",v,"'"]) - return ["rm","-f",v] - | otherwise -> throwM (InvalidCleanupCommandException line) - e <- try (readDockerProcess envOverride args) - case e of - Left (ReadProcessException _ _ _ _) -> - $logError (concatT ["Could not remove: '",v,"'"]) - Left e' -> throwM e' - Right _ -> return () - _ -> throwM (InvalidCleanupCommandException line) - parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8 - where parseImageRepo :: String -> (String, [String]) - parseImageRepo line = - case words line of - repo:tag:hash:_ - | repo == "" -> (hash,[]) - | tag == "" -> (hash,[repo]) - | otherwise -> (hash,[repo ++ ":" ++ tag]) - _ -> throw (InvalidImagesOutputException line) - parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8 - where parseContainer line = - case words line of - hash:image:rest -> (hash,(image,last rest)) - _ -> throw (InvalidPSOutputException line) - buildPlan curTime - imagesLastUsed - imageRepos - danglingImageHashes - stoppedContainers - runningContainers - inspectMap = - do case dcAction opts of - CleanupInteractive -> - do buildStrLn - (concat - ["# STACK DOCKER CLEANUP PLAN" - ,"\n#" - ,"\n# When you leave the editor, the lines in this plan will be processed." - ,"\n#" - ,"\n# Lines that begin with 'R' denote an image or container that will be." - ,"\n# removed. You may change the first character to/from 'R' to remove/keep" - ,"\n# and image or container that would otherwise be kept/removed." - ,"\n#" - ,"\n# To cancel the cleanup, delete all lines in this file." - ,"\n#" - ,"\n# By default, the following images/containers will be removed:" - ,"\n#"]) - buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used" - buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created" - buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created" - buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created" - buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created" - buildStrLn - (concat - ["#" - ,"\n# The default plan can be adjusted using command-line arguments." - ,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] ++ - " --help' for details." - ,"\n#"]) - _ -> buildStrLn - (unlines - ["# Lines that begin with 'R' denote an image or container that will be." - ,"# removed."]) - buildSection "KNOWN IMAGES (pulled/used by stack)" - imagesLastUsed - buildKnownImage - buildSection "UNKNOWN IMAGES (not managed by stack)" - (sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m) - imageRepos - imagesLastUsed))) - buildUnknownImage - buildSection "DANGLING IMAGES (no named references and not depended on by other images)" - (sortCreated (map (,()) danglingImageHashes)) - buildDanglingImage - buildSection "STOPPED CONTAINERS" - (sortCreated stoppedContainers) - (buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts)) - buildSection "RUNNING CONTAINERS" - (sortCreated runningContainers) - (buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts)) - where - buildDefault accessor description = - case accessor opts of - Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".") - Nothing -> return () - sortCreated 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 disp = (name ++ " (image: " ++ image ++ ")") - buildTime containerStr removeAge created disp - buildInspect hash - return True - buildProject (lastUsedTime, projectPath) = - buildInfo ("Last used " ++ - showDaysAgo lastUsedTime ++ - " in " ++ - projectPath) - buildInspect hash = - case Map.lookup hash inspectMap of - Just (Inspect{iiCreated,iiVirtualSize}) -> - buildInfo ("Created " ++ - showDaysAgo iiCreated ++ - maybe "" - (\s -> " (size: " ++ - printf "%g" (fromIntegral s / 1024.0 / 1024.0 :: Float) ++ - "M)") - iiVirtualSize) - Nothing -> return () - showDays days = - case days of - 0 -> "today" - 1 -> "yesterday" - n -> show n ++ " days ago" - showDaysAgo oldTime = showDays (daysAgo oldTime) - daysAgo oldTime = - let ZonedTime (LocalTime today _) zone = curTime - LocalTime oldDay _ = utcToLocalTime zone oldTime - in diffDays today oldDay - buildImageTime = buildTime imageStr - buildTime t removeAge time disp = - case removeAge of - Just d | daysAgo time >= d -> buildStrLn ("R " ++ t ++ " " ++ disp) - _ -> buildKeep t disp - buildKeep t d = buildStrLn (" " ++ t ++ " " ++ d) - buildKeepImage = buildKeep imageStr - buildSectionHead s = buildStrLn ("\n#\n# " ++ s ++ "\n#\n") - buildInfo = buildStrLn . (" # " ++) - buildStrLn l = do buildStr l - tell (charUtf8 '\n') - buildStr = tell . stringUtf8 - - imageStr = "image" - containerStr = "container" --- | Inspect Docker image or container. -inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) - => EnvOverride -> String -> m (Maybe Inspect) -inspect envOverride image = - do results <- inspects envOverride [image] - case Map.toList results of - [] -> return Nothing - [(_,i)] -> return (Just i) - _ -> throwM (InvalidInspectOutputException "expect a single result") - --- | Inspect multiple Docker images and/or containers. -inspects :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> [String] -> m (Map String Inspect) -inspects _ [] = return Map.empty -inspects envOverride images = - do maybeInspectOut <- - try (readDockerProcess envOverride ("inspect" : images)) - case maybeInspectOut of - Right inspectOut -> - -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8 - case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of - Left msg -> throwM (InvalidInspectOutputException msg) - Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) - Left (ReadProcessException _ _ _ _) -> return Map.empty - Left e -> throwM e - --- | Pull latest version of configured Docker image from registry. -pull :: M env m => m () -pull = - do config <- asks getConfig - let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride - pullImage envOverride docker (dockerImage docker) - --- | Pull Docker image from registry. -pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) - => EnvOverride -> DockerOpts -> String -> m () -pullImage envOverride docker image = - do $logInfo (concatT ["Pulling image from registry: '",image,"'"]) - when (dockerRegistryLogin docker) - (do $logInfo "You may need to log in." - callProcess - Nothing - envOverride - "docker" - (concat - [["login"] - ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) - ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) - ,[takeWhile (/= '/') image]])) - e <- 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, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> m () -checkDockerVersion envOverride = - do dockerExists <- doesExecutableExist envOverride "docker" - unless dockerExists (throwM DockerNotInstalledException) - dockerVersionOut <- readDockerProcess envOverride ["--version"] - case words (decodeUtf8 dockerVersionOut) of - (_:_:v:_) -> - case parseVersionFromString (dropWhileEnd (not . isDigit) v) of - Just v' - | v' < minimumDockerVersion -> - throwM (DockerTooOldException minimumDockerVersion v') - | v' `elem` prohibitedDockerVersions -> - throwM (DockerVersionProhibitedException prohibitedDockerVersions v') - | otherwise -> - return () - _ -> throwM InvalidVersionOutputException - _ -> throwM InvalidVersionOutputException - where minimumDockerVersion = $(mkVersion "1.3.0") - prohibitedDockerVersions = [$(mkVersion "1.2.0")] - --- | 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 <- dirExists path - when isRootDir - (do (lsd,lsf) <- listDirectory path - forM_ lsd - (\d -> unless (dirname d `elem` excludeDirs) - (removeTree d)) - forM_ lsf - (\f -> unless (filename f `elem` excludeFiles) - (removeFile f))) --} --- | Produce a strict 'S.ByteString' from the stdout of a --- process. Throws a 'ReadProcessException' exception if the --- process fails. Logs process's stderr using @$logError@. -readDockerProcess - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> [String] -> m BS.ByteString -readDockerProcess envOverride args = - readProcessStdout Nothing envOverride "docker" args -{- --- | 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/") --} --- | Convenience function to decode ByteString to String. -decodeUtf8 :: BS.ByteString -> String -decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs)) -{- --- | Convenience function constructing message for @$log*@. -concatT :: [String] -> Text -concatT = T.pack . concat --} --- | Fail with friendly error if project root not set. -fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir -fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) -{- --- | Environment variable that contains the sandbox ID. -sandboxIDEnvVar :: String -sandboxIDEnvVar = "DOCKER_SANDBOX_ID" --} -- | Environment variable used to indicate stack is running in container. inContainerEnvVar :: String inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] --- | Command-line argument for "docker" -dockerCmdName :: String -dockerCmdName = "docker" - --- | Command-line argument for @docker pull@. -dockerPullCmdName :: String -dockerPullCmdName = "pull" -{- --- | Command-line argument for @docker cleanup@. -dockerCleanupCmdName :: String -dockerCleanupCmdName = "cleanup" --} -- | Command-line option for @--internal-re-exec@. reExecArgName :: String reExecArgName = "internal-re-exec-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. - | CannotDetermineProjectRootException - -- ^ Can't determine the project root (where to put docker sandbox). - | DockerNotInstalledException - -- ^ @docker --version@ failed. - | UnsupportedStackExeHostPlatformException - -- ^ Using host stack-exe on unsupported platform. - deriving (Typeable) - --- | Exception instance for StackDockerException. -instance Exception StackDockerException - --- | Show instance for StackDockerException. -instance Show StackDockerException where - show DockerMustBeEnabledException = - concat ["Docker must be enabled in your configuration file to use this command."] - show OnlyOnHostException = - "This command must be run on host OS (not in a Docker container)." - show (InspectFailedException image) = - concat ["'docker inspect' failed for image after pull: ",image,"."] - show (NotPulledException image) = - concat ["The Docker image referenced by your configuration file" - ," has not\nbeen downloaded:\n " - ,image - ,"\n\nRun '" - ,unwords [stackProgName, dockerCmdName, dockerPullCmdName] - ,"' to download it, then try again."] - show (InvalidCleanupCommandException line) = - concat ["Invalid line in cleanup commands: '",line,"'."] - show (InvalidImagesOutputException line) = - concat ["Invalid 'docker images' output line: '",line,"'."] - show (InvalidPSOutputException line) = - concat ["Invalid 'docker ps' output line: '",line,"'."] - show (InvalidInspectOutputException msg) = - concat ["Invalid 'docker inspect' output: ",msg,"."] - show (PullFailedException image) = - concat ["Could not pull Docker image:\n " - ,image - ,"\nThere may not be an image on the registry for your resolver's LTS version in\n" - ,"your configuration file."] - show (DockerTooOldException minVersion haveVersion) = - concat ["Minimum docker version '" - ,versionString minVersion - ,"' is required (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 CannotDetermineProjectRootException = - "Cannot determine project root directory for Docker sandbox." - show DockerNotInstalledException = - "Cannot find 'docker' in PATH. Is Docker installed?" - show UnsupportedStackExeHostPlatformException = concat - [ "Using host's " - , stackProgName - , " executable in Docker container is only supported on " - , display dockerContainerPlatform - , " platform" ] - --- | Platform that Docker containers run -dockerContainerPlatform :: Platform -dockerContainerPlatform = Platform X86_64 Linux -- | A shortcut type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m From bdb32f790d5ceb72718fcaf28b8a873842619178 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sat, 24 Oct 2015 11:35:21 +0200 Subject: [PATCH 09/56] Remove redundant LANGUAGE pragmas. --- src/Stack/ExecEnv/NixShell.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index c14924bfd6..ef5eb55920 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns, - OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskell, - TupleSections #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} -- | Run commands in a nix-shell module Stack.ExecEnv.NixShell From ffea96d29cd552973243d0768873b3b081c51525 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sat, 24 Oct 2015 11:35:35 +0200 Subject: [PATCH 10/56] Remove trailing whitespace. --- src/Stack/ExecEnv/NixShell.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/ExecEnv/NixShell.hs index ef5eb55920..1b12155267 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/ExecEnv/NixShell.hs @@ -39,7 +39,7 @@ import System.Process (CreateProcess(delegate_ctlc)) -- | If ExecEnv is enabled, re-runs the currently running OS command in a ExecEnv container. -- Otherwise, runs the inner action. --- +-- -- This takes an optional release action which should be taken IFF control is -- transfering away from the current process to the intra-container one. The main use -- for this is releasing a lock. After launching reexecution, the host process becomes @@ -103,7 +103,7 @@ execWithShell resolver mprojectRoot getCmdArgs mbefore inner mafter mrelease = where fromMaybeAction Nothing = return () fromMaybeAction (Just hook) = hook - + runShellAndExit :: M env m => Resolver -> m (String, [String]) From a8e9b7fadc220f6c22db6cd694b1c0bc805112ac Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 07:21:55 +0100 Subject: [PATCH 11/56] Rename ExecEnv to Nix. --- src/Stack/Config.hs | 2 +- src/Stack/Config/{ExecEnv.hs => Nix.hs} | 4 ++-- src/Stack/{ExecEnv/NixShell.hs => Nix.hs} | 2 +- src/Stack/Types.hs | 2 +- src/Stack/Types/Config.hs | 2 +- src/Stack/Types/{ExecEnv.hs => Nix.hs} | 4 ++-- src/main/Main.hs | 2 +- stack.cabal | 6 +++--- 8 files changed, 12 insertions(+), 12 deletions(-) rename src/Stack/Config/{ExecEnv.hs => Nix.hs} (97%) rename src/Stack/{ExecEnv/NixShell.hs => Nix.hs} (99%) rename src/Stack/Types/{ExecEnv.hs => Nix.hs} (99%) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 40a935532e..796b5cc77c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -68,7 +68,7 @@ import Safe (headMay) import Stack.BuildPlan import Stack.Constants import Stack.Config.Docker -import Stack.Config.ExecEnv +import Stack.Config.Nix import qualified Stack.Image as Image import Stack.Init import Stack.Types diff --git a/src/Stack/Config/ExecEnv.hs b/src/Stack/Config/Nix.hs similarity index 97% rename from src/Stack/Config/ExecEnv.hs rename to src/Stack/Config/Nix.hs index c33a7c1675..be464dd21f 100644 --- a/src/Stack/Config/ExecEnv.hs +++ b/src/Stack/Config/Nix.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-} --- | Docker configuration -module Stack.Config.ExecEnv where +-- | Nix configuration +module Stack.Config.Nix where import Control.Exception.Lifted import Control.Monad diff --git a/src/Stack/ExecEnv/NixShell.hs b/src/Stack/Nix.hs similarity index 99% rename from src/Stack/ExecEnv/NixShell.hs rename to src/Stack/Nix.hs index 1b12155267..24a90eac86 100644 --- a/src/Stack/ExecEnv/NixShell.hs +++ b/src/Stack/Nix.hs @@ -3,7 +3,7 @@ {-# LANGUAGE MultiWayIf #-} -- | Run commands in a nix-shell -module Stack.ExecEnv.NixShell +module Stack.Nix (execWithShell ,reexecWithShell ,reExecArgName diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs index 80d1d46f70..8b2266e370 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -12,7 +12,7 @@ import Stack.Types.PackageName as X import Stack.Types.Version as X import Stack.Types.Config as X import Stack.Types.Docker as X -import Stack.Types.ExecEnv as X +import Stack.Types.Nix as X import Stack.Types.Image as X import Stack.Types.Build as X import Stack.Types.Package as X diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index c80083ea16..2c75fe0556 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -55,7 +55,7 @@ import qualified Paths_stack as Meta import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import Stack.Types.Compiler import Stack.Types.Docker -import Stack.Types.ExecEnv +import Stack.Types.Nix import Stack.Types.FlagName import Stack.Types.Image import Stack.Types.PackageIdentifier diff --git a/src/Stack/Types/ExecEnv.hs b/src/Stack/Types/Nix.hs similarity index 99% rename from src/Stack/Types/ExecEnv.hs rename to src/Stack/Types/Nix.hs index aa229cc386..dd54c1a474 100644 --- a/src/Stack/Types/ExecEnv.hs +++ b/src/Stack/Types/Nix.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-} --- | Docker types. +-- | Nix types. -module Stack.Types.ExecEnv where +module Stack.Types.Nix where import Control.Applicative import Control.Monad diff --git a/src/main/Main.hs b/src/main/Main.hs index ae6f818845..de07fd70cd 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -57,7 +57,7 @@ import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot import Stack.Exec -import qualified Stack.ExecEnv.NixShell as Nix +import qualified Stack.Nix as Nix import Stack.Fetch import Stack.FileWatch import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) diff --git a/stack.cabal b/stack.cabal index aad998f761..29a87d2234 100644 --- a/stack.cabal +++ b/stack.cabal @@ -53,20 +53,20 @@ library Stack.BuildPlan Stack.Config Stack.Config.Docker - Stack.Config.ExecEnv + Stack.Config.Nix Stack.ConfigCmd Stack.Constants Stack.Coverage Stack.Docker Stack.Docker.GlobalDB Stack.Dot - Stack.ExecEnv.NixShell Stack.Fetch Stack.Exec Stack.FileWatch Stack.GhcPkg Stack.Init Stack.New + Stack.Nix Stack.Options Stack.Package Stack.PackageDump @@ -84,10 +84,10 @@ library Stack.Types.Compiler Stack.Types.Config Stack.Types.Docker - Stack.Types.ExecEnv Stack.Types.FlagName Stack.Types.GhcPkgId Stack.Types.Image + Stack.Types.Nix Stack.Types.PackageIdentifier Stack.Types.PackageName Stack.Types.TemplateName From 9e8a2dce523882066e2c264161fc0356d2754f10 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 07:33:07 +0100 Subject: [PATCH 12/56] Remove dead code. --- src/Stack/Config/Nix.hs | 43 --------------- src/Stack/Types/Nix.hs | 112 +++++----------------------------------- 2 files changed, 12 insertions(+), 143 deletions(-) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index be464dd21f..e5c0b336cc 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -24,47 +24,4 @@ execEnvOptsFromMonoid mproject stackRoot ExecEnvOptsMonoid{..} = do else Nothing execEnvPackages = execEnvMonoidPackages execEnvInitFile = execEnvMonoidInitFile - {- dockerContainerName = emptyToNothing dockerMonoidContainerName - dockerRunArgs = dockerMonoidRunArgs - dockerMount = dockerMonoidMount - dockerEnv = dockerMonoidEnv - dockerDatabasePath <- - case dockerMonoidDatabasePath of - Nothing -> return $ stackRoot $(mkRelFile "docker.db") - Just fp -> - case parseAbsFile fp of - Left e -> throwM (InvalidDatabasePathException e) - Right p -> return p - dockerStackExe <- - case dockerMonoidStackExe of - Just e -> liftM Just (parseDockerStackExe e) - Nothing -> return Nothing -} return ExecEnvOpts{..} - -{- where emptyToNothing Nothing = Nothing - emptyToNothing (Just s) | null s = Nothing - | otherwise = Just s - --- | Exceptions thrown by Stack.Docker.Config. -data StackNixConfigException - = ResolverNotSupportedException String - -- ^ Only LTS resolvers are supported for default image tag. - | InvalidDatabasePathException SomeException - -- ^ Invalid global database path. - deriving (Typeable) - --- | Exception instance for StackDockerConfigException. -instance Exception StackDockerConfigException - --- | Show instance for StackDockerConfigException. -instance Show StackDockerConfigException where - show (ResolverNotSupportedException resolver) = - concat - [ "Resolver not supported for Docker images:\n " - , resolver - , "\nUse an LTS resolver, or set the '" - , T.unpack dockerImageArgName - , "' explicitly, in your configuration file."] - show (InvalidDatabasePathException ex) = - concat ["Invalid database path: ", show ex] --} diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index dd54c1a474..51d39a645e 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -26,17 +26,6 @@ data ExecEnvOpts = ExecEnvOpts -- ^ The system packages to be installed in the environment before it runs ,execEnvInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) --- ,dockerContainerName :: !(Maybe String) - -- ^ Container name to use, only makes sense from command-line with `dockerPersist` - -- or `dockerDetach`. --- ,execEnvRunArgs :: ![String] - -- ^ Arguments to pass directly to @docker run@. --- ,dockerEnv :: ![String] - -- ^ Environment variables to set in the container. --- ,dockerDatabasePath :: !(Path Abs File) - -- ^ Location of image usage database. --- ,dockerStackExe :: !(Maybe DockerStackExe) - -- ^ Location of container-compatible stack executable } deriving (Show) @@ -51,76 +40,33 @@ data ExecEnvOptsMonoid = ExecEnvOptsMonoid -- ^ System packages to use (given to nix-shell) ,execEnvMonoidInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) --- ,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@ --- ,dockerMonoidEnv :: ![String] - -- ^ Environment variables to set in the container --- ,dockerMonoidDatabasePath :: !(Maybe String) - -- ^ Location of image usage database. --- ,dockerMonoidStackExe :: !(Maybe String) - -- ^ Location of container-compatible stack executable } deriving (Show) -- | Decode uninterpreted docker options from JSON/YAML. instance FromJSON (ExecEnvOptsMonoid, [JSONWarning]) where parseJSON = withObjectWarnings "DockerOptsMonoid" - (\o -> do execEnvMonoidDefaultEnable <- pure True - execEnvMonoidEnable <- o ..:? execEnvEnableArgName - execEnvMonoidPackages <- o ..:? execEnvPackagesArgName ..!= [] - execEnvMonoidInitFile <- o ..:? execEnvInitFileArgName --- dockerMonoidContainerName <- o ..:? dockerContainerNameArgName --- dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] --- dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= [] --- dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName --- dockerMonoidStackExe <- o ..:? dockerStackExeArgName + (\o -> do execEnvMonoidDefaultEnable <- pure True + execEnvMonoidEnable <- o ..:? execEnvEnableArgName + execEnvMonoidPackages <- o ..:? execEnvPackagesArgName ..!= [] + execEnvMonoidInitFile <- o ..:? execEnvInitFileArgName return ExecEnvOptsMonoid{..}) -- | Left-biased combine Docker options instance Monoid ExecEnvOptsMonoid where mempty = ExecEnvOptsMonoid - {execEnvMonoidDefaultEnable = False - ,execEnvMonoidEnable = Nothing - ,execEnvMonoidPackages = [] - ,execEnvMonoidInitFile = Nothing --- ,dockerMonoidContainerName = Nothing --- ,dockerMonoidRunArgs = [] --- ,dockerMonoidEnv = [] --- ,dockerMonoidDatabasePath = Nothing --- ,dockerMonoidStackExe = Nothing + {execEnvMonoidDefaultEnable = False + ,execEnvMonoidEnable = Nothing + ,execEnvMonoidPackages = [] + ,execEnvMonoidInitFile = Nothing } mappend l r = ExecEnvOptsMonoid - {execEnvMonoidDefaultEnable = execEnvMonoidDefaultEnable l || execEnvMonoidDefaultEnable r - ,execEnvMonoidEnable = execEnvMonoidEnable l <|> execEnvMonoidEnable r - ,execEnvMonoidPackages = execEnvMonoidPackages l <> execEnvMonoidPackages r - ,execEnvMonoidInitFile = execEnvMonoidInitFile l <|> execEnvMonoidInitFile r --- ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r --- ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l --- ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l --- ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r --- ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r + {execEnvMonoidDefaultEnable = execEnvMonoidDefaultEnable l || execEnvMonoidDefaultEnable r + ,execEnvMonoidEnable = execEnvMonoidEnable l <|> execEnvMonoidEnable r + ,execEnvMonoidPackages = execEnvMonoidPackages l <> execEnvMonoidPackages r + ,execEnvMonoidInitFile = execEnvMonoidInitFile l <|> execEnvMonoidInitFile r } -{- -- | Where to get the `stack` executable to run in Docker containers -data DockerStackExe - = DockerStackExeDownload -- ^ Download from official bindist - | DockerStackExeHost -- ^ Host's `stack` (linux-x86_64 only) - | DockerStackExeImage -- ^ Docker image's `stack` (versions must match) - | DockerStackExePath (Path Abs File) -- ^ Executable at given path - deriving (Show) - --- | Parse 'DockerStackExe'. -parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe -parseDockerStackExe t - | t == dockerStackExeDownloadVal = return DockerStackExeDownload - | t == dockerStackExeHostVal = return DockerStackExeHost - | t == dockerStackExeImageVal = return DockerStackExeImage - | otherwise = liftM DockerStackExePath (parseAbsFile t) --} - -- | ExecEnv enable argument name. execEnvEnableArgName :: Text execEnvEnableArgName = "enable" @@ -132,37 +78,3 @@ execEnvPackagesArgName = "packages" -- | ExecEnv init env file path argument name. execEnvInitFileArgName :: Text execEnvInitFileArgName = "init-env-file" - -{- --- | Docker run args argument name. -dockerRunArgsArgName :: Text -dockerRunArgsArgName = "run-args" - --- | Docker environment variable argument name. -dockerEnvArgName :: Text -dockerEnvArgName = "env" - --- | Docker container name argument name. -dockerContainerNameArgName :: Text -dockerContainerNameArgName = "container-name" - --- | Docker database path argument name. -dockerDatabasePathArgName :: Text -dockerDatabasePathArgName = "database-path" - --- | Docker database path argument name. -dockerStackExeArgName :: Text -dockerStackExeArgName = "stack-exe" - --- | Value for @--docker-stack-exe=download@ -dockerStackExeDownloadVal :: String -dockerStackExeDownloadVal = "download" - --- | Value for @--docker-stack-exe=host@ -dockerStackExeHostVal :: String -dockerStackExeHostVal = "host" - --- | Value for @--docker-stack-exe=image@ -dockerStackExeImageVal :: String -dockerStackExeImageVal = "image" --} From 2809ff9696e07ee75e8283da4abc2bac1e941296 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 15:56:00 +0100 Subject: [PATCH 13/56] Remove ExecEnv abstraction. Allow docker + nix simultaneously. Don't dispatch on the ExecEnv type. Using Docker and nix is no longer mutually exclusive. We run commands in a docker container if configured, and then fork a nix-shell inside if configured. --- src/Stack/Config.hs | 2 +- src/Stack/Config/Nix.hs | 17 +++---- src/Stack/Nix.hs | 93 +++++++++++++++++---------------------- src/Stack/Types/Config.hs | 10 ++--- src/Stack/Types/Nix.hs | 89 ++++++++++++++++++------------------- src/main/Main.hs | 39 +++++++++------- 6 files changed, 119 insertions(+), 131 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 796b5cc77c..db49723755 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -144,7 +144,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts - configExecEnv <- execEnvOptsFromMonoid mproject configStackRoot configMonoidExecEnvOpts + configNix <- nixOptsFromMonoid mproject configStackRoot configMonoidNixOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index e5c0b336cc..e9c2c534ca 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -14,14 +14,11 @@ import Path import Stack.Types -- | Interprets DockerOptsMonoid options. -execEnvOptsFromMonoid +nixOptsFromMonoid :: MonadThrow m - => Maybe Project -> Path Abs Dir -> ExecEnvOptsMonoid -> m ExecEnvOpts -execEnvOptsFromMonoid mproject stackRoot ExecEnvOptsMonoid{..} = do - let execEnvType = - if fromMaybe execEnvMonoidDefaultEnable execEnvMonoidEnable - then Just NixShellExecEnv - else Nothing - execEnvPackages = execEnvMonoidPackages - execEnvInitFile = execEnvMonoidInitFile - return ExecEnvOpts{..} + => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts +nixOptsFromMonoid mproject stackRoot NixOptsMonoid{..} = do + let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable + nixPackages = nixMonoidPackages + nixInitFile = nixMonoidInitFile + return NixOpts{..} diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 24a90eac86..5648f5ef21 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -4,8 +4,8 @@ -- | Run commands in a nix-shell module Stack.Nix - (execWithShell - ,reexecWithShell + (execWithOptionalShell + ,reexecWithOptionalShell ,reExecArgName ) where @@ -37,26 +37,22 @@ import System.Process.Run import System.Process (CreateProcess(delegate_ctlc)) --- | If ExecEnv is enabled, re-runs the currently running OS command in a ExecEnv container. +-- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. -- -- This takes an optional release action which should be taken IFF control is -- transfering away from the current process to the intra-container one. The main use -- for this is releasing a lock. After launching reexecution, the host process becomes -- nothing but an manager for the call into docker and thus may not hold the lock. -reexecWithShell +reexecWithOptionalShell :: M env m - => Resolver -- ^ Needed for installing ghc in the nix-shell - -> Maybe (Path Abs Dir) - -> Maybe (m ()) + => Maybe (Path Abs Dir) -> IO () - -> Maybe (m ()) - -> Maybe (m ()) -> m () -reexecWithShell resolver mprojectRoot = - execWithShell resolver mprojectRoot getCmdArgs +reexecWithOptionalShell mprojectRoot = + execWithOptionalShell mprojectRoot getCmdArgs where - getCmdArgs {-envOverride imageInfo-} = do + getCmdArgs = do args <- fmap (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) @@ -64,63 +60,47 @@ reexecWithShell resolver mprojectRoot = exePath <- liftIO getExecutablePath return (exePath, args) --- | If ExecEnv is enabled, re-runs the OS command returned by the second argument in a --- ExecEnv container. Otherwise, runs the inner action. +-- | If Nix is enabled, re-runs the OS command returned by the second argument in a +-- Nix container. Otherwise, runs the inner action. -- --- This takes an optional release action just like `reexecWithOptionalContainer`. -execWithShell +-- This takes an optional release action just like `reexecWithOptionalShell`. +execWithOptionalShell :: M env m - => Resolver - -> Maybe (Path Abs Dir) - -> ({-EnvOverride -> Inspect ->-} m (FilePath,[String])) --,[(String,String)],[Mount])) - -> Maybe (m ()) + => Maybe (Path Abs Dir) + -> m (FilePath,[String]) -> IO () - -> Maybe (m ()) - -> Maybe (m ()) -> m () -execWithShell resolver mprojectRoot getCmdArgs mbefore inner mafter mrelease = +execWithOptionalShell mprojectRoot getCmdArgs inner = do config <- asks getConfig inShell <- getInShell isReExec <- asks getReExec - let envType = execEnvType (configExecEnv config) - if | inShell && not isReExec && (isJust mbefore || isJust mafter) -> + if | inShell && not isReExec -> throwM OnlyOnHostException | inShell -> liftIO (do inner exitSuccess) - | isNothing envType -> - do fromMaybeAction mbefore - liftIO inner - fromMaybeAction mafter + | not (nixEnable (configNix config)) -> + do liftIO inner liftIO exitSuccess - | envType == Just NixShellExecEnv -> - do fromMaybeAction mrelease - runShellAndExit resolver + | otherwise -> + do runShellAndExit getCmdArgs mprojectRoot - (fromMaybeAction mbefore) - (fromMaybeAction mafter) - where - fromMaybeAction Nothing = return () - fromMaybeAction (Just hook) = hook runShellAndExit :: M env m - => Resolver - -> m (String, [String]) - -> t - -> m () + => m (String, [String]) + -> Maybe (Path Abs Dir) -> m () - -> m () -runShellAndExit resolver getCmdArgs mprojectRoot before after = do +runShellAndExit getCmdArgs mprojectRoot = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- getCmdArgs - before + resolver <- bcResolver <$> asks getBuildConfig let ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> - "haskell.packages.lts-" ++ (show x) ++ "_" ++ (show y) ++ ".ghc" + "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" - nixpkgs = [ghcInNix] ++ (map show (execEnvPackages (configExecEnv config))) + nixpkgs = [ghcInNix] ++ (map show (nixPackages (configNix config))) fullArgs = (concat [["--pure", "-p"] ,nixpkgs ,["--command"] @@ -137,11 +117,9 @@ runShellAndExit resolver getCmdArgs mprojectRoot before after = do fullArgs) case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) - Right () -> do after - liftIO exitSuccess - + Right () -> liftIO exitSuccess --- | 'True' if we are currently running inside a ExecEnv. +-- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) @@ -153,6 +131,15 @@ inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] reExecArgName :: String reExecArgName = "internal-re-exec-version" --- | A shortcut -type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m - ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m) +type M env m = + (MonadIO m + ,MonadReader env m + ,MonadLogger m + ,MonadBaseControl IO m + ,MonadCatch m + ,HasBuildConfig env + ,HasTerminal env + ,HasReExec env + ,HasHttpManager env + ,MonadMask m + ) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 2c75fe0556..278cd91872 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -75,7 +75,7 @@ data Config = -- ^ Path to user configuration file (usually ~/.stack/config.yaml) ,configDocker :: !DockerOpts -- ^ Docker configuration - ,configExecEnv :: !ExecEnvOpts + ,configNix :: !NixOpts -- ^ Execution environment (e.g nix-shell) configuration ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools @@ -588,7 +588,7 @@ data ConfigMonoid = ConfigMonoid { configMonoidDockerOpts :: !DockerOptsMonoid -- ^ Docker options. - , configMonoidExecEnvOpts :: !ExecEnvOptsMonoid + , configMonoidNixOpts :: !NixOptsMonoid -- ^ Options for the execution environment (nix-shell or container) , configMonoidConnectionCount :: !(Maybe Int) -- ^ See: 'configConnectionCount' @@ -656,7 +656,7 @@ data ConfigMonoid = instance Monoid ConfigMonoid where mempty = ConfigMonoid { configMonoidDockerOpts = mempty - , configMonoidExecEnvOpts = mempty + , configMonoidNixOpts = mempty , configMonoidConnectionCount = Nothing , configMonoidHideTHLoading = Nothing , configMonoidLatestSnapshotUrl = Nothing @@ -690,7 +690,7 @@ instance Monoid ConfigMonoid where } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r - , configMonoidExecEnvOpts = configMonoidExecEnvOpts l <> configMonoidExecEnvOpts r + , configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r @@ -733,7 +733,7 @@ instance FromJSON (ConfigMonoid, [JSONWarning]) where parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) - configMonoidExecEnvOpts <- jsonSubWarnings (obj ..:? "nix-shell" ..!= mempty) + configMonoidNixOpts <- jsonSubWarnings (obj ..:? "nix-shell" ..!= mempty) configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index 51d39a645e..8527f2c005 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Nix types. @@ -14,67 +16,62 @@ import Path import Stack.Types.PackageName --- | Which ExecEnv are we using? -data ExecEnvType = NixShellExecEnv | DockerContainerExecEnv - deriving (Show, Eq) - --- | Docker configuration. -data ExecEnvOpts = ExecEnvOpts - {execEnvType :: !(Maybe ExecEnvType) - -- ^ Are we using a special execution environment? (Docker container, Nix-shell, chroot...) - ,execEnvPackages :: ![PackageName] +-- | Nix configuration. +data NixOpts = NixOpts + {nixEnable :: !Bool + ,nixPackages :: ![PackageName] -- ^ The system packages to be installed in the environment before it runs - ,execEnvInitFile :: !(Maybe String) + ,nixInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) } deriving (Show) --- | An uninterpreted representation of stack execution environment options. +-- | An uninterpreted representation of nix options. -- Configurations may be "cascaded" using mappend (left-biased). -data ExecEnvOptsMonoid = ExecEnvOptsMonoid - {execEnvMonoidDefaultEnable :: !Bool - -- ^ Should nix-shell be defaulted to enabled (does @execenv:@ section exist in the config)? - ,execEnvMonoidEnable :: !(Maybe Bool) +data NixOptsMonoid = NixOptsMonoid + {nixMonoidDefaultEnable :: !Bool + -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? + ,nixMonoidEnable :: !(Maybe Bool) -- ^ Is using nix-shell enabled? - ,execEnvMonoidPackages :: ![PackageName] + ,nixMonoidPackages :: ![PackageName] -- ^ System packages to use (given to nix-shell) - ,execEnvMonoidInitFile :: !(Maybe String) + ,nixMonoidInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) } deriving (Show) --- | Decode uninterpreted docker options from JSON/YAML. -instance FromJSON (ExecEnvOptsMonoid, [JSONWarning]) where +-- | Decode uninterpreted nix options from JSON/YAML. +instance FromJSON (NixOptsMonoid, [JSONWarning]) where parseJSON = withObjectWarnings "DockerOptsMonoid" - (\o -> do execEnvMonoidDefaultEnable <- pure True - execEnvMonoidEnable <- o ..:? execEnvEnableArgName - execEnvMonoidPackages <- o ..:? execEnvPackagesArgName ..!= [] - execEnvMonoidInitFile <- o ..:? execEnvInitFileArgName - return ExecEnvOptsMonoid{..}) + (\o -> do nixMonoidDefaultEnable <- pure True + nixMonoidEnable <- o ..:? nixEnableArgName + nixMonoidPackages <- o ..:? nixPackagesArgName ..!= [] + nixMonoidInitFile <- o ..:? nixInitFileArgName + return NixOptsMonoid{..}) --- | Left-biased combine Docker options -instance Monoid ExecEnvOptsMonoid where - mempty = ExecEnvOptsMonoid - {execEnvMonoidDefaultEnable = False - ,execEnvMonoidEnable = Nothing - ,execEnvMonoidPackages = [] - ,execEnvMonoidInitFile = Nothing +-- | Left-biased combine nix options +instance Monoid NixOptsMonoid where + mempty = NixOptsMonoid + {nixMonoidDefaultEnable = False + ,nixMonoidEnable = Nothing + ,nixMonoidPackages = [] + ,nixMonoidInitFile = Nothing } - mappend l r = ExecEnvOptsMonoid - {execEnvMonoidDefaultEnable = execEnvMonoidDefaultEnable l || execEnvMonoidDefaultEnable r - ,execEnvMonoidEnable = execEnvMonoidEnable l <|> execEnvMonoidEnable r - ,execEnvMonoidPackages = execEnvMonoidPackages l <> execEnvMonoidPackages r - ,execEnvMonoidInitFile = execEnvMonoidInitFile l <|> execEnvMonoidInitFile r + mappend l r = NixOptsMonoid + {nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r + ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r + ,nixMonoidPackages = nixMonoidPackages l <> nixMonoidPackages r + ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r } --- | ExecEnv enable argument name. -execEnvEnableArgName :: Text -execEnvEnableArgName = "enable" +-- | Nix enable argument name. +nixEnableArgName :: Text +nixEnableArgName = "enable" --- | ExecEnv system packages argument name. -execEnvPackagesArgName :: Text -execEnvPackagesArgName = "packages" +-- | Nix system packages argument name. +nixPackagesArgName :: Text +nixPackagesArgName = "packages" --- | ExecEnv init env file path argument name. -execEnvInitFileArgName :: Text -execEnvInitFileArgName = "init-env-file" +-- | Nix init env file path argument name. +nixInitFileArgName :: Text +nixInitFileArgName = "init-env-file" diff --git a/src/main/Main.hs b/src/main/Main.hs index de07fd70cd..67b44f113b 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -754,21 +754,21 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do runStackTGlobal manager bconfig go (setupEnv Nothing) - runStackTGlobal - manager - envConfig - go - (inner' lk) + runStackTGlobal manager bconfig go $ + Nix.reexecWithOptionalShell + (lcProjectRoot lc) + (runStackTGlobal + manager + envConfig + go + (inner' lk)) - reexecFn <- case execEnvType (configExecEnv (lcConfig lc)) of - Just NixShellExecEnv -> do - -- for now we bypass docker if nix-shell is on - resolver <- bcResolver <$> (runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc globalResolver) - return $ Nix.reexecWithShell resolver - _ -> return Docker.reexecWithOptionalContainer runStackTGlobal manager (lcConfig lc) go $ - reexecFn (lcProjectRoot lc) mbefore (inner'' lk0) mafter + Docker.reexecWithOptionalContainer + (lcProjectRoot lc) + mbefore + (inner'' lk0) + mafter (Just $ liftIO $ do lk' <- readIORef curLk munlockFile lk') @@ -877,10 +877,17 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do Docker.execWithOptionalContainer (lcProjectRoot lc) (\_ _ -> return (cmd, args, [], [])) - -- Unlock before transferring control away, whether using docker or not: + -- Unlock before transferring control away, whether using + -- docker or not: (Just $ munlockFile lk) - (runStackTGlobal manager (lcConfig lc) go $ do - exec plainEnvSettings cmd args) + (do bconfig <- runStackLoggingTGlobal manager go $ + lcLoadBuildConfig lc globalResolver + runStackTGlobal manager bconfig go $ do + Nix.execWithOptionalShell + (lcProjectRoot lc) + (return (cmd, args)) + (runStackTGlobal manager (lcConfig lc) go $ + exec plainEnvSettings cmd args)) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> From e33a65bbae462f4566b2d54f9c9eb152834083c7 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 17:57:59 +0100 Subject: [PATCH 14/56] Remove redundant imports and arguments. --- src/Stack/Config.hs | 2 +- src/Stack/Config/Nix.hs | 12 ++---------- src/Stack/Nix.hs | 17 ++++++----------- src/Stack/Types/Nix.hs | 3 --- src/main/Main.hs | 2 -- 5 files changed, 9 insertions(+), 27 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index db49723755..d9a4d3d24c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -144,7 +144,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts - configNix <- nixOptsFromMonoid mproject configStackRoot configMonoidNixOpts + configNix <- nixOptsFromMonoid configStackRoot configMonoidNixOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index e9c2c534ca..2cd969aa75 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -3,21 +3,13 @@ -- | Nix configuration module Stack.Config.Nix where -import Control.Exception.Lifted -import Control.Monad -import Control.Monad.Catch (throwM, MonadThrow) -import Data.List (find) import Data.Maybe -import qualified Data.Text as T -import Data.Typeable (Typeable) import Path import Stack.Types -- | Interprets DockerOptsMonoid options. -nixOptsFromMonoid - :: MonadThrow m - => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts -nixOptsFromMonoid mproject stackRoot NixOptsMonoid{..} = do +nixOptsFromMonoid :: Monad m => Path Abs Dir -> NixOptsMonoid -> m NixOpts +nixOptsFromMonoid _stackRoot NixOptsMonoid{..} = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable nixPackages = nixMonoidPackages nixInitFile = nixMonoidInitFile diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 5648f5ef21..e9e8a6755a 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -23,7 +23,6 @@ import Data.Maybe import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Version (showVersion) import Network.HTTP.Client.Conduit (HasHttpManager) -import Path import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings import Stack.Constants (stackProgName) @@ -46,11 +45,10 @@ import System.Process (CreateProcess(delegate_ctlc)) -- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalShell :: M env m - => Maybe (Path Abs Dir) - -> IO () + => IO () -> m () -reexecWithOptionalShell mprojectRoot = - execWithOptionalShell mprojectRoot getCmdArgs +reexecWithOptionalShell = + execWithOptionalShell getCmdArgs where getCmdArgs = do args <- @@ -66,11 +64,10 @@ reexecWithOptionalShell mprojectRoot = -- This takes an optional release action just like `reexecWithOptionalShell`. execWithOptionalShell :: M env m - => Maybe (Path Abs Dir) - -> m (FilePath,[String]) + => m (FilePath,[String]) -> IO () -> m () -execWithOptionalShell mprojectRoot getCmdArgs inner = +execWithOptionalShell getCmdArgs inner = do config <- asks getConfig inShell <- getInShell isReExec <- asks getReExec @@ -85,13 +82,11 @@ execWithOptionalShell mprojectRoot getCmdArgs inner = | otherwise -> do runShellAndExit getCmdArgs - mprojectRoot runShellAndExit :: M env m => m (String, [String]) - -> Maybe (Path Abs Dir) -> m () -runShellAndExit getCmdArgs mprojectRoot = do +runShellAndExit getCmdArgs = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- getCmdArgs diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index 8527f2c005..dbb171f024 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -7,12 +7,9 @@ module Stack.Types.Nix where import Control.Applicative -import Control.Monad -import Control.Monad.Catch (MonadThrow) import Data.Aeson.Extended import Data.Monoid import Data.Text (Text) -import Path import Stack.Types.PackageName diff --git a/src/main/Main.hs b/src/main/Main.hs index 67b44f113b..8e77147f4c 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -756,7 +756,6 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do (setupEnv Nothing) runStackTGlobal manager bconfig go $ Nix.reexecWithOptionalShell - (lcProjectRoot lc) (runStackTGlobal manager envConfig @@ -884,7 +883,6 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do lcLoadBuildConfig lc globalResolver runStackTGlobal manager bconfig go $ do Nix.execWithOptionalShell - (lcProjectRoot lc) (return (cmd, args)) (runStackTGlobal manager (lcConfig lc) go $ exec plainEnvSettings cmd args)) From 68480b38a7b4fd704e055c672c1a804609ffeccc Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 18:05:54 +0100 Subject: [PATCH 15/56] Nix: delegate ctrlc if in terminal. --- src/Stack/Nix.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index e9e8a6755a..c6a5576304 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -31,6 +31,7 @@ import Stack.Types import Stack.Types.Internal import System.Environment (lookupEnv,getArgs,getExecutablePath) import System.Exit (exitSuccess, exitWith) +import System.IO (stderr,stdin,hIsTerminalDevice) import System.Process.Read import System.Process.Run import System.Process (CreateProcess(delegate_ctlc)) @@ -91,7 +92,12 @@ runShellAndExit getCmdArgs = do envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- getCmdArgs resolver <- bcResolver <$> asks getBuildConfig - let ghcInNix = case resolver of + isStdoutTerminal <- asks getTerminal + (isStdinTerminal,isStderrTerminal) <- + liftIO ((,) <$> hIsTerminalDevice stdin + <*> hIsTerminalDevice stderr) + let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal + ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" @@ -105,7 +111,7 @@ runShellAndExit getCmdArgs = do liftIO $ putStrLn $ "Using a nix-shell environment with nix packages: " ++ (concat $ intersperse ", " nixpkgs) e <- try (callProcess' - (\cp -> cp { delegate_ctlc = False }) + (if isTerm then id else \cp -> cp { delegate_ctlc = False }) Nothing envOverride "nix-shell" From dd5ee9c51617e3bab1a133257295a0080c3df33f Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 18:16:04 +0100 Subject: [PATCH 16/56] twiddle: intercalate rather than concat . intersperse. --- src/Stack/Nix.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index c6a5576304..99c6513cd3 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -18,7 +18,7 @@ import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader,asks) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Char (toUpper) -import Data.List (intersperse) +import Data.List (intercalate) import Data.Maybe import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Version (showVersion) @@ -102,14 +102,15 @@ runShellAndExit getCmdArgs = do "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" nixpkgs = [ghcInNix] ++ (map show (nixPackages (configNix config))) - fullArgs = (concat [["--pure", "-p"] - ,nixpkgs - ,["--command"] - ,[(concat $ intersperse " " - ("export":(inContainerEnvVar++"=1"):";":cmnd:args))] - ]) - liftIO $ putStrLn $ "Using a nix-shell environment with nix packages: " ++ - (concat $ intersperse ", " nixpkgs) + fullArgs = concat [["--pure", "-p"] + ,nixpkgs + ,["--command"] + ,[intercalate " " + ("export":(inContainerEnvVar++"=1"):";":cmnd:args)] + ] + liftIO $ putStrLn $ + "Using a nix-shell environment with nix packages: " ++ + (intercalate ", " nixpkgs) e <- try (callProcess' (if isTerm then id else \cp -> cp { delegate_ctlc = False }) Nothing From 95c24b8cd2d649293577a94af41c5725e1093a54 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 18:16:42 +0100 Subject: [PATCH 17/56] Use $logDebug. --- src/Stack/Nix.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 99c6513cd3..bf19b9f9ab 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} -- | Run commands in a nix-shell module Stack.Nix @@ -14,13 +15,14 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (throwM,MonadCatch,MonadMask) import Control.Monad.IO.Class (MonadIO,liftIO) -import Control.Monad.Logger (MonadLogger) +import Control.Monad.Logger (MonadLogger,logDebug) import Control.Monad.Reader (MonadReader,asks) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Char (toUpper) import Data.List (intercalate) import Data.Maybe import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) +import qualified Data.Text as T import Data.Version (showVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import qualified Paths_stack as Meta @@ -108,7 +110,7 @@ runShellAndExit getCmdArgs = do ,[intercalate " " ("export":(inContainerEnvVar++"=1"):";":cmnd:args)] ] - liftIO $ putStrLn $ + $logDebug $ T.pack $ "Using a nix-shell environment with nix packages: " ++ (intercalate ", " nixpkgs) e <- try (callProcess' From a2930f91ef7d374733e0922f27dac20c7c10f6b7 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Sun, 25 Oct 2015 18:37:16 +0100 Subject: [PATCH 18/56] Remove redundant extra-dep. --- stack.cabal | 1 - stack.yaml | 1 - 2 files changed, 2 deletions(-) diff --git a/stack.cabal b/stack.cabal index 29a87d2234..c9e4b21b30 100644 --- a/stack.cabal +++ b/stack.cabal @@ -161,7 +161,6 @@ library , http-conduit >= 2.1.7 , http-types >= 0.8.6 , lifted-base - , language-nix >= 2.0 , monad-control , monad-logger >= 0.3.13.1 , monad-loops >= 0.4.2.1 diff --git a/stack.yaml b/stack.yaml index 0474f0b2cc..a75523da6e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,6 @@ resolver: lts-3.7 extra-deps: - binary-tagged-0.1.1.0 -- language-nix-2.1 image: container: base: "fpco/ubuntu-with-libgmp:14.04" From 292bd3dce8ec7822ba1b819fb749e2580186cd69 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 12:02:25 +0100 Subject: [PATCH 19/56] Nix options (--nix & --no-nix) and help added to command line --- src/Stack/Nix.hs | 5 +++++ src/Stack/Options.hs | 23 +++++++++++++++++++++-- src/main/Main.hs | 7 ++++++- 3 files changed, 32 insertions(+), 3 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index bf19b9f9ab..8e2fcdc548 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -8,6 +8,7 @@ module Stack.Nix (execWithOptionalShell ,reexecWithOptionalShell ,reExecArgName + ,nixCmdName ) where import Control.Applicative @@ -131,6 +132,10 @@ getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) inContainerEnvVar :: String inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] +-- | Command-line argument for "docker" +nixCmdName :: String +nixCmdName = "nix" + -- | Command-line option for @--internal-re-exec@. reExecArgName :: String reExecArgName = "internal-re-exec-version" diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 08abd5a295..870e5ce333 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -14,6 +14,7 @@ module Stack.Options ,globalOptsParser ,initOptsParser ,newOptsParser + ,nixOptsParser ,logLevelOptsParser ,ghciOptsParser ,solverOptsParser @@ -50,6 +51,7 @@ import Stack.Dot import Stack.Ghci (GhciOpts(..)) import Stack.Init import Stack.New +import Stack.Nix import Stack.Types import Stack.Types.TemplateName @@ -221,8 +223,9 @@ readFlag = do -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Bool -> Parser ConfigMonoid configOptsParser isSub docker = - (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty - { configMonoidDockerOpts = opts + (\dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty + { configMonoidDockerOpts = dockerOpts + , configMonoidNixOpts = nixOpts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC , configMonoidSkipGHCCheck = skipGHCCheck @@ -237,6 +240,7 @@ configOptsParser isSub docker = , configMonoidModifyCodePage = modifyCodePage }) <$> dockerOptsParser (not isSub && docker) + <*> nixOptsParser docker -- Don't show nix opts when docker opts aren't shown <*> maybeBoolFlags "system-ghc" "using the system installed GHC (on the PATH) if available and a matching version" @@ -297,6 +301,21 @@ configOptsParser isSub docker = hide where hide = hideMods isSub +nixOptsParser :: Bool -> Parser NixOptsMonoid +nixOptsParser showOptions = + NixOptsMonoid + <$> pure False + <*> maybeBoolFlags nixCmdName + "using a Nix-shell" + hide + <*> pure [] + <*> pure Nothing + where + hide = if showOptions + then idm + else internal <> hidden + + -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid dockerOptsParser showOptions = diff --git a/src/main/Main.hs b/src/main/Main.hs index 8e77147f4c..22eaa64ff4 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -113,6 +113,10 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do dockerHelpOptName (dockerOptsParser True) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") + execExtraHelp args + nixHelpOptName + (nixOptsParser True) + ("Only showing --" ++ Nix.nixCmdName ++ "* options.") let commitCount = $gitCommitCount versionString' = concat $ concat [ [$(simpleVersion Meta.version)] @@ -407,6 +411,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do exitFailure where dockerHelpOptName = Docker.dockerCmdName ++ "-help" + nixHelpOptName = Nix.nixCmdName ++ "-help" cmdFooter = "Run 'stack --help' for global options that apply to all subcommands." -- | Print out useful path information in a human-readable format (and @@ -880,7 +885,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do -- docker or not: (Just $ munlockFile lk) (do bconfig <- runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc globalResolver + lcLoadBuildConfig lc globalResolver globalCompiler runStackTGlobal manager bconfig go $ do Nix.execWithOptionalShell (return (cmd, args)) From 086e9d3da4c7c84f93a89871fddc464e12d0a7d2 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 12:37:14 +0100 Subject: [PATCH 20/56] Added --nix-shell-options to be passed to nix-shell --- src/Stack/Config/Nix.hs | 1 + src/Stack/Nix.hs | 1 + src/Stack/Options.hs | 3 +++ src/Stack/Types/Nix.hs | 10 ++++++++++ 4 files changed, 15 insertions(+) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 2cd969aa75..2f5221c0fe 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -13,4 +13,5 @@ nixOptsFromMonoid _stackRoot NixOptsMonoid{..} = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable nixPackages = nixMonoidPackages nixInitFile = nixMonoidInitFile + nixShellOptions = nixMonoidShellOptions return NixOpts{..} diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 8e2fcdc548..4c891f21f7 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -107,6 +107,7 @@ runShellAndExit getCmdArgs = do nixpkgs = [ghcInNix] ++ (map show (nixPackages (configNix config))) fullArgs = concat [["--pure", "-p"] ,nixpkgs + ,map T.unpack (nixShellOptions (configNix config)) ,["--command"] ,[intercalate " " ("export":(inContainerEnvVar++"=1"):";":cmnd:args)] diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 870e5ce333..b000b2763c 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -310,6 +310,9 @@ nixOptsParser showOptions = hide <*> pure [] <*> pure Nothing + <*> many (textOption (long "nix-shell-options" <> + metavar "OPTION" <> + help "Additional options passed to nix-shell")) where hide = if showOptions then idm diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index dbb171f024..b03dba7895 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -20,6 +20,8 @@ data NixOpts = NixOpts -- ^ The system packages to be installed in the environment before it runs ,nixInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) + ,nixShellOptions :: ![Text] + -- ^ Options to be given to the nix-shell command line } deriving (Show) @@ -34,6 +36,8 @@ data NixOptsMonoid = NixOptsMonoid -- ^ System packages to use (given to nix-shell) ,nixMonoidInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) + ,nixMonoidShellOptions :: ![Text] + -- ^ Options to be given to the nix-shell command line } deriving (Show) @@ -44,6 +48,7 @@ instance FromJSON (NixOptsMonoid, [JSONWarning]) where nixMonoidEnable <- o ..:? nixEnableArgName nixMonoidPackages <- o ..:? nixPackagesArgName ..!= [] nixMonoidInitFile <- o ..:? nixInitFileArgName + nixMonoidShellOptions <- o ..:? nixShellOptsArgName ..!= [] return NixOptsMonoid{..}) -- | Left-biased combine nix options @@ -53,12 +58,14 @@ instance Monoid NixOptsMonoid where ,nixMonoidEnable = Nothing ,nixMonoidPackages = [] ,nixMonoidInitFile = Nothing + ,nixMonoidShellOptions = [] } mappend l r = NixOptsMonoid {nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r ,nixMonoidPackages = nixMonoidPackages l <> nixMonoidPackages r ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r + ,nixMonoidShellOptions = nixMonoidShellOptions l <> nixMonoidShellOptions r } -- | Nix enable argument name. @@ -72,3 +79,6 @@ nixPackagesArgName = "packages" -- | Nix init env file path argument name. nixInitFileArgName :: Text nixInitFileArgName = "init-env-file" + +nixShellOptsArgName :: Text +nixShellOptsArgName = "nix-shell-options" From 68ef716cadb483d24bf922ac0755189b37abe9d3 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 12:49:57 +0100 Subject: [PATCH 21/56] --nix* option group showing in stack --help output --- src/Stack/Options.hs | 3 ++- src/main/Main.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index b000b2763c..af566a0a6e 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -312,7 +312,8 @@ nixOptsParser showOptions = <*> pure Nothing <*> many (textOption (long "nix-shell-options" <> metavar "OPTION" <> - help "Additional options passed to nix-shell")) + help "Additional options passed to nix-shell" <> + hide)) where hide = if showOptions then idm diff --git a/src/main/Main.hs b/src/main/Main.hs index 22eaa64ff4..ae293963a0 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -134,6 +134,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do "stack - The Haskell Tool Stack" "" (\isSub -> extraHelpOption isSub progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> + extraHelpOption isSub progName (Nix.nixCmdName ++ "*") nixHelpOptName <*> globalOptsParser isSub) (do addCommand "build" "Build the package(s) in this directory/configuration" From 210772b90246035601596e663dbef33b69ba1f54 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 15:23:28 +0100 Subject: [PATCH 22/56] Nix can read a premade shell.nix file --- src/Stack/Nix.hs | 19 ++++++++++++------- src/Stack/Types/Nix.hs | 2 +- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 4c891f21f7..5e6abb35c2 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -100,21 +100,26 @@ runShellAndExit getCmdArgs = do liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal + mshellFile = nixInitFile (configNix config) ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" nixpkgs = [ghcInNix] ++ (map show (nixPackages (configNix config))) - fullArgs = concat [["--pure", "-p"] - ,nixpkgs + packagesOrFile = case mshellFile of + Just filePath -> [filePath] + Nothing -> "-p" : nixpkgs + fullArgs = concat [["--pure"] + ,packagesOrFile ,map T.unpack (nixShellOptions (configNix config)) ,["--command"] ,[intercalate " " - ("export":(inContainerEnvVar++"=1"):";":cmnd:args)] + ("export":(inShellEnvVar ++ "=1"):";":cmnd:args)] ] $logDebug $ T.pack $ - "Using a nix-shell environment with nix packages: " ++ - (intercalate ", " nixpkgs) + "Using a nix-shell environment " ++ (case mshellFile of + Just filePath -> "from file: " ++ filePath + Nothing -> "with nix packages: " ++ (intercalate ", " nixpkgs)) e <- try (callProcess' (if isTerm then id else \cp -> cp { delegate_ctlc = False }) Nothing @@ -130,8 +135,8 @@ getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) -- | Environment variable used to indicate stack is running in container. -inContainerEnvVar :: String -inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] +inShellEnvVar :: String +inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"] -- | Command-line argument for "docker" nixCmdName :: String diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index b03dba7895..420b2785a3 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -78,7 +78,7 @@ nixPackagesArgName = "packages" -- | Nix init env file path argument name. nixInitFileArgName :: Text -nixInitFileArgName = "init-env-file" +nixInitFileArgName = "shell-file" nixShellOptsArgName :: Text nixShellOptsArgName = "nix-shell-options" From 2554209addf7bb592941c58420338f63ad0c8840 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 15:36:49 +0100 Subject: [PATCH 23/56] Throwing an exception when trying to use shell file and packages at the same time --- src/Stack/Nix.hs | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 5e6abb35c2..2d173b34e6 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -9,6 +9,7 @@ module Stack.Nix ,reexecWithOptionalShell ,reExecArgName ,nixCmdName + ,StackNixException(..) ) where import Control.Applicative @@ -24,6 +25,7 @@ import Data.List (intercalate) import Data.Maybe import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import qualified Data.Text as T +import Data.Typeable import Data.Version (showVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import qualified Paths_stack as Meta @@ -99,13 +101,17 @@ runShellAndExit getCmdArgs = do (isStdinTerminal,isStderrTerminal) <- liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) + let mshellFile = nixInitFile (configNix config) + pkgsInConfig = map show (nixPackages (configNix config)) + if not (null pkgsInConfig) && isJust mshellFile then + throwM NixCannotUseShellFileAndPackagesException + else return () let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal - mshellFile = nixInitFile (configNix config) ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" - nixpkgs = [ghcInNix] ++ (map show (nixPackages (configNix config))) + nixpkgs = ghcInNix : pkgsInConfig packagesOrFile = case mshellFile of Just filePath -> [filePath] Nothing -> "-p" : nixpkgs @@ -132,7 +138,7 @@ runShellAndExit getCmdArgs = do -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool -getInShell = liftIO (isJust <$> lookupEnv inContainerEnvVar) +getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) -- | Environment variable used to indicate stack is running in container. inShellEnvVar :: String @@ -158,3 +164,15 @@ type M env m = ,HasHttpManager env ,MonadMask m ) + +-- Exceptions thown specifically by Stack.Nix +data StackNixException + = NixCannotUseShellFileAndPackagesException + -- ^ Nix can't be given packages and a shell file at the same time + deriving (Typeable) + +instance Exception StackNixException + +instance Show StackNixException where + show NixCannotUseShellFileAndPackagesException = + "You cannot have packages and a shell-file filled at the same time in your nix-shell configuration." From b4689a4c746389cc2a21f373d7f8ef5d2ae7d30a Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 15:43:03 +0100 Subject: [PATCH 24/56] Sharing reExecArgName with Docker config --- src/Stack/Nix.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 2d173b34e6..75f32a66db 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -7,7 +7,6 @@ module Stack.Nix (execWithOptionalShell ,reexecWithOptionalShell - ,reExecArgName ,nixCmdName ,StackNixException(..) ) where @@ -31,7 +30,7 @@ import Network.HTTP.Client.Conduit (HasHttpManager) import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings import Stack.Constants (stackProgName) -import Stack.Docker (StackDockerException(OnlyOnHostException)) +import Stack.Docker (StackDockerException(OnlyOnHostException), reExecArgName) import Stack.Types import Stack.Types.Internal import System.Environment (lookupEnv,getArgs,getExecutablePath) @@ -148,10 +147,6 @@ inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"] nixCmdName :: String nixCmdName = "nix" --- | Command-line option for @--internal-re-exec@. -reExecArgName :: String -reExecArgName = "internal-re-exec-version" - type M env m = (MonadIO m ,MonadReader env m From f25fcadbdc7aaf078f13ae6e78d220b2461fcd07 Mon Sep 17 00:00:00 2001 From: YPares Date: Mon, 26 Oct 2015 18:00:35 +0100 Subject: [PATCH 25/56] Fixing a comment --- src/Stack/Nix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 75f32a66db..a5bbee02b1 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -143,7 +143,7 @@ getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) inShellEnvVar :: String inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"] --- | Command-line argument for "docker" +-- | Command-line argument for "nix" nixCmdName :: String nixCmdName = "nix" From c44aaf932fca74a75aba893e09d55200dc46d315 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 28 Oct 2015 12:10:53 +0100 Subject: [PATCH 26/56] When nix enabled, stack setup downloads ghc and system deps through nix and reports the use of nix-provided GHC --- src/main/Main.hs | 80 +++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 38 deletions(-) diff --git a/src/main/Main.hs b/src/main/Main.hs index ae293963a0..69b587fd65 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -605,44 +605,48 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do Docker.reexecWithOptionalContainer (lcProjectRoot lc) Nothing - (runStackLoggingTGlobal manager go $ do - (wantedCompiler, compilerCheck, mstack) <- - case scoCompilerVersion of - Just v -> return (v, MatchMinor, Nothing) - Nothing -> do - bc <- lcLoadBuildConfig lc globalResolver globalCompiler - return ( bcWantedCompiler bc - , configCompilerCheck (lcConfig lc) - , Just $ bcStackYaml bc - ) - miniConfig <- loadMiniConfig (lcConfig lc) - mpaths <- runStackTGlobal manager miniConfig go $ - ensureCompiler SetupOpts - { soptsInstallIfMissing = True - , soptsUseSystem = - (configSystemGHC $ lcConfig lc) - && not scoForceReinstall - , soptsWantedCompiler = wantedCompiler - , soptsCompilerCheck = compilerCheck - , soptsStackYaml = mstack - , soptsForceReinstall = scoForceReinstall - , soptsSanityCheck = True - , soptsSkipGhcCheck = False - , soptsSkipMsys = configSkipMsys $ lcConfig lc - , soptsUpgradeCabal = scoUpgradeCabal - , soptsResolveMissingGHC = Nothing - , soptsStackSetupYaml = scoStackSetupYaml - , soptsGHCBindistURL = scoGHCBindistURL - } - let compiler = case wantedCompiler of - GhcVersion _ -> "GHC" - GhcjsVersion {} -> "GHCJS" - case mpaths of - Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH" - Just _ -> $logInfo $ "stack will use a locally installed " <> compiler - $logInfo "For more information on paths, see 'stack path' and 'stack exec env'" - $logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:" - $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" + (do bconfig <- runStackLoggingTGlobal manager go $ + lcLoadBuildConfig lc globalResolver globalCompiler + runStackTGlobal manager bconfig go $ + Nix.reexecWithOptionalShell $ + runStackLoggingTGlobal manager go $ do + (wantedCompiler, compilerCheck, mstack) <- + case scoCompilerVersion of + Just v -> return (v, MatchMinor, Nothing) + Nothing -> do + bc <- lcLoadBuildConfig lc globalResolver globalCompiler + return ( bcWantedCompiler bc + , configCompilerCheck (lcConfig lc) + , Just $ bcStackYaml bc + ) + miniConfig <- loadMiniConfig (lcConfig lc) + mpaths <- runStackTGlobal manager miniConfig go $ + ensureCompiler SetupOpts + { soptsInstallIfMissing = True + , soptsUseSystem = + (configSystemGHC $ lcConfig lc) + && not scoForceReinstall + , soptsWantedCompiler = wantedCompiler + , soptsCompilerCheck = compilerCheck + , soptsStackYaml = mstack + , soptsForceReinstall = scoForceReinstall + , soptsSanityCheck = True + , soptsSkipGhcCheck = False + , soptsSkipMsys = configSkipMsys $ lcConfig lc + , soptsUpgradeCabal = scoUpgradeCabal + , soptsResolveMissingGHC = Nothing + , soptsStackSetupYaml = scoStackSetupYaml + , soptsGHCBindistURL = scoGHCBindistURL + } + let compiler = case wantedCompiler of + GhcVersion _ -> "GHC" + GhcjsVersion {} -> "GHCJS" + case mpaths of + Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH" + Just _ -> $logInfo $ "stack will use a locally installed " <> compiler + $logInfo "For more information on paths, see 'stack path' and 'stack exec env'" + $logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:" + $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" ) Nothing (Just $ munlockFile lk) From a2c417c90fb50ab62f1be667394e8c157fb070b7 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 28 Oct 2015 12:21:48 +0100 Subject: [PATCH 27/56] Added some tests for nix-shell configuration --- src/test/Stack/NixShellSpec.hs | 65 ++++++++++++++++++++++++++++++++++ stack.cabal | 1 + 2 files changed, 66 insertions(+) create mode 100644 src/test/Stack/NixShellSpec.hs diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs new file mode 100644 index 0000000000..26ccba9bd3 --- /dev/null +++ b/src/test/Stack/NixShellSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Stack.NixShellSpec where + +import Test.Hspec + +import Control.Monad.Logger +import Control.Exception +import Network.HTTP.Conduit (Manager) +import System.Environment +import Path +import System.Directory +import System.IO.Temp (withSystemTempDirectory) + +import Stack.Config +import Stack.Types.PackageName +import Stack.Types.Config +import Stack.Types.StackT +import Stack.Types.Nix + +sampleConfig :: String +sampleConfig = + "resolver: lts-2.10\n" ++ + "packages: ['.']\n" ++ + "nix-shell:\n" ++ + " enable: True\n" ++ + " packages: [glpk]" + +stackDotYaml :: Path Rel File +stackDotYaml = $(mkRelFile "stack.yaml") + +data T = T + { manager :: Manager + } + +setup :: IO T +setup = do + manager <- newTLSManager + unsetEnv "STACK_YAML" + return T{..} + +teardown :: T -> IO () +teardown _ = return () + +spec :: Spec +spec = beforeAll setup $ afterAll teardown $ do + let loadConfig' m = runStackLoggingT m LevelDebug False False (loadConfig mempty Nothing) + inTempDir action = do + currentDirectory <- getCurrentDirectory + withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do + let enterDir = setCurrentDirectory tempDir + exitDir = setCurrentDirectory currentDirectory + bracket_ enterDir exitDir action + describe "nix-shell" $ do + it "sees that nix-shell is enabled" $ \T{..} -> inTempDir $ do + writeFile (toFilePath stackDotYaml) sampleConfig + lc <- loadConfig' manager + (nixEnable $ configNix $ lcConfig lc) `shouldBe` True + it "sees that the only package asked for is glpk" $ \T{..} -> inTempDir $ do + writeFile (toFilePath stackDotYaml) sampleConfig + lc <- loadConfig' manager + pn <- parsePackageNameFromString "glpk" + (nixPackages $ configNix $ lcConfig lc) `shouldBe` [pn] + diff --git a/stack.cabal b/stack.cabal index c9e4b21b30..ace7596c4e 100644 --- a/stack.cabal +++ b/stack.cabal @@ -258,6 +258,7 @@ test-suite stack-test , Stack.DotSpec , Stack.PackageDumpSpec , Stack.ArgsSpec + , Stack.NixShellSpec , Network.HTTP.Download.VerifiedSpec ghc-options: -Wall -threaded build-depends: base >=4.7 && <5 From b0213f928cdc253486d724c850b1b3e7e2bfdd1f Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 28 Oct 2015 17:55:08 +0100 Subject: [PATCH 28/56] Using Strings instead of PackageName for nix packages Using PackageNames forbid to use '.' in names, which is required when you use attributes --- src/Stack/Nix.hs | 2 +- src/Stack/Types/Nix.hs | 6 ++---- src/test/Stack/NixShellSpec.hs | 4 +--- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index a5bbee02b1..bb8cb9ff61 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -101,7 +101,7 @@ runShellAndExit getCmdArgs = do liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) let mshellFile = nixInitFile (configNix config) - pkgsInConfig = map show (nixPackages (configNix config)) + pkgsInConfig = nixPackages (configNix config) if not (null pkgsInConfig) && isJust mshellFile then throwM NixCannotUseShellFileAndPackagesException else return () diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index 420b2785a3..bbe4fa6236 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -11,12 +11,10 @@ import Data.Aeson.Extended import Data.Monoid import Data.Text (Text) -import Stack.Types.PackageName - -- | Nix configuration. data NixOpts = NixOpts {nixEnable :: !Bool - ,nixPackages :: ![PackageName] + ,nixPackages :: ![String] -- ^ The system packages to be installed in the environment before it runs ,nixInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) @@ -32,7 +30,7 @@ data NixOptsMonoid = NixOptsMonoid -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? ,nixMonoidEnable :: !(Maybe Bool) -- ^ Is using nix-shell enabled? - ,nixMonoidPackages :: ![PackageName] + ,nixMonoidPackages :: ![String] -- ^ System packages to use (given to nix-shell) ,nixMonoidInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs index 26ccba9bd3..50dd21abf2 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixShellSpec.hs @@ -14,7 +14,6 @@ import System.Directory import System.IO.Temp (withSystemTempDirectory) import Stack.Config -import Stack.Types.PackageName import Stack.Types.Config import Stack.Types.StackT import Stack.Types.Nix @@ -60,6 +59,5 @@ spec = beforeAll setup $ afterAll teardown $ do it "sees that the only package asked for is glpk" $ \T{..} -> inTempDir $ do writeFile (toFilePath stackDotYaml) sampleConfig lc <- loadConfig' manager - pn <- parsePackageNameFromString "glpk" - (nixPackages $ configNix $ lcConfig lc) `shouldBe` [pn] + (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"] From 5ef1584ac7d632d1f6afb5b2fb9c7331323cfe47 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 28 Oct 2015 19:28:20 +0100 Subject: [PATCH 29/56] Trying to fix the LD_LIBRARY_PATH problem --- src/Stack/Nix.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index bb8cb9ff61..3e27293a11 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -110,7 +110,7 @@ runShellAndExit getCmdArgs = do ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" - nixpkgs = ghcInNix : pkgsInConfig + nixpkgs = ghcInNix : "gnused" : "coreutils" : pkgsInConfig packagesOrFile = case mshellFile of Just filePath -> [filePath] Nothing -> "-p" : nixpkgs @@ -119,7 +119,7 @@ runShellAndExit getCmdArgs = do ,map T.unpack (nixShellOptions (configNix config)) ,["--command"] ,[intercalate " " - ("export":(inShellEnvVar ++ "=1"):";":cmnd:args)] + ("export":(inShellEnvVar ++ "=1"):";":exportLDPath:";":cmnd:args)] ] $logDebug $ T.pack $ "Using a nix-shell environment " ++ (case mshellFile of @@ -135,6 +135,8 @@ runShellAndExit getCmdArgs = do Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) Right () -> liftIO exitSuccess +exportLDPath = "export LD_LIBRARY_PATH=`echo -n $NIX_LDFLAGS | tr ' ' $'\n' | sed -n '/-L/{s/-L//; p}' | tr $'\n' ':'`" + -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) From c3233eceab04f497cc7dadc0868181c48f9b9b10 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 4 Nov 2015 13:53:37 +0100 Subject: [PATCH 30/56] Added default dep to glibcLocales when lauching nix-shell --- src/Stack/Nix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 3e27293a11..a64d429609 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -110,7 +110,7 @@ runShellAndExit getCmdArgs = do ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" - nixpkgs = ghcInNix : "gnused" : "coreutils" : pkgsInConfig + nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig packagesOrFile = case mshellFile of Just filePath -> [filePath] Nothing -> "-p" : nixpkgs From 8913e6601234d76cd7321cf8cf284b8585e4c6c6 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 4 Nov 2015 16:32:31 +0100 Subject: [PATCH 31/56] Added a comment about the LD_LIBRARY_PATH hack --- src/Stack/Nix.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index a64d429609..46a9596095 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -111,6 +111,8 @@ runShellAndExit getCmdArgs = do "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig + -- gnused and coreutils (for tr) are necessary for the hack exposed in the doc for 'exportLDPath'. + -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. packagesOrFile = case mshellFile of Just filePath -> [filePath] Nothing -> "-p" : nixpkgs @@ -135,6 +137,11 @@ runShellAndExit getCmdArgs = do Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) Right () -> liftIO exitSuccess +-- | This is a hack! +-- Nix currently doesn't expose the paths of the shared libraries provided +-- by the demanded packages in a manner that is suitable to GHC. +-- Therefore, in the Nix-shell, we retrieve in the NIX_LDFLAGS env var those paths and set LD_LIBRARY_PATH before the build happens. +exportLDPath :: String exportLDPath = "export LD_LIBRARY_PATH=`echo -n $NIX_LDFLAGS | tr ' ' $'\n' | sed -n '/-L/{s/-L//; p}' | tr $'\n' ':'`" -- | 'True' if we are currently running inside a Nix. From 6a51e454397308202addc09cd62249586c2951be Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 4 Nov 2015 16:52:52 +0100 Subject: [PATCH 32/56] Following the convention RE option names --- src/Stack/Types/Config.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 278cd91872..db330755bd 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -733,7 +733,7 @@ instance FromJSON (ConfigMonoid, [JSONWarning]) where parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) - configMonoidNixOpts <- jsonSubWarnings (obj ..:? "nix-shell" ..!= mempty) + configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixShellOptsName ..!= mempty) configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName @@ -813,6 +813,9 @@ parseConfigMonoidJSON obj = do configMonoidDockerOptsName :: Text configMonoidDockerOptsName = "docker" +configMonoidNixShellOptsName :: Text +configMonoidNixShellOptsName = "nix-shell" + configMonoidConnectionCountName :: Text configMonoidConnectionCountName = "connection-count" From 83d87796c50dc1516d26e910c62f701509ac681c Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 4 Nov 2015 17:18:00 +0100 Subject: [PATCH 33/56] Added DeriveDataTypeable for Nix exception type derivation --- src/Stack/Nix.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 46a9596095..50ce2791ad 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Run commands in a nix-shell module Stack.Nix From fa2991ddc195f4c7634e756630b420400197407a Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 6 Nov 2015 18:17:37 +0100 Subject: [PATCH 34/56] Passing libs and includes zith --extra-*-dirs to stack: beginning --- src/Stack/Nix.hs | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 50ce2791ad..e7af413492 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -111,19 +111,33 @@ runShellAndExit getCmdArgs = do ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc" - nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig + --nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig + nixpkgs = "glibcLocales" : pkgsInConfig -- gnused and coreutils (for tr) are necessary for the hack exposed in the doc for 'exportLDPath'. -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. - packagesOrFile = case mshellFile of - Just filePath -> [filePath] - Nothing -> "-p" : nixpkgs + --packagesOrFile = case mshellFile of + -- Just filePath -> [filePath] + -- Nothing -> "-p" : nixpkgs fullArgs = concat [["--pure"] - ,packagesOrFile + --,packagesOrFile ,map T.unpack (nixShellOptions (configNix config)) - ,["--command"] - ,[intercalate " " - ("export":(inShellEnvVar ++ "=1"):";":exportLDPath:";":cmnd:args)] - ] + ,["-E", intercalate " " + ["with (import {}); + runCommand \"myEnv\" { + buildInputs=[",nixpkgs,"]; + shellHook='' + STACK_EXTRA_ARGS=", + map (\p -> ["--extra-lib-dirs=", "${"++p++"}/lib" + ,"--extra-include-dirs=", "${"++p++"}/include"]) + pkgsInConfig + ," + ''; + } \"\""]] + ,["--run"] + ,[concat ["export ",inShellEnvVar,"=1 ; + " + ,cmnd:args] + ]] $logDebug $ T.pack $ "Using a nix-shell environment " ++ (case mshellFile of Just filePath -> "from file: " ++ filePath From 969fa358d3500b837c0ca50076d3140e8646471a Mon Sep 17 00:00:00 2001 From: YPares Date: Thu, 12 Nov 2015 15:45:59 +0100 Subject: [PATCH 35/56] Building with --extra-lib-dirs --- src/Stack/Nix.hs | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index e7af413492..f9e48b0b5f 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -121,23 +121,22 @@ runShellAndExit getCmdArgs = do fullArgs = concat [["--pure"] --,packagesOrFile ,map T.unpack (nixShellOptions (configNix config)) - ,["-E", intercalate " " - ["with (import {}); - runCommand \"myEnv\" { - buildInputs=[",nixpkgs,"]; - shellHook='' - STACK_EXTRA_ARGS=", - map (\p -> ["--extra-lib-dirs=", "${"++p++"}/lib" - ,"--extra-include-dirs=", "${"++p++"}/include"]) - pkgsInConfig - ," - ''; - } \"\""]] - ,["--run"] - ,[concat ["export ",inShellEnvVar,"=1 ; - " - ,cmnd:args] - ]] + ,["-E", intercalate " " $ concat + [["with (import {});" + ,"runCommand \"myEnv\" {" + ,"buildInputs=["],nixpkgs,["];" + ,"shellHook=''" + , ("export " ++ inShellEnvVar ++ "=1 ;") + , "STACK_IN_NIX_EXTRA_ARGS='"] + , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" + ," --extra-include-dirs=", "${"++p++"}/include"]) + pkgsInConfig), ["' ;" + , "STACK_IN_NIX_CMD='"] + , (cmnd:args), ["' ;" + ,"'';" + ,"} \"\""]]] + ,["--command", "$STACK_IN_NIX_CMD $STACK_IN_NIX_EXTRA_ARGS"] + ] $logDebug $ T.pack $ "Using a nix-shell environment " ++ (case mshellFile of Just filePath -> "from file: " ++ filePath From 6f1ed7d4c367c0e317169de025ccc6804629838a Mon Sep 17 00:00:00 2001 From: YPares Date: Thu, 12 Nov 2015 17:25:19 +0100 Subject: [PATCH 36/56] Ok on OSX BUT in a non-pure shell. Investigating... --- src/Stack/Nix.hs | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index f9e48b0b5f..62f4d2a95d 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -113,29 +113,33 @@ runShellAndExit getCmdArgs = do _ -> "ghc" --nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig nixpkgs = "glibcLocales" : pkgsInConfig - -- gnused and coreutils (for tr) are necessary for the hack exposed in the doc for 'exportLDPath'. - -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. - --packagesOrFile = case mshellFile of - -- Just filePath -> [filePath] - -- Nothing -> "-p" : nixpkgs - fullArgs = concat [["--pure"] - --,packagesOrFile - ,map T.unpack (nixShellOptions (configNix config)) - ,["-E", intercalate " " $ concat + nixopts = case mshellFile of + Just filePath -> [filePath] + Nothing -> ["-E", intercalate " " $ concat [["with (import {});" ,"runCommand \"myEnv\" {" ,"buildInputs=["],nixpkgs,["];" ,"shellHook=''" - , ("export " ++ inShellEnvVar ++ "=1 ;") , "STACK_IN_NIX_EXTRA_ARGS='"] , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" ," --extra-include-dirs=", "${"++p++"}/include"]) pkgsInConfig), ["' ;" - , "STACK_IN_NIX_CMD='"] - , (cmnd:args), ["' ;" ,"'';" ,"} \"\""]]] - ,["--command", "$STACK_IN_NIX_CMD $STACK_IN_NIX_EXTRA_ARGS"] + -- gnused and coreutils (for tr) are necessary for the hack exposed in the doc for 'exportLDPath'. + -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. + {-baseDerivExpr = case mshellFile of + Just filePath -> "(import ./" ++ filePath ++ " {})" + Nothing -> concat $ concat + [["(with (import {}); " + ,"runCommand \"dummy\" {" + ,"buildInputs=["],nixpkgs,["]; } \"\""]]-} + fullArgs = concat [ -- ["--pure"], + map T.unpack (nixShellOptions (configNix config)) + ,nixopts + ,["--command", ("export " ++ inShellEnvVar ++ "=1 ; ") + ++ intercalate " " (cmnd:args) + ++ " $STACK_IN_NIX_EXTRA_ARGS"] ] $logDebug $ T.pack $ "Using a nix-shell environment " ++ (case mshellFile of From 103f926b13e738d68c2b9d647d6f565e7fc50fb9 Mon Sep 17 00:00:00 2001 From: YPares Date: Thu, 12 Nov 2015 18:35:15 +0100 Subject: [PATCH 37/56] No exception --- src/Stack/Nix.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 62f4d2a95d..cc23ac0814 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -103,9 +103,9 @@ runShellAndExit getCmdArgs = do <*> hIsTerminalDevice stderr) let mshellFile = nixInitFile (configNix config) pkgsInConfig = nixPackages (configNix config) - if not (null pkgsInConfig) && isJust mshellFile then + {-if not (null pkgsInConfig) && isJust mshellFile then throwM NixCannotUseShellFileAndPackagesException - else return () + else return ()-} let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal ghcInNix = case resolver of ResolverSnapshot (LTS x y) -> From 8d3a004bfa2b5552568ecb0599e369f59c07f885 Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 13 Nov 2015 17:53:26 +0100 Subject: [PATCH 38/56] Stack/Nix doesn't need BuildConfig anymore It fixes the bug which prevented stack to launch without a local GHC even if Nix GHC was to be used to build --- src/Stack/Config.hs | 2 +- src/Stack/Config/Nix.hs | 12 +++++++++--- src/Stack/Nix.hs | 25 +++++-------------------- src/main/Main.hs | 24 ++++++++++-------------- 4 files changed, 25 insertions(+), 38 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d9a4d3d24c..db49723755 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -144,7 +144,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts - configNix <- nixOptsFromMonoid configStackRoot configMonoidNixOpts + configNix <- nixOptsFromMonoid mproject configStackRoot configMonoidNixOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 2f5221c0fe..325c1fcdcb 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -8,10 +8,16 @@ import Path import Stack.Types -- | Interprets DockerOptsMonoid options. -nixOptsFromMonoid :: Monad m => Path Abs Dir -> NixOptsMonoid -> m NixOpts -nixOptsFromMonoid _stackRoot NixOptsMonoid{..} = do +nixOptsFromMonoid :: Monad m => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts +nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable - nixPackages = nixMonoidPackages + nixPackages = case mproject of + Nothing -> nixMonoidPackages + Just p -> nixMonoidPackages ++ ["glibcLocales", case projectResolver p of + ResolverSnapshot (LTS x y) -> + "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" + _ -> "ghc"] + -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. nixInitFile = nixMonoidInitFile nixShellOptions = nixMonoidShellOptions return NixOpts{..} diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index cc23ac0814..3a819c5be0 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -96,29 +96,22 @@ runShellAndExit getCmdArgs = do config <- asks getConfig envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- getCmdArgs - resolver <- bcResolver <$> asks getBuildConfig isStdoutTerminal <- asks getTerminal (isStdinTerminal,isStderrTerminal) <- liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) let mshellFile = nixInitFile (configNix config) pkgsInConfig = nixPackages (configNix config) - {-if not (null pkgsInConfig) && isJust mshellFile then + if not (null pkgsInConfig) && isJust mshellFile then throwM NixCannotUseShellFileAndPackagesException - else return ()-} + else return () let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal - ghcInNix = case resolver of - ResolverSnapshot (LTS x y) -> - "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" - _ -> "ghc" - --nixpkgs = ghcInNix : "gnused" : "coreutils" : "glibcLocales" : pkgsInConfig - nixpkgs = "glibcLocales" : pkgsInConfig nixopts = case mshellFile of Just filePath -> [filePath] Nothing -> ["-E", intercalate " " $ concat [["with (import {});" ,"runCommand \"myEnv\" {" - ,"buildInputs=["],nixpkgs,["];" + ,"buildInputs=["],pkgsInConfig,["];" ,"shellHook=''" , "STACK_IN_NIX_EXTRA_ARGS='"] , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" @@ -126,14 +119,6 @@ runShellAndExit getCmdArgs = do pkgsInConfig), ["' ;" ,"'';" ,"} \"\""]]] - -- gnused and coreutils (for tr) are necessary for the hack exposed in the doc for 'exportLDPath'. - -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. - {-baseDerivExpr = case mshellFile of - Just filePath -> "(import ./" ++ filePath ++ " {})" - Nothing -> concat $ concat - [["(with (import {}); " - ,"runCommand \"dummy\" {" - ,"buildInputs=["],nixpkgs,["]; } \"\""]]-} fullArgs = concat [ -- ["--pure"], map T.unpack (nixShellOptions (configNix config)) ,nixopts @@ -144,7 +129,7 @@ runShellAndExit getCmdArgs = do $logDebug $ T.pack $ "Using a nix-shell environment " ++ (case mshellFile of Just filePath -> "from file: " ++ filePath - Nothing -> "with nix packages: " ++ (intercalate ", " nixpkgs)) + Nothing -> "with nix packages: " ++ (intercalate ", " pkgsInConfig)) e <- try (callProcess' (if isTerm then id else \cp -> cp { delegate_ctlc = False }) Nothing @@ -180,7 +165,7 @@ type M env m = ,MonadLogger m ,MonadBaseControl IO m ,MonadCatch m - ,HasBuildConfig env + ,HasConfig env ,HasTerminal env ,HasReExec env ,HasHttpManager env diff --git a/src/main/Main.hs b/src/main/Main.hs index 69b587fd65..e82b83d962 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -605,9 +605,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do Docker.reexecWithOptionalContainer (lcProjectRoot lc) Nothing - (do bconfig <- runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc globalResolver globalCompiler - runStackTGlobal manager bconfig go $ + (do runStackTGlobal manager (lcConfig lc) go $ Nix.reexecWithOptionalShell $ runStackLoggingTGlobal manager go $ do (wantedCompiler, compilerCheck, mstack) <- @@ -764,19 +762,19 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do runStackTGlobal manager bconfig go (setupEnv Nothing) - runStackTGlobal manager bconfig go $ - Nix.reexecWithOptionalShell - (runStackTGlobal - manager - envConfig - go - (inner' lk)) + runStackTGlobal + manager + envConfig + go + (inner' lk) runStackTGlobal manager (lcConfig lc) go $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore - (inner'' lk0) + (runStackTGlobal manager (lcConfig lc) go $ + Nix.reexecWithOptionalShell (inner'' lk0) + ) mafter (Just $ liftIO $ do lk' <- readIORef curLk @@ -889,9 +887,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do -- Unlock before transferring control away, whether using -- docker or not: (Just $ munlockFile lk) - (do bconfig <- runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc globalResolver globalCompiler - runStackTGlobal manager bconfig go $ do + (runStackTGlobal manager (lcConfig lc) go $ do Nix.execWithOptionalShell (return (cmd, args)) (runStackTGlobal manager (lcConfig lc) go $ From da3c61e4371ff9544a654fb7b66347cc5ac40bfd Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 13 Nov 2015 17:56:19 +0100 Subject: [PATCH 39/56] Removed shell string to export LD_LIBRARY_PATH since we're using --extra-lib-dirs explicitely passed to stack --- src/Stack/Nix.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 3a819c5be0..591e681052 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -140,13 +140,6 @@ runShellAndExit getCmdArgs = do Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) Right () -> liftIO exitSuccess --- | This is a hack! --- Nix currently doesn't expose the paths of the shared libraries provided --- by the demanded packages in a manner that is suitable to GHC. --- Therefore, in the Nix-shell, we retrieve in the NIX_LDFLAGS env var those paths and set LD_LIBRARY_PATH before the build happens. -exportLDPath :: String -exportLDPath = "export LD_LIBRARY_PATH=`echo -n $NIX_LDFLAGS | tr ' ' $'\n' | sed -n '/-L/{s/-L//; p}' | tr $'\n' ':'`" - -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) From 9c843157321860f2919a3459da7ed57c55340ac5 Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 13 Nov 2015 18:59:07 +0100 Subject: [PATCH 40/56] glibcLocales passed as buildInput only on Linux --- src/Stack/Config/Nix.hs | 3 +-- src/Stack/Nix.hs | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 325c1fcdcb..92acc15aca 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -13,11 +13,10 @@ nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable nixPackages = case mproject of Nothing -> nixMonoidPackages - Just p -> nixMonoidPackages ++ ["glibcLocales", case projectResolver p of + Just p -> nixMonoidPackages ++ [case projectResolver p of ResolverSnapshot (LTS x y) -> "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" _ -> "ghc"] - -- glibcLocales is necessary to avoid warnings about GHC being incapable to set the locale. nixInitFile = nixMonoidInitFile nixShellOptions = nixMonoidShellOptions return NixOpts{..} diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 591e681052..4432575a12 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -111,7 +111,7 @@ runShellAndExit getCmdArgs = do Nothing -> ["-E", intercalate " " $ concat [["with (import {});" ,"runCommand \"myEnv\" {" - ,"buildInputs=["],pkgsInConfig,["];" + ,"buildInputs=lib.optional stdenv.isLinux \"glibcLocales\" ++ ["],pkgsInConfig,["];" ,"shellHook=''" , "STACK_IN_NIX_EXTRA_ARGS='"] , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" @@ -119,6 +119,7 @@ runShellAndExit getCmdArgs = do pkgsInConfig), ["' ;" ,"'';" ,"} \"\""]]] + -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale. fullArgs = concat [ -- ["--pure"], map T.unpack (nixShellOptions (configNix config)) ,nixopts @@ -138,6 +139,7 @@ runShellAndExit getCmdArgs = do fullArgs) case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) + Right () -> liftIO exitSuccess -- | 'True' if we are currently running inside a Nix. From 7c876f5e7d69654461cbb3211526a0541e908d1f Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 13 Nov 2015 19:43:19 +0100 Subject: [PATCH 41/56] darwin.cf-private added as a dep on OSX --- src/Stack/Nix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 4432575a12..6d81ca7fd8 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -111,7 +111,7 @@ runShellAndExit getCmdArgs = do Nothing -> ["-E", intercalate " " $ concat [["with (import {});" ,"runCommand \"myEnv\" {" - ,"buildInputs=lib.optional stdenv.isLinux \"glibcLocales\" ++ ["],pkgsInConfig,["];" + ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ lib.optional stdenv.isDarwin darwin.cf-private ++ ["],pkgsInConfig,["];" ,"shellHook=''" , "STACK_IN_NIX_EXTRA_ARGS='"] , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" From 51498b705f6f0fa2b0a6efba216510101f9a7ca6 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 18 Nov 2015 10:51:14 +0100 Subject: [PATCH 42/56] Updated Nix test due to change of behaviour GHC is automatically added to Nix deps, because it's necessary at least on Linux. This is now reflected in the tests. --- src/test/Stack/NixShellSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs index 50dd21abf2..f363b6e35d 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixShellSpec.hs @@ -56,8 +56,8 @@ spec = beforeAll setup $ afterAll teardown $ do writeFile (toFilePath stackDotYaml) sampleConfig lc <- loadConfig' manager (nixEnable $ configNix $ lcConfig lc) `shouldBe` True - it "sees that the only package asked for is glpk" $ \T{..} -> inTempDir $ do + it "sees that the only package asked for is glpk and adds GHC from nixpkgs mirror of LTS resolver" $ \T{..} -> inTempDir $ do writeFile (toFilePath stackDotYaml) sampleConfig lc <- loadConfig' manager - (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"] + (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk", "haskell.packages.lts-2_10.ghc"] From 1b6b03260512371d03ccc704ec84231b1cf8746b Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 18 Nov 2015 11:40:08 +0100 Subject: [PATCH 43/56] Fixing warning --- src/Stack/Config.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 131db82d08..325e655c14 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -34,7 +34,6 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Arrow ((***)) -import Control.Exception (IOException) import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM) import Control.Monad.IO.Class @@ -68,9 +67,9 @@ import qualified Paths_stack as Meta import Safe (headMay) import Stack.BuildPlan import Stack.Config.Docker -import Stack.Constants import Stack.Config.Docker import Stack.Config.Nix +import Stack.Constants import qualified Stack.Image as Image import Stack.Init import Stack.PackageIndex From c7b7e29a3889d97f9bc446e4bedf7ac67bd8ba07 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 18 Nov 2015 12:04:44 +0100 Subject: [PATCH 44/56] Builds with --pedantic --- src/Stack/Config.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 325e655c14..fcdf16d028 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -67,7 +67,6 @@ import qualified Paths_stack as Meta import Safe (headMay) import Stack.BuildPlan import Stack.Config.Docker -import Stack.Config.Docker import Stack.Config.Nix import Stack.Constants import qualified Stack.Image as Image From 86d2204907c0c2bffddd6fe267996d3a5fef858a Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 18 Nov 2015 13:20:55 +0100 Subject: [PATCH 45/56] Building with --pedantic with GHC 7.8.4 --- src/test/Stack/NixShellSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs index f363b6e35d..5118ad3ad5 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixShellSpec.hs @@ -7,6 +7,7 @@ import Test.Hspec import Control.Monad.Logger import Control.Exception +import Data.Monoid (mempty) import Network.HTTP.Conduit (Manager) import System.Environment import Path From 44a22415b988a9d667346f5c048256c705bfaf14 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 18 Nov 2015 15:33:15 +0100 Subject: [PATCH 46/56] Removed warning with an import Prelude --- src/test/Stack/NixShellSpec.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs index 5118ad3ad5..43de1ed18b 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixShellSpec.hs @@ -7,7 +7,7 @@ import Test.Hspec import Control.Monad.Logger import Control.Exception -import Data.Monoid (mempty) +import Data.Monoid import Network.HTTP.Conduit (Manager) import System.Environment import Path @@ -19,6 +19,9 @@ import Stack.Types.Config import Stack.Types.StackT import Stack.Types.Nix +import Prelude -- to remove the warning about Data.Monoid being redundant on GHC 7.10 + + sampleConfig :: String sampleConfig = "resolver: lts-2.10\n" ++ From a6e51d0e0508a179fdd7c5986fbe0973ad3ecab7 Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 25 Nov 2015 11:13:20 +0100 Subject: [PATCH 47/56] Nix integration documentation added to manual Removed a language annotation in doc Fixed an internal link Added ref to nixpkgs github --- doc/GUIDE.md | 12 ++++ doc/nix_integration.md | 141 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 153 insertions(+) create mode 100644 doc/nix_integration.md diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 245ffbc692..b34e24f218 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1686,6 +1686,18 @@ image: and then run `stack image container` and then `docker images` to list the images. +### Nix + +stack provides an integration with [Nix](http://nixos.org/nix), in order to build inside nix-shells. This allows you: + +* to gather non-Haskell dependencies that are packaged in [Nixpkgs](http://nixos.org/nixpkgs) before build starts +* to have these dependencies installed in an isolated location +* to launch the build in a special environment (a nix-shell) so it may find these dependencies without altering your system + +The Nix ecosystem provides a programming language and a package management system. The [Nix manual](http://nixos.org/nix/manual) is a good place to start. + +For more information, see [the Nix-integration documentation](nix_integration.md). + ## Power user commands The following commands are a little more powerful, and won't be needed by all diff --git a/doc/nix_integration.md b/doc/nix_integration.md new file mode 100644 index 0000000000..2d9ad0d150 --- /dev/null +++ b/doc/nix_integration.md @@ -0,0 +1,141 @@ +# Using Nix with Stack + +`stack` can build automatically inside a Nix-shell, provided Nix is already installed on your system. +There are two ways of doing that: + +- providing a list of packages (by attribute name) existing in [Nixpkgs](http://nixos.org/nixos/packages.html), or +- providing a custom `shell.nix` file defining a derivation that will be used to launch the shell. + +The second requires a fully explicit configuration. So use this option only if +you already know Nix and have special requirements, as using one or several +overriden Nix derivations or using libraries which are not laid out in standard +way once installed in the Nix store. + +## Usage + +To install Nix, please visit the [Nix download page](http://nixos.org/nix/download.html). + +### Enable in stack.yaml + +Add a section to your stack.yaml as follows: + + nix-shell: + enable: true + packages: [glpk, pcre] + +It will make `stack` build inside a Nix-shell that will first install and make available the `glpk` and `pcre` libraries. + +Stack expects every library used this way to provide a `lib` and an `include` +subdirectories directly in the directory where the library is installed in the +nix store, which is the case for most libraries in Nixpkgs. + +On both Linux and MacOSX, this will automatically add a dependency to GHC +according to which `resolver:` is used in your `stack.yaml` configuration. This +means that when using the Nix support, stack no longer builds using a locally +installed GHC, as GHC becomes yet another Nix dependency. + +This also means that you cannot set your `resolver:` to something that has not yet been mirrored in the Nixpkgs. In order to check this, the quickest way is to install and launch a `nix-repl`: + +``` +$ nix-channel --update +$ nix-env -i nix-repl +$ nix-repl +``` + +Then, inside the `nix-repl`, do: + +``` +nix-repl> :l +nix-repl> haskell.packages.lts-3_13.ghc +``` + +Replace the resolver version with whatever version you are using. If it outputs +a path of a derivation in the Nix store, like + +`«derivation /nix/store/00xx8y0p3r0dqyq2frq277yr1ldqzzg0-ghc-7.10.2.drv»` + +then it means this resolver has been mirrored. Whereas an error like + +`error: attribute ‘lts-3_14’ missing, at (string):1:1` + +means you should use a different resolver. +You can also use autocompletion with TAB to know which attributes `haskell.packages` contains. + +In Nixpkgs master branch, you can find the mirrored resolvers in the Haskell modules [here on Github](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules). + +### Use stack as normal + +With Nix enabled, `stack build` and `stack exec` will automatically launch themselves in a nix-shell. Note that for now `stack ghci` will not work, due to a bug in GHCi when working with external shared libraries. + +Note that if `enable:` is set to `false`, you can still build in a nix-shell by passing the `--nix` flag to stack, for instance `stack --nix build`. + +## Command-line options + +The configuration present in your `stack.yaml` can be overriden on the command-line. See `stack --nix-help` for a list of all Nix options. + + +## Configuration + +`stack.yaml` contains a `nix-shell:` section with Nix settings. Without this section, Nix will not be used. + +Here is a commented configuration file, showing the default values: + + nix-shell: + + # `true` by default when the nix-shell section is present. + # Set it to `false` to disable using Nix. + enable: true + + # Empty by default. The list of packages you want to be available + # in the nix-shell at build time (with `stack build`) and + #run time (with `stack exec`). + packages: [] + + # Unset by default. You cannot set this option if `packages:` + # is already present and not empty, this will result in + # an exception + shell-file: shell.nix + + # A list of strings, empty by default. + # Additional options that will be passed + # verbatim to the `nix-shell` command. + nix-shell-options: [] + +## Using a custom shell.nix file + +Nix is also a programming language, and as specified [here](#using-nix-with-stack) if you know it you can provide +to the shell a fully customized derivation as an environment to use. Here is +the equivalent of the configuration used in [this section](#enable-in-stackyaml), but with an explicit `shell.nix` +file: + +``` +with (import {}); +stdenv.mkDerivation { + name = "myEnv"; + buildInputs = [glpk pcre haskell.packages.lts-3_13.ghc]; + STACK_IN_NIX_EXTRA_ARGS="--extra-lib-dirs=${glpk}/lib --extra-include-dirs=${glpk}/include --extra-lib-dirs=${pcre}/lib --extra-include-dirs=${pcre}/include"; +} +``` + +Note that in that case, you _have_ to include (a version of) GHC in your +`buildInputs`! This potentially allows you to use a GHC which is not the one of +your `resolver:`. Also, you need to tell Stack where to find the new libraries +and headers. This is especially necessary on MacOSX. The special variable +`STACK_IN_NIX_EXTRA_ARGS` will be looked for by the nix-shell when running the +inner `stack` process. `--extra-lib-dirs` and `--extra-include-dirs` are +regular `stack build` options. You can repeat these options for each dependency. + +Defining manually a `shell.nix` file gives you the possibility to override some +Nix derivations ("packages"), for instance to change some build options of the +libraries you use. + +And now for the `stack.yaml` file: + +``` +nix-shell: + enable: true + shell-file: shell.nix +``` + +The `stack build` command will behave exactly the same as above. Note that specifying both `packages:` +and a `shell-file:` results in an error. (Comment one out before adding the other.) From dcd10f9435530489c085d4da8d1d5facebfcf9d7 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Wed, 25 Nov 2015 16:38:14 +0100 Subject: [PATCH 48/56] Edit Nix section of the guide. --- doc/GUIDE.md | 34 ++++++++--- doc/nix_integration.md | 133 +++++++++++++++++++++++------------------ 2 files changed, 100 insertions(+), 67 deletions(-) diff --git a/doc/GUIDE.md b/doc/GUIDE.md index caceed685e..70826be685 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1690,15 +1690,33 @@ the images. ### Nix -stack provides an integration with [Nix](http://nixos.org/nix), in order to build inside nix-shells. This allows you: +stack provides an integration with [Nix](http://nixos.org/nix), +providing you with the same two benefits as the first Docker +integration discussed above: + +* more reproducible builds, since fixed versions of any system + libraries and commands required to build the project are + automatically built using Nix and managed locally per-project. These + system packages never conflict with any existing versions of these + libraries on your system. That they are managed locally to the + project means that you don't need to alter your system in any way to + build any odd project pulled from the Internet. +* implicit sharing of system packages between projects, so you don't + have more copies on-disk than you need to. + +Both Docker and Nix are methods to *isolate* builds and thereby make +them more reproducible. They just differ in the means of achieving +this isolation. Nix provides slightly weaker isolation guarantees than +Docker, but is more lightweight and more portable (Linux and OS +X mainly, but also Windows). For more on Nix, its command-line +interface and its package description language, read the +[Nix manual](http://nixos.org/nix/manual). But keep in mind that the +point of stack's support is to obviate the need to write any Nix code +in the common case or even to learn how to use the Nix tools (they're +called under the hood). -* to gather non-Haskell dependencies that are packaged in [Nixpkgs](http://nixos.org/nixpkgs) before build starts -* to have these dependencies installed in an isolated location -* to launch the build in a special environment (a nix-shell) so it may find these dependencies without altering your system - -The Nix ecosystem provides a programming language and a package management system. The [Nix manual](http://nixos.org/nix/manual) is a good place to start. - -For more information, see [the Nix-integration documentation](nix_integration.md). +For more information, see +[the Nix-integration documentation](nix_integration.md). ## Power user commands diff --git a/doc/nix_integration.md b/doc/nix_integration.md index 2d9ad0d150..90337a6edd 100644 --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -1,40 +1,42 @@ # Using Nix with Stack -`stack` can build automatically inside a Nix-shell, provided Nix is already installed on your system. -There are two ways of doing that: +`stack` can build automatically inside a nix-shell (the equivalent of +a "container" in Docker parlance), provided Nix is already installed +on your system. To do so, please visit the +[Nix download page](http://nixos.org/nix/download.html). -- providing a list of packages (by attribute name) existing in [Nixpkgs](http://nixos.org/nixos/packages.html), or -- providing a custom `shell.nix` file defining a derivation that will be used to launch the shell. +There are two ways to create a nix-shell: -The second requires a fully explicit configuration. So use this option only if -you already know Nix and have special requirements, as using one or several -overriden Nix derivations or using libraries which are not laid out in standard -way once installed in the Nix store. +- providing a list of packages (by "attribute name") from + [Nixpkgs](http://nixos.org/nixos/packages.html), or +- providing a custom `shell.nix` file containing a Nix expression that + determines a *derivation*, i.e. a specification of what resources + are available inside the shell. -## Usage +The second requires writing code in Nix's custom language. So use this +option only if you already know Nix and have special requirements, +such as using custom Nix packages that override the standard ones or +using system libraries with special requirements. -To install Nix, please visit the [Nix download page](http://nixos.org/nix/download.html). +### Additions to your `stack.yaml` -### Enable in stack.yaml - -Add a section to your stack.yaml as follows: +Add a section to your `stack.yaml` as follows: nix-shell: - enable: true - packages: [glpk, pcre] - -It will make `stack` build inside a Nix-shell that will first install and make available the `glpk` and `pcre` libraries. - -Stack expects every library used this way to provide a `lib` and an `include` -subdirectories directly in the directory where the library is installed in the -nix store, which is the case for most libraries in Nixpkgs. + enable: true + packages: [glpk, pcre] -On both Linux and MacOSX, this will automatically add a dependency to GHC -according to which `resolver:` is used in your `stack.yaml` configuration. This -means that when using the Nix support, stack no longer builds using a locally -installed GHC, as GHC becomes yet another Nix dependency. +This will instruct `stack` to build inside a nix-shell that will have +the `glpk` and `pcre` libraries installed and available. Further, the +nix-shell will implicitly also include a version of GHC matching the +configured resolver. Enabling Nix support means packages will always +be built using a GHC available inside the shell, rather than your +globally installed one if any. -This also means that you cannot set your `resolver:` to something that has not yet been mirrored in the Nixpkgs. In order to check this, the quickest way is to install and launch a `nix-repl`: +Note also that this also means that you cannot set your `resolver:` to +something that has not yet been mirrored in the Nixpkgs package +repository. In order to check this, the quickest way is to install and +launch a `nix-repl`: ``` $ nix-channel --update @@ -56,56 +58,67 @@ a path of a derivation in the Nix store, like then it means this resolver has been mirrored. Whereas an error like -`error: attribute ‘lts-3_14’ missing, at (string):1:1` +`error: attribute ‘lts-3_99’ missing, at (string):1:1` -means you should use a different resolver. -You can also use autocompletion with TAB to know which attributes `haskell.packages` contains. +means you should use a different resolver. You can also use +autocompletion with TAB to know which attributes `haskell.packages` +contains. -In Nixpkgs master branch, you can find the mirrored resolvers in the Haskell modules [here on Github](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules). +In Nixpkgs master branch, you can find the mirrored resolvers in the +Haskell modules +[here on Github](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules). ### Use stack as normal -With Nix enabled, `stack build` and `stack exec` will automatically launch themselves in a nix-shell. Note that for now `stack ghci` will not work, due to a bug in GHCi when working with external shared libraries. +With Nix enabled, `stack build` and `stack exec` will automatically +launch themselves in a nix-shell. Note that for now `stack ghci` will +not work, due to a bug in GHCi when working with external shared +libraries. -Note that if `enable:` is set to `false`, you can still build in a nix-shell by passing the `--nix` flag to stack, for instance `stack --nix build`. +If `enable:` is set to `false`, you can still build in a nix-shell by +passing the `--nix` flag to stack, for instance `stack --nix build`. +Nix just won't be used by default. ## Command-line options -The configuration present in your `stack.yaml` can be overriden on the command-line. See `stack --nix-help` for a list of all Nix options. +The configuration present in your `stack.yaml` can be overriden on the +command-line. See `stack --nix-help` for a list of all Nix options. ## Configuration -`stack.yaml` contains a `nix-shell:` section with Nix settings. Without this section, Nix will not be used. +`stack.yaml` contains a `nix-shell:` section with Nix settings. +Without this section, Nix will not be used. Here is a commented configuration file, showing the default values: nix-shell: - # `true` by default when the nix-shell section is present. - # Set it to `false` to disable using Nix. + # `true` by default when the nix-shell section is present. Set + # it to `false` to disable using Nix. enable: true - # Empty by default. The list of packages you want to be available - # in the nix-shell at build time (with `stack build`) and - #run time (with `stack exec`). + # Empty by default. The list of packages you want to be + # available in the nix-shell at build time (with `stack + # build`) and run time (with `stack exec`). packages: [] # Unset by default. You cannot set this option if `packages:` - # is already present and not empty, this will result in - # an exception + # is already present and not empty, this will result in an + # exception shell-file: shell.nix - # A list of strings, empty by default. - # Additional options that will be passed - # verbatim to the `nix-shell` command. + # A list of strings, empty by default. Additional options that + # will be passed verbatim to the `nix-shell` command. nix-shell-options: [] ## Using a custom shell.nix file -Nix is also a programming language, and as specified [here](#using-nix-with-stack) if you know it you can provide -to the shell a fully customized derivation as an environment to use. Here is -the equivalent of the configuration used in [this section](#enable-in-stackyaml), but with an explicit `shell.nix` +Nix is also a programming language, and as specified +[here](#using-nix-with-stack) if you know it you can provide to the +shell a fully customized derivation as an environment to use. Here is +the equivalent of the configuration used in +[this section](#enable-in-stackyaml), but with an explicit `shell.nix` file: ``` @@ -117,17 +130,18 @@ stdenv.mkDerivation { } ``` -Note that in that case, you _have_ to include (a version of) GHC in your -`buildInputs`! This potentially allows you to use a GHC which is not the one of -your `resolver:`. Also, you need to tell Stack where to find the new libraries -and headers. This is especially necessary on MacOSX. The special variable -`STACK_IN_NIX_EXTRA_ARGS` will be looked for by the nix-shell when running the -inner `stack` process. `--extra-lib-dirs` and `--extra-include-dirs` are -regular `stack build` options. You can repeat these options for each dependency. +Note that in this case, you _have_ to include (a version of) GHC in +your `buildInputs`! This potentially allows you to use a GHC which is +not the one of your `resolver:`. Also, you need to tell Stack where to +find the new libraries and headers. This is especially necessary on OS +X. The special variable `STACK_IN_NIX_EXTRA_ARGS` will be looked for +by the nix-shell when running the inner `stack` process. +`--extra-lib-dirs` and `--extra-include-dirs` are regular `stack +build` options. You can repeat these options for each dependency. -Defining manually a `shell.nix` file gives you the possibility to override some -Nix derivations ("packages"), for instance to change some build options of the -libraries you use. +Defining manually a `shell.nix` file gives you the possibility to +override some Nix derivations ("packages"), for instance to change +some build options of the libraries you use. And now for the `stack.yaml` file: @@ -137,5 +151,6 @@ nix-shell: shell-file: shell.nix ``` -The `stack build` command will behave exactly the same as above. Note that specifying both `packages:` -and a `shell-file:` results in an error. (Comment one out before adding the other.) +The `stack build` command will behave exactly the same as above. Note +that specifying both `packages:` and a `shell-file:` results in an +error. (Comment one out before adding the other.) From 29135b3b5bd4c19eee77cb5722f67f8ff8bc2278 Mon Sep 17 00:00:00 2001 From: Mathieu Boespflug Date: Wed, 25 Nov 2015 16:42:23 +0100 Subject: [PATCH 49/56] Mention stack nix standard layout condition in manual. --- doc/nix_integration.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/nix_integration.md b/doc/nix_integration.md index 90337a6edd..69df7faf79 100644 --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -68,6 +68,12 @@ In Nixpkgs master branch, you can find the mirrored resolvers in the Haskell modules [here on Github](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules). +*Note:* currently, stack only discovers dynamic and static libraries +in the `lib/` folder of any nix package, and likewise header files in +the `include/` folder. If you're dealing with a package that doesn't +follow this standard layout, you'll have to deal with that using +a custom shell file (see below). + ### Use stack as normal With Nix enabled, `stack build` and `stack exec` will automatically From 8acfb7adc87e0538ab0d904faff1976bdce9c04b Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 27 Nov 2015 17:42:49 +0100 Subject: [PATCH 50/56] Simplifying src/Stack/Nix.hs and using the right CL parsing combinators --- src/Stack/Config/Nix.hs | 7 +-- src/Stack/Nix.hs | 100 +++++++++++++--------------------------- src/Stack/Options.hs | 15 +++--- src/Stack/Types/Nix.hs | 4 +- src/main/Main.hs | 5 +- 5 files changed, 48 insertions(+), 83 deletions(-) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 92acc15aca..1c3a0a1176 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} -- | Nix configuration module Stack.Config.Nix where +import Data.Text (pack) import Data.Maybe import Path import Stack.Types @@ -15,8 +16,8 @@ nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do Nothing -> nixMonoidPackages Just p -> nixMonoidPackages ++ [case projectResolver p of ResolverSnapshot (LTS x y) -> - "haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc" - _ -> "ghc"] + pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc") + _ -> pack "ghc"] nixInitFile = nixMonoidInitFile nixShellOptions = nixMonoidShellOptions return NixOpts{..} diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 6d81ca7fd8..bb288db672 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,13 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, TemplateHaskell #-} -- | Run commands in a nix-shell module Stack.Nix - (execWithOptionalShell - ,reexecWithOptionalShell + (reexecWithOptionalShell ,nixCmdName ,StackNixException(..) ) where @@ -23,6 +20,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Data.Char (toUpper) import Data.List (intercalate) import Data.Maybe +import Data.Monoid import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import qualified Data.Text as T import Data.Typeable @@ -31,30 +29,27 @@ import Network.HTTP.Client.Conduit (HasHttpManager) import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings import Stack.Constants (stackProgName) -import Stack.Docker (StackDockerException(OnlyOnHostException), reExecArgName) +import Stack.Docker (reExecArgName) +import Stack.Exec (exec) import Stack.Types import Stack.Types.Internal import System.Environment (lookupEnv,getArgs,getExecutablePath) import System.Exit (exitSuccess, exitWith) -import System.IO (stderr,stdin,hIsTerminalDevice) -import System.Process.Read -import System.Process.Run -import System.Process (CreateProcess(delegate_ctlc)) -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. --- --- This takes an optional release action which should be taken IFF control is --- transfering away from the current process to the intra-container one. The main use --- for this is releasing a lock. After launching reexecution, the host process becomes --- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalShell :: M env m => IO () -> m () -reexecWithOptionalShell = - execWithOptionalShell getCmdArgs +reexecWithOptionalShell inner = + do config <- asks getConfig + inShell <- getInShell + isReExec <- asks getReExec + if nixEnable (configNix config) && not inShell && not isReExec + then runShellAndExit getCmdArgs + else liftIO (inner >> exitSuccess) where getCmdArgs = do args <- @@ -64,77 +59,46 @@ reexecWithOptionalShell = exePath <- liftIO getExecutablePath return (exePath, args) --- | If Nix is enabled, re-runs the OS command returned by the second argument in a --- Nix container. Otherwise, runs the inner action. --- --- This takes an optional release action just like `reexecWithOptionalShell`. -execWithOptionalShell - :: M env m - => m (FilePath,[String]) - -> IO () - -> m () -execWithOptionalShell getCmdArgs inner = - do config <- asks getConfig - inShell <- getInShell - isReExec <- asks getReExec - if | inShell && not isReExec -> - throwM OnlyOnHostException - | inShell -> - liftIO (do inner - exitSuccess) - | not (nixEnable (configNix config)) -> - do liftIO inner - liftIO exitSuccess - | otherwise -> - do runShellAndExit - getCmdArgs - runShellAndExit :: M env m => m (String, [String]) -> m () runShellAndExit getCmdArgs = do config <- asks getConfig - envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- getCmdArgs - isStdoutTerminal <- asks getTerminal - (isStdinTerminal,isStderrTerminal) <- - liftIO ((,) <$> hIsTerminalDevice stdin - <*> hIsTerminalDevice stderr) let mshellFile = nixInitFile (configNix config) pkgsInConfig = nixPackages (configNix config) if not (null pkgsInConfig) && isJust mshellFile then throwM NixCannotUseShellFileAndPackagesException else return () - let isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal - nixopts = case mshellFile of + let nixopts = case mshellFile of Just filePath -> [filePath] - Nothing -> ["-E", intercalate " " $ concat + Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat [["with (import {});" ,"runCommand \"myEnv\" {" - ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ lib.optional stdenv.isDarwin darwin.cf-private ++ ["],pkgsInConfig,["];" - ,"shellHook=''" - , "STACK_IN_NIX_EXTRA_ARGS='"] - , (map (\p -> concat ["--extra-lib-dirs=", "${"++p++"}/lib" - ," --extra-include-dirs=", "${"++p++"}/include"]) - pkgsInConfig), ["' ;" - ,"'';" + ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgsInConfig,["];" + ,T.pack inShellEnvVar,"=1 ;" + ,"STACK_IN_NIX_EXTRA_ARGS=''"] + , (map (\p -> T.concat + ["--extra-lib-dirs=${",p,"}/lib" + ," --extra-include-dirs=${",p,"}/include "]) + pkgsInConfig), ["'' ;" ,"} \"\""]]] -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale. fullArgs = concat [ -- ["--pure"], map T.unpack (nixShellOptions (configNix config)) ,nixopts - ,["--command", ("export " ++ inShellEnvVar ++ "=1 ; ") - ++ intercalate " " (cmnd:args) + ,["--command", intercalate " " (cmnd:args) ++ " $STACK_IN_NIX_EXTRA_ARGS"] ] - $logDebug $ T.pack $ - "Using a nix-shell environment " ++ (case mshellFile of - Just filePath -> "from file: " ++ filePath - Nothing -> "with nix packages: " ++ (intercalate ", " pkgsInConfig)) - e <- try (callProcess' - (if isTerm then id else \cp -> cp { delegate_ctlc = False }) - Nothing - envOverride + $logDebug $ + "Using a nix-shell environment " <> (case mshellFile of + Just filePath -> "from file: " <> (T.pack filePath) + Nothing -> "with nix packages: " <> (T.intercalate ", " pkgsInConfig)) + e <- try (exec + (EnvSettings {esIncludeLocals = False + ,esIncludeGhcPackagePath = False + ,esStackExe = False + ,esLocaleUtf8 = False}) "nix-shell" fullArgs) case e of @@ -147,6 +111,8 @@ getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) -- | Environment variable used to indicate stack is running in container. +-- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions, +-- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty. inShellEnvVar :: String inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"] diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index f7acc0f2bb..2261cf89f5 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -313,7 +313,7 @@ configOptsParser hide0 = where hide = hideMods hide0 nixOptsParser :: Bool -> Parser NixOptsMonoid -nixOptsParser showOptions = +nixOptsParser hide0 = NixOptsMonoid <$> pure False <*> maybeBoolFlags nixCmdName @@ -321,14 +321,13 @@ nixOptsParser showOptions = hide <*> pure [] <*> pure Nothing - <*> many (textOption (long "nix-shell-options" <> - metavar "OPTION" <> - help "Additional options passed to nix-shell" <> - hide)) + <*> ((map T.pack . fromMaybe []) + <$> optional (argsOption (long "nix-shell-options" <> + metavar "OPTION" <> + help "Additional options passed to nix-shell" <> + hide))) where - hide = if showOptions - then idm - else internal <> hidden + hide = hideMods hide0 -- | Options parser configuration for Docker. diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index bbe4fa6236..548b6ae1ce 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -14,7 +14,7 @@ import Data.Text (Text) -- | Nix configuration. data NixOpts = NixOpts {nixEnable :: !Bool - ,nixPackages :: ![String] + ,nixPackages :: ![Text] -- ^ The system packages to be installed in the environment before it runs ,nixInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) @@ -30,7 +30,7 @@ data NixOptsMonoid = NixOptsMonoid -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? ,nixMonoidEnable :: !(Maybe Bool) -- ^ Is using nix-shell enabled? - ,nixMonoidPackages :: ![String] + ,nixMonoidPackages :: ![Text] -- ^ System packages to use (given to nix-shell) ,nixMonoidInitFile :: !(Maybe String) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) diff --git a/src/main/Main.hs b/src/main/Main.hs index 00d09042ce..a832823393 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -117,7 +117,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") execExtraHelp args nixHelpOptName - (nixOptsParser True) + (nixOptsParser False) ("Only showing --" ++ Nix.nixCmdName ++ "* options.") let commitCount = $gitCommitCount versionString' = concat $ concat @@ -880,8 +880,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) (runStackTGlobal manager (lcConfig lc) go $ - Nix.execWithOptionalShell - (return (cmd, args)) + Nix.reexecWithOptionalShell (runStackTGlobal manager (lcConfig lc) go $ exec plainEnvSettings cmd args)) Nothing From ae7e0fff80e804cd668e2669a45cc511c5b32b15 Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 27 Nov 2015 18:14:19 +0100 Subject: [PATCH 51/56] Changelog updated --- ChangeLog.md | 3 +++ src/main/Main.hs | 1 - 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 0c90f8395e..a0224dbfac 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -4,6 +4,9 @@ Major changes: +* Support for building inside a Nix-shell providing system dependencies + [#1285](https://github.com/commercialhaskell/stack/pull/1285) + Other enhancements: * Print latest applicable version of packages on conflicts diff --git a/src/main/Main.hs b/src/main/Main.hs index 15f1e96f6b..d8c4902125 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -124,7 +124,6 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do nixHelpOptName (nixOptsParser False) ("Only showing --" ++ Nix.nixCmdName ++ "* options.") - #ifdef USE_GIT_INFO let commitCount = $gitCommitCount versionString' = concat $ concat From ae9d301d5c1c62a37f3c4c673ca20fabf9a997c1 Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 27 Nov 2015 18:32:50 +0100 Subject: [PATCH 52/56] Stack/Nix: shell subcommand args put between simple quotes --- src/Stack/Nix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index bb288db672..c72ea9878d 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -87,7 +87,7 @@ runShellAndExit getCmdArgs = do fullArgs = concat [ -- ["--pure"], map T.unpack (nixShellOptions (configNix config)) ,nixopts - ,["--command", intercalate " " (cmnd:args) + ,["--command", intercalate " " (map (\a -> "'"++a++"'") (cmnd:args)) ++ " $STACK_IN_NIX_EXTRA_ARGS"] ] $logDebug $ From 95051af4f8c0771b82d6ba3cffd66f94d0b7d2ef Mon Sep 17 00:00:00 2001 From: YPares Date: Fri, 27 Nov 2015 18:35:39 +0100 Subject: [PATCH 53/56] Fixed OverloadedStrings missing in tests --- src/test/Stack/NixShellSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixShellSpec.hs index 43de1ed18b..968e6ce33f 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixShellSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} module Stack.NixShellSpec where import Test.Hspec From c2a1135762282aa7220c7f9f0a432936cb5eafbe Mon Sep 17 00:00:00 2001 From: YPares Date: Tue, 1 Dec 2015 12:31:04 +0100 Subject: [PATCH 54/56] Nix: Escaping quote characters before re-issuing the stack cmd --- src/Stack/Nix.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 584ff4212c..54edd9dd54 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -89,7 +89,7 @@ runShellAndExit getCmdArgs = do fullArgs = concat [ -- ["--pure"], map T.unpack (nixShellOptions (configNix config)) ,nixopts - ,["--command", intercalate " " (map (\a -> "'"++a++"'") (cmnd:args)) + ,["--command", intercalate " " (map escape (cmnd:args)) ++ " $STACK_IN_NIX_EXTRA_ARGS"] ] $logDebug $ @@ -101,6 +101,13 @@ runShellAndExit getCmdArgs = do Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec) Right () -> liftIO exitSuccess +-- | Shell-escape quotes inside the string and enclose it in quotes. +escape :: String -> String +escape str = "'" ++ foldr (\c -> if c == '\'' then + ("'\"'\"'"++) + else (c:)) "" str + ++ "'" + -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar) From 6be2541f047beec3bbcedd921389419a6ce2a130 Mon Sep 17 00:00:00 2001 From: YPares Date: Tue, 1 Dec 2015 12:50:32 +0100 Subject: [PATCH 55/56] nix-shell: section in stack.yaml renamed to nix: for coherence with CLI --- doc/nix_integration.md | 12 ++++++------ src/Stack/Types/Config.hs | 6 +++--- src/Stack/Types/Nix.hs | 5 +++-- src/test/Stack/{NixShellSpec.hs => NixSpec.hs} | 8 ++++---- stack.cabal | 2 +- 5 files changed, 17 insertions(+), 16 deletions(-) rename src/test/Stack/{NixShellSpec.hs => NixSpec.hs} (92%) diff --git a/doc/nix_integration.md b/doc/nix_integration.md index 69df7faf79..e6de031e48 100644 --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -22,7 +22,7 @@ using system libraries with special requirements. Add a section to your `stack.yaml` as follows: - nix-shell: + nix: enable: true packages: [glpk, pcre] @@ -56,7 +56,7 @@ a path of a derivation in the Nix store, like `«derivation /nix/store/00xx8y0p3r0dqyq2frq277yr1ldqzzg0-ghc-7.10.2.drv»` -then it means this resolver has been mirrored. Whereas an error like +then it means that this resolver has been mirrored and exists in your local copy of the nixpkgs. Whereas an error like `error: attribute ‘lts-3_99’ missing, at (string):1:1` @@ -93,14 +93,14 @@ command-line. See `stack --nix-help` for a list of all Nix options. ## Configuration -`stack.yaml` contains a `nix-shell:` section with Nix settings. +`stack.yaml` contains a `nix:` section with Nix settings. Without this section, Nix will not be used. Here is a commented configuration file, showing the default values: - nix-shell: + nix: - # `true` by default when the nix-shell section is present. Set + # `true` by default when the nix section is present. Set # it to `false` to disable using Nix. enable: true @@ -152,7 +152,7 @@ some build options of the libraries you use. And now for the `stack.yaml` file: ``` -nix-shell: +nix: enable: true shell-file: shell.nix ``` diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 4a4a4a7f8f..3d6bd56eed 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -879,7 +879,7 @@ parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do configMonoidWorkDir <- obj ..:? configMonoidWorkDirName configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) - configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixShellOptsName ..!= mempty) + configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty) configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName @@ -962,8 +962,8 @@ configMonoidWorkDirName = "work-dir" configMonoidDockerOptsName :: Text configMonoidDockerOptsName = "docker" -configMonoidNixShellOptsName :: Text -configMonoidNixShellOptsName = "nix-shell" +configMonoidNixOptsName :: Text +configMonoidNixOptsName = "nix" configMonoidConnectionCountName :: Text configMonoidConnectionCountName = "connection-count" diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index 548b6ae1ce..e7c40b3528 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -70,13 +70,14 @@ instance Monoid NixOptsMonoid where nixEnableArgName :: Text nixEnableArgName = "enable" --- | Nix system packages argument name. +-- | Nix packages (build inputs) argument name. nixPackagesArgName :: Text nixPackagesArgName = "packages" --- | Nix init env file path argument name. +-- | shell.nix file path argument name. nixInitFileArgName :: Text nixInitFileArgName = "shell-file" +-- | Extra options for the nix-shell command argument name. nixShellOptsArgName :: Text nixShellOptsArgName = "nix-shell-options" diff --git a/src/test/Stack/NixShellSpec.hs b/src/test/Stack/NixSpec.hs similarity index 92% rename from src/test/Stack/NixShellSpec.hs rename to src/test/Stack/NixSpec.hs index 6e23706b82..354d6aaae2 100644 --- a/src/test/Stack/NixShellSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell, OverloadedStrings #-} -module Stack.NixShellSpec where +module Stack.NixSpec where import Test.Hspec @@ -26,7 +26,7 @@ sampleConfig :: String sampleConfig = "resolver: lts-2.10\n" ++ "packages: ['.']\n" ++ - "nix-shell:\n" ++ + "nix:\n" ++ " enable: True\n" ++ " packages: [glpk]" @@ -55,8 +55,8 @@ spec = beforeAll setup $ afterAll teardown $ do let enterDir = setCurrentDirectory tempDir exitDir = setCurrentDirectory currentDirectory bracket_ enterDir exitDir action - describe "nix-shell" $ do - it "sees that nix-shell is enabled" $ \T{..} -> inTempDir $ do + describe "nix" $ do + it "sees that the nix shell is enabled" $ \T{..} -> inTempDir $ do writeFile (toFilePath stackDotYaml) sampleConfig lc <- loadConfig' manager (nixEnable $ configNix $ lcConfig lc) `shouldBe` True diff --git a/stack.cabal b/stack.cabal index 5d813e48e7..7db3182c25 100644 --- a/stack.cabal +++ b/stack.cabal @@ -265,7 +265,7 @@ test-suite stack-test , Stack.DotSpec , Stack.PackageDumpSpec , Stack.ArgsSpec - , Stack.NixShellSpec + , Stack.NixSpec , Network.HTTP.Download.VerifiedSpec ghc-options: -Wall -threaded build-depends: base >=4.7 && <5 From 3554309279fac06433d9022cc343ad892434138f Mon Sep 17 00:00:00 2001 From: YPares Date: Wed, 2 Dec 2015 18:43:40 +0100 Subject: [PATCH 56/56] Testing validity of nix: config moved to Config/Nix.hs --- src/Stack/Config/Nix.hs | 30 ++++++++++++++++++++++++++---- src/Stack/Nix.hs | 25 +++---------------------- 2 files changed, 29 insertions(+), 26 deletions(-) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 1c3a0a1176..246719ccc4 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -1,15 +1,22 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} -- | Nix configuration -module Stack.Config.Nix where +module Stack.Config.Nix + (nixOptsFromMonoid + ,StackNixException(..) + ) where import Data.Text (pack) import Data.Maybe +import Data.Typeable import Path import Stack.Types +import Control.Exception.Lifted +import Control.Monad.Catch (throwM,MonadCatch) --- | Interprets DockerOptsMonoid options. -nixOptsFromMonoid :: Monad m => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts + +-- | Interprets NixOptsMonoid options. +nixOptsFromMonoid :: (Monad m, MonadCatch m) => Maybe Project -> Path Abs Dir -> NixOptsMonoid -> m NixOpts nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable nixPackages = case mproject of @@ -20,4 +27,19 @@ nixOptsFromMonoid mproject _stackRoot NixOptsMonoid{..} = do _ -> pack "ghc"] nixInitFile = nixMonoidInitFile nixShellOptions = nixMonoidShellOptions + if not (null nixMonoidPackages) && isJust nixInitFile then + throwM NixCannotUseShellFileAndPackagesException + else return () return NixOpts{..} + +-- Exceptions thown specifically by Stack.Nix +data StackNixException + = NixCannotUseShellFileAndPackagesException + -- ^ Nix can't be given packages and a shell file at the same time + deriving (Typeable) + +instance Exception StackNixException + +instance Show StackNixException where + show NixCannotUseShellFileAndPackagesException = + "You cannot have packages and a shell-file filled at the same time in your nix-shell configuration." diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 54edd9dd54..e8a26bd714 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,18 +1,16 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -- | Run commands in a nix-shell module Stack.Nix (reexecWithOptionalShell ,nixCmdName - ,StackNixException(..) ) where import Control.Applicative -import Control.Exception.Lifted import Control.Monad -import Control.Monad.Catch (throwM,MonadCatch,MonadMask) +import Control.Monad.Catch (try,MonadCatch) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logDebug) import Control.Monad.Reader (MonadReader,asks) @@ -23,7 +21,6 @@ import Data.Maybe import Data.Monoid import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import qualified Data.Text as T -import Data.Typeable import Data.Version (showVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import qualified Paths_stack as Meta @@ -69,10 +66,7 @@ runShellAndExit getCmdArgs = do (cmnd,args) <- getCmdArgs let mshellFile = nixInitFile (configNix config) pkgsInConfig = nixPackages (configNix config) - if not (null pkgsInConfig) && isJust mshellFile then - throwM NixCannotUseShellFileAndPackagesException - else return () - let nixopts = case mshellFile of + nixopts = case mshellFile of Just filePath -> [filePath] Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat [["with (import {});" @@ -132,17 +126,4 @@ type M env m = ,HasTerminal env ,HasReExec env ,HasHttpManager env - ,MonadMask m ) - --- Exceptions thown specifically by Stack.Nix -data StackNixException - = NixCannotUseShellFileAndPackagesException - -- ^ Nix can't be given packages and a shell file at the same time - deriving (Typeable) - -instance Exception StackNixException - -instance Show StackNixException where - show NixCannotUseShellFileAndPackagesException = - "You cannot have packages and a shell-file filled at the same time in your nix-shell configuration."