{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ScopedTypeVariables #-}

-- | Run commands in Docker containers

module Stack.Docker

(dockerCmdName

,dockerHelpOptName

,dockerPullCmdName

,entrypoint

,preventInContainer

,pull

,reset

,reExecArgName

,StackDockerException(..)

,getProjectRoot

,runContainerAndExit

) where

import Stack.Prelude

import qualified Crypto.Hash as Hash (Digest, MD5, hash)

import Pantry.Internal.AesonExtended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)

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 (isAscii,isDigit)

import Data.Conduit.List (sinkNull)

import Data.Conduit.Process.Typed hiding (proc)

import Data.List (dropWhileEnd,isPrefixOf,isInfixOf)

import Data.List.Extra (trim)

import qualified Data.Map.Strict as Map

import qualified Data.Text as T

import qualified Data.Text.Encoding as T

import Data.Time (UTCTime)

import qualified Data.Version (showVersion, parseVersion)

import Distribution.Version (mkVersion, mkVersion')

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.Setup (ensureDockerStackExe)

import Stack.Storage.User (loadDockerImageExeCache,saveDockerImageExeCache)

import Stack.Types.Version

import Stack.Types.Config

import Stack.Types.Docker

import System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)

import qualified System.FilePath as FP

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.Terminal (hIsTerminalDeviceOrMinTTY)

import Text.ParserCombinators.ReadP (readP_to_S)

import RIO.Process

import qualified RIO.Directory

#ifndef WINDOWS

import System.Posix.Signals

import qualified System.Posix.User as PosixUser

#endif

-- | Function to get command and arguments to run in Docker container

getCmdArgs

:: HasConfig env

=> DockerOpts

-> Inspect

-> Bool

-> RIO env (FilePath,[String],[(String,String)],[Mount])

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 ++ "=" ++ Data.Version.showVersion Meta.version

,"--" ++ dockerEntrypointArgName

,show DockerEntrypoint{..}] ++)

(liftIO getArgs)

case dockerStackExe (configDocker config) of

Just DockerStackExeHost

| configPlatform config == dockerContainerPlatform -> do

exePath <- resolveFile' =<< liftIO getExecutablePath

cmdArgs args exePath

| otherwise -> throwIO UnsupportedStackExeHostPlatformException

Just DockerStackExeImage -> do

progName <- liftIO getProgName

return (FP.takeBaseName progName, args, [], [])

Just (DockerStackExePath path) -> do

cmdArgs args path

Just DockerStackExeDownload -> exeDownload args

Nothing

| configPlatform config == dockerContainerPlatform -> do

(exePath,exeTimestamp,misCompatible) <-

do exePath <- resolveFile' =<< liftIO getExecutablePath

exeTimestamp <- getModificationTime exePath

isKnown <-

loadDockerImageExeCache

(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"

, toFilePath exePath ++ ":" ++ "/tmp/stack"

, T.unpack (iiId imageInfo)

, "/tmp/stack"

, "--version"]

sinkNull

sinkNull

let compatible =

case e of

Left ExitCodeException{} -> False

Right _ -> True

saveDockerImageExeCache

(iiId imageInfo)

exePath

exeTimestamp

compatible

if compatible

then cmdArgs args exePath

else exeDownload args

Nothing -> exeDownload args

where

exeDownload args = do

exePath <- ensureDockerStackExe dockerContainerPlatform

cmdArgs args exePath

cmdArgs args exePath = do

-- MSS 2020-04-21 previously used replaceExtension, but semantics changed in path 0.7

-- In any event, I'm not even sure _why_ we need to drop a file extension here

-- Originally introduced here: https://github.com/commercialhaskell/stack/commit/6218dadaf5fd7bf312bb1bd0db63b4784ba78cb2

#if MIN_VERSION_path(0, 7, 0)

let exeBase =

case splitExtension exePath of

Left _ -> exePath

Right (x, _) -> x

#else

exeBase <- exePath -<.> ""

#endif

let mountPath = hostBinDir FP.</> toFilePath (filename exeBase)

return (mountPath, args, [], [Mount (toFilePath exePath) mountPath])

-- | 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 => RIO env void

runContainerAndExit = do

config <- view configL

let docker = configDocker config

checkDockerVersion docker

