{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
             OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables,
             TemplateHaskell, TupleSections #-}

-- | Run commands in Docker containers
module Stack.Docker
  (cleanup
  ,CleanupOpts(..)
  ,CleanupAction(..)
  ,dockerCleanupCmdName
  ,dockerCmdName
  ,dockerHelpOptName
  ,dockerPullCmdName
  ,entrypoint
  ,preventInContainer
  ,pull
  ,reexecWithOptionalContainer
  ,reset
  ,reExecArgName
  ,StackDockerException(..)
  ) where

import           Stack.Prelude
import           Control.Monad.Writer (execWriter,runWriter,tell)
import qualified Crypto.Hash as Hash (Digest, MD5, hash)
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 as BL
import qualified Data.ByteString.Lazy.Char8 as LBS
import           Data.Char (isSpace,toUpper,isAscii,isDigit)
import           Data.Conduit.List (sinkNull)
import           Data.Conduit.Process.Typed hiding (proc)
import           Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf)
import           Data.List.Extra (trim)
import qualified Data.Map.Strict as Map
import           Data.Ord (Down(..))
import           Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))
import           Data.Version (showVersion)
import           GHC.Exts (sortWith)
import           Lens.Micro (set)
import           Path
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO hiding (canonicalizePath)
import qualified Paths_stack as Meta
import           Stack.Config (getInContainer)
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Docker.GlobalDB
import           Stack.PackageIndex
import           Stack.Types.PackageIndex
import           Stack.Types.Runner
import           Stack.Types.Version
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Setup (ensureDockerStackExe)
import           System.Directory (canonicalizePath,getHomeDirectory)
import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)
import           System.Exit (exitSuccess, exitWith, ExitCode(..))
import qualified System.FilePath as FP
import           System.IO (stderr,stdin,stdout)
import           System.IO.Error (isDoesNotExistError)
import           System.IO.Unsafe (unsafePerformIO)
import qualified System.PosixCompat.User as User
import qualified System.PosixCompat.Files as Files
import           System.Process.PagerEditor (editByteString)
import           RIO.Process
import           Text.Printf (printf)

#ifndef WINDOWS
import           System.Posix.Signals
import qualified System.Posix.User as PosixUser
#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
-- transferring 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
    :: HasConfig env
    => Maybe (Path Abs Dir)
    -> Maybe (RIO env ())
    -> IO ()
    -> Maybe (RIO env ())
    -> Maybe (RIO env ())
    -> RIO env ()