(env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $

(,,,)

<$> getEnvironment

<*> hIsTerminalDeviceOrMinTTY stdin

<*> hIsTerminalDeviceOrMinTTY stderr

<*> getHomeDir

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

mstackYaml <- for (lookup "STACK_YAML" env) RIO.Directory.makeAbsolute

image <- either throwIO pure (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)

projectRoot <- getProjectRoot

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))

let mpath = T.pack <$> lookupImageEnv "PATH" imageEnvVars

when (isNothing mpath) $ do

logWarn "The Docker image does not set the PATH env var"

logWarn "This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"

newPathEnv <- either throwM return $ augmentPath

[ hostBinDir

, toFilePath (sandboxHomeDir </> relDirDotLocal </> relDirBin)]

mpath

(cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker

pwd <- getCurrentDir

liftIO $ 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))))

let mountSuffix = maybe "" (":" ++) (dockerMountMode docker)

containerID <- withWorkingDir (toFilePath projectRoot) $ trim . decodeUtf8 <$> readDockerProcess

(concat

[["create"

,"-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 ++ mountSuffix

,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot ++ mountSuffix

,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot ++ mountSuffix

,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir ++ mountSuffix

,"-w",toFilePathNoTrailingSep pwd]

,case dockerNetwork docker of

Nothing -> ["--net=host"]

Just name -> ["--net=" ++ name]

,case muserEnv of

Nothing -> []

Just userEnv -> ["-e","USER=" ++ userEnv]

,case msshAuthSock of

Nothing -> []

Just sshAuthSock ->

["-e","SSH_AUTH_SOCK=" ++ sshAuthSock

,"-v",sshAuthSock ++ ":" ++ sshAuthSock]

,case mstackYaml of

Nothing -> []

Just stackYaml ->

["-e","STACK_YAML=" ++ stackYaml

,"-v",stackYaml++ ":" ++ stackYaml ++ ":ro"]

-- 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 mountSuffix) (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])

-- MSS 2018-08-30 can the CPP below be removed entirely, and instead exec the

-- `docker` process so that it can handle the signals directly?

#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 ExitCodeException{eceExitCode} -> exitWith eceExitCode

Right () -> 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 mountSuffix (Mount host container) =

["-v",host ++ ":" ++ container ++ mountSuffix]

sshRelDir = relDirDotSsh

-- | 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 Text Inspect)

inspects [] = return Map.empty

inspects images =

do maybeInspectOut <-

-- not using 'readDockerProcess' as the error from a missing image

-- needs to be recovered.

try (BL.toStrict . fst <$> proc "docker" ("inspect" : images) readProcess_)

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

either throwIO (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 fmap mkVersion' $ parseVersion' $ 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)

-- version is parsed by Data.Version provided code to avoid

-- Cabal's Distribution.Version lack of support for leading zeros in version

parseVersion' = fmap fst . listToMaybe . reverse . readP_to_S Data.Version.parseVersion

-- | Remove the project's Docker sandbox.

reset :: HasConfig env => Bool -> RIO env ()

reset keepHome = do

projectRoot <- getProjectRoot

dockerSandboxDir <- projectDockerSandboxDir projectRoot

liftIO (removeDirectoryContents

dockerSandboxDir

[homeDirName | keepHome]

[])

-- | 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 </> relDirDotStackProgName

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

return True

where

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.

--

-- The stderr output is passed straight through, which is desirable for some cases

-- e.g. docker pull, in which docker uses stderr for progress output.

--

-- Use 'readProcess_' directly to customize this.

readDockerProcess

:: (HasProcessContext env, HasLogFunc env)

=> [String] -> RIO env BS.ByteString

readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_

-- | Name of home directory within docker sandbox.

homeDirName :: Path Rel Dir

homeDirName = relDirUnderHome

-- | Directory where 'stack' executable is bind-mounted in Docker container

-- This refers to a path in the Linux *container*, and so should remain a

-- 'FilePath' (not 'Path Abs Dir') so that it works when the host runs Windows.

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.

getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)

getProjectRoot = do

mroot <- view $ configL.to configProjectRoot

maybe (throwIO CannotDetermineProjectRootException) pure mroot

-- | 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"

-- | Parsed result of @docker inspect@.

data Inspect = Inspect

{iiConfig :: ImageConfig

,iiCreated :: UTCTime

,iiId :: Text

,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") .!= []