reexecWithOptionalContainer mprojectRoot =
    execWithOptionalContainer mprojectRoot getCmdArgs
  where
    getCmdArgs docker imageInfo isRemoteDocker = do
        config <- view configL
        deUser <-
            if fromMaybe (not isRemoteDocker) (dockerSetUser docker)
                then liftIO $ do
                  duUid <- User.getEffectiveUserID
                  duGid <- User.getEffectiveGroupID
                  duGroups <- nubOrd <$> User.getGroups
                  duUmask <- Files.setFileCreationMask 0o022
                  -- Only way to get old umask seems to be to change it, so set it back afterward
                  _ <- Files.setFileCreationMask duUmask
                  return (Just DockerUser{..})
                else return Nothing
        args <-
            fmap
                (["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version
                 ,"--" ++ dockerEntrypointArgName
                 ,show DockerEntrypoint{..}] ++)
                (liftIO getArgs)
        case dockerStackExe (configDocker config) of
            Just DockerStackExeHost
              | configPlatform config == dockerContainerPlatform -> do
                  exePath <- liftIO getExecutablePath
                  cmdArgs args exePath
              | otherwise -> throwIO UnsupportedStackExeHostPlatformException
            Just DockerStackExeImage -> do
                progName <- liftIO getProgName
                return (FP.takeBaseName progName, args, [], [])
            Just (DockerStackExePath path) -> do
                exePath <- liftIO $ canonicalizePath (toFilePath path)
                cmdArgs args exePath
            Just DockerStackExeDownload -> exeDownload args
            Nothing
              | configPlatform config == dockerContainerPlatform -> do
                  (exePath,exeTimestamp,misCompatible) <-
                      liftIO $
                      do exePath <- liftIO getExecutablePath
                         exeTimestamp <- resolveFile' exePath >>= getModificationTime
                         isKnown <-
                             liftIO $
                             getDockerImageExe
                                 config
                                 (iiId imageInfo)
                                 exePath
                                 exeTimestamp
                         return (exePath, exeTimestamp, isKnown)
                  case misCompatible of
                      Just True -> cmdArgs args exePath
                      Just False -> exeDownload args
                      Nothing -> do
                          e <-
                              try $
                              sinkProcessStderrStdout
                                  "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 cmdArgs args exePath
                              else exeDownload args
            Nothing -> exeDownload args
    exeDownload args = do
        exePath <- ensureDockerStackExe dockerContainerPlatform
        cmdArgs args (toFilePath exePath)
    cmdArgs args exePath = do
        let mountPath = hostBinDir FP.</> FP.takeBaseName exePath
        return (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
    :: HasConfig env
    => Maybe (Path Abs Dir)
    -> GetCmdArgs env
    -> Maybe (RIO env ())
    -> IO ()
    -> Maybe (RIO env ())
    -> Maybe (RIO env ())
    -> RIO env ()
execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease =
  do config <- view configL
     inContainer <- getInContainer
     isReExec <- view reExecL
     if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->
            throwIO 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 => m () -> m ()
preventInContainer inner =
  do inContainer <- getInContainer
     if inContainer
        then throwIO OnlyOnHostException
        else inner

-- | Run a command in a new Docker container, then exit the process.
runContainerAndExit
  :: HasConfig env
  => GetCmdArgs env
  -> Maybe (Path Abs Dir) -- ^ Project root (maybe)
  -> RIO env ()  -- ^ Action to run before
  -> RIO env ()  -- ^ Action to run after
  -> RIO env ()
runContainerAndExit getCmdArgs
                    mprojectRoot
                    before
                    after = do
     config <- view configL
     let docker = configDocker config
     checkDockerVersion docker
     (env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $
       (,,,)
       <$> getEnvironment
       <*> hIsTerminalDevice stdin
       <*> hIsTerminalDevice stderr
       <*> (parseAbsDir =<< getHomeDirectory)
     isStdoutTerminal <- view terminalL
     let dockerHost = lookup "DOCKER_HOST" env
         dockerCertPath = lookup "DOCKER_CERT_PATH" env
         bamboo = lookup "bamboo_buildKey" env
         jenkins = lookup "JENKINS_HOME" env
         msshAuthSock = lookup "SSH_AUTH_SOCK" env
         muserEnv = lookup "USER" env
         isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost
         image = dockerImage docker
     when (isRemoteDocker &&
           maybe False (isInfixOf "boot2docker") dockerCertPath)
          (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
     maybeImageInfo <- inspect image
     imageInfo@Inspect{..} <- case maybeImageInfo of
       Just ii -> return ii
       Nothing
         | dockerAutoPull docker ->
             do pullImage docker image
                mii2 <- inspect image
                case mii2 of
                  Just ii2 -> return ii2
                  Nothing -> throwM (InspectFailedException image)
         | otherwise -> throwM (NotPulledException image)
     sandboxDir <- projectDockerSandboxDir projectRoot
     let ImageConfig {..} = iiConfig
         imageEnvVars = map (break (== '=')) icEnv
         platformVariant = show $ hashRepoName image
         stackRoot = view stackRootL config
         sandboxHomeDir = sandboxDir </> homeDirName
         isTerm = not (dockerDetach docker) &&
                  isStdinTerminal &&
                  isStdoutTerminal &&
                  isStderrTerminal
         keepStdinOpen = not (dockerDetach docker) &&
                         -- Workaround for https://github.com/docker/docker/issues/12319
                         -- This is fixed in Docker 1.9.1, but will leave the workaround
                         -- in place for now, for users who haven't upgraded yet.
                         (isTerm || (isNothing bamboo && isNothing jenkins))
     hostBinDirPath <- parseAbsDir hostBinDir
     newPathEnv <- either throwM return $ augmentPath
                      ( toFilePath <$>
                      [ hostBinDirPath
                      , sandboxHomeDir </> $(mkRelDir ".local/bin")])
                      (T.pack <$> lookupImageEnv "PATH" imageEnvVars)
     (cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker
     pwd <- getCurrentDir
     liftIO
       (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)
           mapM_ ensureDir [sandboxHomeDir, stackRoot])
     -- Since $HOME is now mounted in the same place in the container we can
     -- just symlink $HOME/.ssh to the right place for the stack docker user
     let sshDir = homeDir </> sshRelDir
     sshDirExists <- doesDirExist sshDir
     sshSandboxDirExists <-
         liftIO
             (Files.fileExist
                 (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)))
     when (sshDirExists && not sshSandboxDirExists)
         (liftIO
             (Files.createSymbolicLink
                 (toFilePathNoTrailingSep sshDir)
                 (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))
     containerID <- withWorkingDir (toFilePath projectRoot) $ trim . decodeUtf8 <$> readDockerProcess
       (concat
         [["create"
          ,"--net=host"
          ,"-e",inContainerEnvVar ++ "=1"
          ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
          ,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant
          ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
          ,"-e","PATH=" ++ T.unpack newPathEnv
          ,"-e","PWD=" ++ toFilePathNoTrailingSep pwd
          ,"-v",toFilePathNoTrailingSep homeDir ++ ":" ++ toFilePathNoTrailingSep homeDir
          ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot
          ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot
          ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir
          ,"-w",toFilePathNoTrailingSep pwd]
         ,case muserEnv of
            Nothing -> []
            Just userEnv -> ["-e","USER=" ++ userEnv]
         ,case msshAuthSock of
            Nothing -> []
            Just sshAuthSock ->
              ["-e","SSH_AUTH_SOCK=" ++ sshAuthSock
              ,"-v",sshAuthSock ++ ":" ++ sshAuthSock]
           -- Disable the deprecated entrypoint in FP Complete-generated images
         ,["--entrypoint=/usr/bin/env"
             | isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&
               (icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||
                 icEntrypoint == ["/root/entrypoint.sh"])]
         ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
         ,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
     run <- askRunInIO
     oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do
       let sigHandler = run $ do
             readProcessNull "docker" ["kill","--signal=" ++ show sig,containerID]
             when (sig `elem` [sigTERM,sigABRT]) $ do
               -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it
               threadDelay 30000000
               readProcessNull "docker" ["kill",containerID]
       oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
       return (sig, oldHandler)
#endif
     let args' = concat [["start"]
                        ,["-a" | not (dockerDetach docker)]
                        ,["-i" | keepStdinOpen]
                        ,[containerID]]
     e <- try (proc "docker" args' $ runProcess_ . setDelegateCtlc False)
         `finally`
         (do unless (dockerPersist docker || dockerDetach docker) $
                 readProcessNull "docker" ["rm","-f",containerID]
                 `catch` (\(_::ExitCodeException) -> return ())
#ifndef WINDOWS
             forM_ oldHandlers $ \(sig,oldHandler) ->
               liftIO $ installHandler sig oldHandler Nothing
#endif
         )
     case e of
       Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
       Right () -> do after
                      liftIO exitSuccess
  where
    -- This is using a hash of the Docker repository (without tag or digest) to ensure
    -- binaries/libraries aren't shared between Docker and host (or incompatible Docker images)
    hashRepoName :: String -> Hash.Digest Hash.MD5
    hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
    lookupImageEnv name vars =
      case lookup name vars of
        Just ('=':val) -> Just val
        _ -> Nothing
    mountArg (Mount host container) = ["-v",host ++ ":" ++ container]
    projectRoot = fromMaybeProjectRoot mprojectRoot
    sshRelDir = $(mkRelDir ".ssh/")

-- | Clean-up old docker images and containers.
cleanup :: HasConfig env => CleanupOpts -> RIO env ()
cleanup opts = do
     config <- view configL
     let docker = configDocker config
     checkDockerVersion docker
     imagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=false"]
     danglingImagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=true"]
     runningContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=running"]
     restartingContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=restarting"]
     exitedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=exited"]
     pausedContainersOut <- readDockerProcess ["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 (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
           (reverse (filter filterPlanLine (lines (LBS.unpack plan'))))
     allImageHashesOut <- readDockerProcess ["images","-aq","--no-trunc"]
     liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut)))
  where
    filterPlanLine line =
      case line of
        c:_ | isSpace c -> False
        _ -> True
    performPlanLine line =
      case filter (not . null) (words (takeWhile (/= '#') line)) of
        [] -> return ()
        (c:_):t:v:_ ->
          do args <- if | toUpper c == 'R' && t == imageStr ->
                            do logInfo $
                                 "Removing image: '" <>
                                 fromString v <>
                                 "'"
                               return ["rmi",v]
                        | toUpper c == 'R' && t == containerStr ->
                            do logInfo $
                                 "Removing container: '" <>
                                 fromString v <>
                                 "'"
                               return ["rm","-f",v]
                        | otherwise -> throwM (InvalidCleanupCommandException line)
             e <- try (readDockerProcess args)
             case e of
               Left ex ->
                 logError $
                   "Could not remove: '" <>
                   fromString v <>
                   "': " <>
                   displayShow (ex :: ExitCodeException)
               Right _ -> return ()
        _ -> throwM (InvalidCleanupCommandException line)
    parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8
      where parseImageRepo :: String -> (String, [String])
            parseImageRepo line =
              case words line of
                repo:tag:hash:_
                  | repo == "<none>" -> (hash,[])
                  | tag == "<none>" -> (hash,[repo])
                  | otherwise -> (hash,[repo ++ ":" ++ tag])
                _ -> impureThrow (InvalidImagesOutputException line)
    parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8
      where parseContainer line =
              case words line of
                hash:image:rest | last:_ <- reverse rest -> (hash,(image,last))
                _ -> impureThrow (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 =
            sortWith (\(_,_,x) -> Down x) .
             mapMaybe (\(h,r) ->
                case Map.lookup h inspectMap of
                    Nothing -> Nothing
                    Just ii -> Just (h,r,iiCreated ii))
        buildSection sectionHead items itemBuilder =
          do let (anyWrote,b) = runWriter (forM items itemBuilder)
             when (or anyWrote) $
                do buildSectionHead sectionHead
                   tell b
        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 :: (HasProcessContext env, HasLogFunc env)
        => String -> RIO env (Maybe Inspect)
inspect image =
  do results <- inspects [image]
     case Map.toList results of
       [] -> return Nothing
       [(_,i)] -> return (Just i)
       _ -> throwIO (InvalidInspectOutputException "expect a single result")

-- | Inspect multiple Docker images and/or containers.
inspects :: (HasProcessContext env, HasLogFunc env)
         => [String] -> RIO env (Map String Inspect)
inspects [] = return Map.empty
inspects images =
  do maybeInspectOut <- try (readDockerProcess ("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 -> throwIO (InvalidInspectOutputException msg)
           Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))
       Left ece
         |  any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> return Map.empty
       Left e -> throwIO e
  where missingImagePrefixes = ["Error: No such image", "Error: No such object:"]

-- | Pull latest version of configured Docker image from registry.
pull :: HasConfig env => RIO env ()
pull =
  do config <- view configL
     let docker = configDocker config
     checkDockerVersion docker
     pullImage docker (dockerImage docker)

-- | Pull Docker image from registry.
pullImage :: (HasProcessContext env, HasLogFunc env)
          => DockerOpts -> String -> RIO env ()
pullImage docker image =
  do logInfo ("Pulling image from registry: '" <> fromString image <> "'")
     when (dockerRegistryLogin docker)
          (do logInfo "You may need to log in."
              proc
                "docker"
                (concat
                   [["login"]
                   ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)
                   ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
                   ,[takeWhile (/= '/') image]])
                runProcess_)
     -- We redirect the stdout of the process to stderr so that the output
     -- of @docker pull@ will not interfere with the output of other
     -- commands when using --auto-docker-pull. See issue #2733.
     ec <- proc "docker" ["pull", image] $ \pc0 -> do
       let pc = setStdout (useHandleOpen stderr)
              $ setStderr (useHandleOpen stderr)
              $ setStdin closed
                pc0
       runProcess pc
     case ec of
       ExitSuccess -> return ()
       ExitFailure _ -> throwIO (PullFailedException image)

-- | Check docker version (throws exception if incorrect)
checkDockerVersion
    :: (HasProcessContext env, HasLogFunc env)
    => DockerOpts -> RIO env ()
checkDockerVersion docker =
  do dockerExists <- doesExecutableExist "docker"
     unless dockerExists (throwIO DockerNotInstalledException)
     dockerVersionOut <- readDockerProcess ["--version"]
     case words (decodeUtf8 dockerVersionOut) of
       (_:_:v:_) ->
         case parseVersionFromString (stripVersion v) of
           Just v'
             | v' < minimumDockerVersion ->
               throwIO (DockerTooOldException minimumDockerVersion v')
             | v' `elem` prohibitedDockerVersions ->
               throwIO (DockerVersionProhibitedException prohibitedDockerVersions v')
             | not (v' `withinRange` dockerRequireDockerVersion docker) ->
               throwIO (BadDockerVersionException (dockerRequireDockerVersion docker) v')
             | otherwise ->
               return ()
           _ -> throwIO InvalidVersionOutputException
       _ -> throwIO InvalidVersionOutputException
  where minimumDockerVersion = $(mkVersion "1.6.0")
        prohibitedDockerVersions = []
        stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v)

-- | Remove the project's Docker sandbox.
reset :: (MonadIO m, MonadReader env m, HasConfig env)
  => Maybe (Path Abs Dir) -> Bool -> m ()
reset maybeProjectRoot keepHome = do
  dockerSandboxDir <- projectDockerSandboxDir projectRoot
  liftIO (removeDirectoryContents
            dockerSandboxDir
            [homeDirName | keepHome]
            [])
  where projectRoot = fromMaybeProjectRoot maybeProjectRoot

-- | The Docker container "entrypoint": special actions performed when first entering
-- a container, such as switching the UID/GID to the "outside-Docker" user's.
entrypoint :: (HasProcessContext env, HasLogFunc env)
           => Config -> DockerEntrypoint -> RIO env ()
entrypoint config@Config{..} DockerEntrypoint{..} =
  modifyMVar_ entrypointMVar $ \alreadyRan -> do
    -- Only run the entrypoint once
    unless alreadyRan $ do
      envOverride <- view processContextL
      homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME"
      -- Get the UserEntry for the 'stack' user in the image, if it exists
      estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $
        User.getUserEntryForName stackUserName
      -- Switch UID/GID if needed, and update user's home directory
      case deUser of
        Nothing -> return ()
        Just (DockerUser 0 _ _ _) -> return ()
        Just du -> withProcessContext envOverride $ updateOrCreateStackUser estackUserEntry0 homeDir du
      case estackUserEntry0 of
        Left _ -> return ()
        Right ue -> do
          -- If the 'stack' user exists in the image, copy any build plans and package indices from
          -- its original home directory to the host's stack root, to avoid needing to download them
          origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue)
          let origStackRoot = origStackHomeDir </> $(mkRelDir ("." ++ stackProgName))
          buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)
          when buildPlanDirExists $ do
            (_, buildPlans) <- listDir (buildPlanDir origStackRoot)
            forM_ buildPlans $ \srcBuildPlan -> do
              let destBuildPlan = buildPlanDir (view stackRootL config) </> filename srcBuildPlan
              exists <- doesFileExist destBuildPlan
              unless exists $ do
                ensureDir (parent destBuildPlan)
                copyFile srcBuildPlan destBuildPlan
          forM_ clIndices $ \pkgIdx -> do
            msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do
               srcIndex <- configPackageIndex (indexName pkgIdx)
               exists <- doesFileExist srcIndex
               return $ if exists
                 then Just srcIndex
                 else Nothing
            case msrcIndex of
              Nothing -> return ()
              Just srcIndex ->
                runRIO config $ do
                  destIndex <- configPackageIndex (indexName pkgIdx)
                  exists <- doesFileExist destIndex
                  unless exists $ do
                    ensureDir (parent destIndex)
                    copyFile srcIndex destIndex
    return True
  where
    CabalLoader {..} = configCabalLoader
    updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do
      case estackUserEntry of
        Left _ -> do
          -- If no 'stack' user in image, create one with correct UID/GID and home directory
          readProcessNull "groupadd"
            ["-o"
            ,"--gid",show duGid
            ,stackUserName]
          readProcessNull "useradd"
            ["-oN"
            ,"--uid",show duUid
            ,"--gid",show duGid
            ,"--home",toFilePathNoTrailingSep homeDir
            ,stackUserName]
        Right _ -> do
          -- If there is already a 'stack' user in the image, adjust its UID/GID and home directory
          readProcessNull "usermod"
            ["-o"
            ,"--uid",show duUid
            ,"--home",toFilePathNoTrailingSep homeDir
            ,stackUserName]
          readProcessNull "groupmod"
            ["-o"
            ,"--gid",show duGid
            ,stackUserName]
      forM_ duGroups $ \gid -> do
        readProcessNull "groupadd"
          ["-o"
          ,"--gid",show gid
          ,"group" ++ show gid]
      -- 'setuid' to the wanted UID and GID
      liftIO $ do
        User.setGroupID duGid
#ifndef WINDOWS
        PosixUser.setGroups duGroups
#endif
        User.setUserID duUid
        _ <- Files.setFileCreationMask duUmask
        return ()
    stackUserName = "stack"::String

-- | MVar used to ensure the Docker entrypoint is performed exactly once
entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar = unsafePerformIO (newMVar False)

-- | 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 <- doesDirExist path
     when isRootDir
          (do (lsd,lsf) <- listDir path
              forM_ lsd
                    (\d -> unless (dirname d `elem` excludeDirs)
                                  (removeDirRecur 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
    :: (HasProcessContext env, HasLogFunc env)
    => [String] -> RIO env BS.ByteString
readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_ -- FIXME stderr isn't logged with logError, should it be?

-- | Name of home directory within docker sandbox.
homeDirName :: Path Rel Dir
homeDirName = $(mkRelDir "_home/")

-- | Directory where 'stack' executable is bind-mounted in Docker container
hostBinDir :: FilePath
hostBinDir = "/opt/host/bin"

-- | Convenience function to decode ByteString to String.
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 bs = T.unpack (T.decodeUtf8 bs)

-- | Fail with friendly error if project root not set.
fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRootException)

-- | Environment variable that contained the old sandbox ID.
-- | Use of this variable is deprecated, and only used to detect old images.
oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"

-- | 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 .: "Config"
               <*> o .: "Created"
               <*> o .: "Id"
               <*> o .:? "VirtualSize"

-- | Parsed @Config@ section of @docker inspect@ output.
data ImageConfig = ImageConfig
  {icEnv :: [String]
  ,icEntrypoint :: [String]}
  deriving (Show)

-- | Parse @Config@ section of @docker inspect@ output.
instance FromJSON ImageConfig where
  parseJSON v =
    do o <- parseJSON v
       ImageConfig
         <$> fmap join (o .:? "Env") .!= []
         <*> fmap join (o .:? "Entrypoint") .!= []

-- | Function to get command and arguments to run in Docker container
type GetCmdArgs env
   = DockerOpts
  -> Inspect
  -> Bool
  -> RIO env (FilePath,[String],[(String,String)],[Mount])