module Docker.Client.Types (
Endpoint(..)
, URL
, ApiVersion
, ContainerID
, fromContainerID
, toContainerID
, ImageID
, fromImageID
, toImageID
, Timeout(..)
, StatusCode(..)
, Signal(..)
, ContainerDetails(..)
, DockerClientOpts(..)
, defaultClientOpts
, ListOpts(..)
, defaultListOpts
, DockerVersion(..)
, ContainerPortInfo(..)
, Container(..)
, ContainerState(..)
, State(..)
, Digest
, Label(..)
, Tag
, Image(..)
, Entrypoint(..)
, dropImagePrefix
, CreateOpts(..)
, BuildOpts(..)
, defaultBuildOpts
, defaultCreateOpts
, DetachKeys(..)
, StartOpts(..)
, defaultStartOpts
, DeleteOpts(..)
, defaultDeleteOpts
, Timestamp
, TailLogOpt(..)
, LogOpts(..)
, defaultLogOpts
, VolumePermission(..)
, Bind(..)
, Volume(..)
, Device(..)
, ContainerName
, VolumeFrom(..)
, Link(..)
, LogDriverType(..)
, LogDriverOption(..)
, LogDriverConfig(..)
, NetworkMode(..)
, PortType(..)
, Network(..)
, NetworkSettings(..)
, NetworkOptions(..)
, Mount(..)
, PortBinding(..)
, HostPort(..)
, RetryCount
, RestartPolicy(..)
, Isolation(..)
, UTSMode(..)
, HostConfig(..)
, defaultHostConfig
, Ulimit(..)
, ContainerResources(..)
, defaultContainerResources
, Port
, Name
, Value
, EnvVar(..)
, ContainerConfig(..)
, defaultContainerConfig
, ExposedPort(..)
, DeviceWeight(..)
, DeviceRate(..)
, addPortBinding
, addExposedPort
, addBind
, setCmd
, addLink
, addVolume
, addVolumeFrom
, MemoryConstraint(..)
, MemoryConstraintSize(..)
) where
import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
genericToJSON, object, parseJSON, toJSON,
(.!=), (.:), (.:?), (.=))
import qualified Data.Aeson as JSON
import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
import Data.Char (isAlphaNum, toUpper)
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import Data.Scientific (floatingOrInteger)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Prelude hiding (all, tail)
import Text.Read (readMaybe)
data Endpoint =
VersionEndpoint
| ListContainersEndpoint ListOpts
| ListImagesEndpoint ListOpts
| CreateContainerEndpoint CreateOpts (Maybe ContainerName)
| StartContainerEndpoint StartOpts ContainerID
| StopContainerEndpoint Timeout ContainerID
| WaitContainerEndpoint ContainerID
| KillContainerEndpoint Signal ContainerID
| RestartContainerEndpoint Timeout ContainerID
| PauseContainerEndpoint ContainerID
| UnpauseContainerEndpoint ContainerID
| ContainerLogsEndpoint LogOpts Bool ContainerID
| DeleteContainerEndpoint DeleteOpts ContainerID
| InspectContainerEndpoint ContainerID
| BuildImageEndpoint BuildOpts FilePath
| CreateImageEndpoint T.Text Tag (Maybe T.Text)
deriving (Eq, Show)
type URL = Text
type ApiVersion = Text
newtype ContainerID = ContainerID Text
deriving (Eq, Show)
fromContainerID :: ContainerID -> Text
fromContainerID (ContainerID t) = t
toContainerID :: Text -> Maybe ContainerID
toContainerID t =
if T.all (\c -> isAlphaNum c || c == ':') t then
Just $ ContainerID t
else
Nothing
newtype ImageID = ImageID Text
deriving (Eq, Show)
fromImageID :: ImageID -> Text
fromImageID (ImageID t) = t
toImageID :: Text -> Maybe ImageID
toImageID t =
if T.all (\c -> isAlphaNum c || c == ':') t then
Just $ ImageID t
else
Nothing
data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
data StatusCode = StatusCode Int
instance ToJSON StatusCode where
toJSON (StatusCode c) = object ["StatusCode" .= c]
instance FromJSON StatusCode where
parseJSON (JSON.Object o) = do
c <- o .: "StatusCode"
if c >= 0 && c <= 255 then
return (StatusCode c)
else
fail "Unknown exit code"
parseJSON _ = fail "Unknown exit code"
data Signal = SIGHUP
| SIGINT
| SIGQUIT
| SIGSTOP
| SIGTERM
| SIGUSR1
| SIG Integer
| SIGKILL deriving (Eq, Show)
instance FromJSON Signal where
parseJSON (JSON.String "SIGTERM") = return SIGTERM
parseJSON (JSON.String "SIGHUP") = return SIGHUP
parseJSON (JSON.String "SIGINT") = return SIGINT
parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
parseJSON _ = fail "Unknown Signal"
instance ToJSON Signal where
toJSON SIGHUP = "SIGHUP"
toJSON SIGINT = "SIGINT"
toJSON SIGQUIT = "SIGQUIT"
toJSON SIGSTOP = "SIGSTOP"
toJSON SIGTERM = "SIGTERM"
toJSON SIGUSR1 = "SIGUSR1"
toJSON (SIG i) = toJSON i
toJSON SIGKILL = "SIGKILL"
data ContainerDetails = ContainerDetails {
appArmorProfile :: Text
, args :: [Text]
, containerDetailsConfig :: ContainerConfig
, created :: UTCTime
, driver :: Text
, containerDetailsHostConfig :: HostConfig
, hostnamePath :: FilePath
, hostsPath :: FilePath
, logPath :: FilePath
, containerDetailsId :: ContainerID
, containerDetailsImage :: ImageID
, mountLabel :: Text
, name :: Text
, networkSettings :: NetworkSettings
, path :: FilePath
, processLabel :: Text
, resolveConfPath :: FilePath
, restartCount :: Int
, containerDetailsState :: ContainerState
, mounts :: [Mount]
}
deriving (Eq, Show, Generic)
data Mount = Mount {
mountName :: Maybe Text
, mountSource :: FilePath
, mountDestination :: FilePath
, mountDriver :: Maybe Text
, mountRW :: Bool
, mountPropogation :: Text
}
deriving (Eq, Show, Generic)
instance FromJSON Mount where
parseJSON (JSON.Object o) = do
name <- o .:? "Name"
src <- o .: "Source"
dest <- o .: "Destination"
driver <- o .:? "Driver"
rw <- o .: "RW"
prop <- o .: "Propagation"
return $ Mount name src dest driver rw prop
parseJSON _ = fail "Mount is not an object"
data ContainerState = ContainerState {
containerError :: Text
, exitCode :: Int
, finishedAt :: Maybe UTCTime
, oomKilled :: Bool
, dead :: Bool
, paused :: Bool
, pid :: Int
, restarting :: Bool
, running :: Bool
, startedAt :: UTCTime
, state :: State
}
deriving (Eq, Show, Generic)
instance FromJSON ContainerState where
parseJSON (JSON.Object o) = do
err <- o .: "Error"
exit <- o .: "ExitCode"
finished <- o .:? "FinishedAt"
oomKilled <- o .: "OOMKilled"
dead <- o .: "Dead"
paused <- o .: "Paused"
pid <- o .: "Pid"
restarting <- o .: "Restarting"
running <- o .: "Running"
started <- o .: "StartedAt"
st <- o .: "Status"
return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st
parseJSON _ = fail "ContainerState is not an object"
data DockerClientOpts = DockerClientOpts {
apiVer :: ApiVersion
, baseUrl :: URL
}
deriving (Eq, Show)
defaultClientOpts :: DockerClientOpts
defaultClientOpts = DockerClientOpts {
apiVer = "v1.24"
, baseUrl = "http://127.0.0.1:2375"
}
data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
defaultListOpts :: ListOpts
defaultListOpts = ListOpts { all=False }
data DockerVersion = DockerVersion {
version :: Text
, apiVersion :: ApiVersion
, gitCommit :: Text
, goVersion :: Text
, os :: Text
, arch :: Text
, kernelVersion :: Text
, buildTime :: Text
} deriving (Show, Eq, Generic)
instance ToJSON DockerVersion where
toJSON = genericToJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
instance FromJSON DockerVersion where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
instance FromJSON ContainerDetails where
parseJSON v@(JSON.Object o) = do
appArmor <- o .: "AppArmorProfile"
args <- o .: "Args"
config <- o .: "Config"
created <- o .: "Created"
driver <- o .: "Driver"
hostConfig <- o .: "HostConfig"
hostnamePath <- o .: "HostnamePath"
hostsPath <- o .: "HostsPath"
logPath <- o .: "LogPath"
id <- parseJSON v
image <- o .: "Image"
mountLabel <- o .: "MountLabel"
name <- o .: "Name"
networkSettings <- o .: "NetworkSettings"
path <- o .: "Path"
processLabel <- o .: "ProcessLabel"
resolveConfPath <- o .: "ResolvConfPath"
restartCount <- o .: "RestartCount"
state <- o .: "State"
mounts <- o .: "Mounts"
return $ ContainerDetails appArmor args config created driver hostConfig hostnamePath hostsPath logPath id image mountLabel name networkSettings path processLabel resolveConfPath restartCount state mounts
parseJSON _ = fail "ContainerDetails is not an object"
instance ToJSON ContainerID where
toJSON (ContainerID cid) = object ["Id" .= cid]
instance FromJSON ContainerID where
parseJSON (JSON.Object o) = do
cid <- o .: "Id"
case toContainerID cid of
Nothing ->
fail "Invalid ContainerID"
Just cid ->
return cid
parseJSON _ = fail "ContainerID is not an object."
instance ToJSON ImageID where
toJSON (ImageID iid) = JSON.String iid
instance FromJSON ImageID where
parseJSON (JSON.String t) = case toImageID t of
Nothing ->
fail "Invalid ImageID"
Just iid ->
return iid
parseJSON _ = fail "ImageID is not an object."
data ContainerPortInfo = ContainerPortInfo {
ipAddressInfo :: Maybe Text
, privatePortInfo :: Port
, publicPortInfo :: Maybe Port
, portTypeInfo :: Maybe PortType
} deriving (Eq, Show)
instance FromJSON ContainerPortInfo where
parseJSON (JSON.Object v) =
ContainerPortInfo <$> (v .:? "IP")
<*> (v .: "PrivatePort")
<*> (v .:? "PublicPort")
<*> (v .:? "Type")
parseJSON _ = fail "ContainerPortInfo: Not a JSON object."
data NetworkOptions = NetworkOptions {
networkOptionsId :: Text
, networkOptionsEndpointId :: Text
, networkOptionsGateway :: Text
, networkOptionsIpAddress :: Text
, networkOptionsIpPrefixLen :: Int
, networkOptionsIpV6Gateway :: Maybe Text
, networkOptionsGlobalIPv6Address :: Maybe Text
, networkOptionsGlobalIPv6PrefixLen :: Maybe Int
, networkOptionsMacAddress :: Text
} deriving (Eq, Show)
instance FromJSON NetworkOptions where
parseJSON (JSON.Object o) = do
networkId <- o .: "NetworkID"
endpointId <- o .: "EndpointID"
gateway <- o .: "Gateway"
ip <- o .: "IPAddress"
ipLen <- o .: "IPPrefixLen"
ip6Gateway <- o .:? "IPv6Gateway"
globalIP6 <- o .:? "GlobalIPv6Address"
globalIP6Len <- o .:? "GlobalIPv6PrefixLen"
mac <- o .: "MacAddress"
return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac
parseJSON _ = fail "NetworkOptions is not an object"
data Network = Network NetworkMode NetworkOptions
deriving (Eq, Show)
instance FromJSON [Network] where
parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
where
f accM k' v' = do
acc <- accM
k <- parseJSON $ JSON.String k'
v <- parseJSON v'
return $ (Network k v):acc
parseJSON _ = fail "Networks is not an object"
data NetworkSettings = NetworkSettings {
networkSettingsBridge :: Text
, networkSettingsSandboxId :: Text
, networkSettingsHairpinMode :: Bool
, networkSettingsLinkLocalIPv6Address :: Text
, networkSettingsLinkLocalIPv6PrefixLen :: Int
, networkSettingsPorts :: [PortBinding]
, networkSettingsSandboxKey :: Text
, networkSettingsSecondaryIPAddresses :: Maybe [Text]
, networkSettingsSecondaryIPv6Addresses :: Maybe [Text]
, networkSettingsEndpointID :: Text
, networkSettingsGateway :: Text
, networkSettingsGlobalIPv6Address :: Text
, networkSettingsGlobalIPv6PrefixLen :: Int
, networkSettingsIpAddress :: Text
, networkSettingsIpPrefixLen :: Int
, networkSettingsIpv6Gateway :: Text
, networkSettingsMacAddress :: Text
, networkSettingsNetworks :: [Network]
}
deriving (Eq, Show)
instance FromJSON NetworkSettings where
parseJSON (JSON.Object o) = do
bridge <- o .: "Bridge"
sandbox <- o .: "SandboxID"
hairpin <- o .: "HairpinMode"
localIP6 <- o .: "LinkLocalIPv6Address"
localIP6Len <- o .: "LinkLocalIPv6PrefixLen"
ports <- o .: "Ports"
sandboxKey <- o .: "SandboxKey"
secondaryIP <- o .: "SecondaryIPAddresses"
secondayIP6 <- o .: "SecondaryIPv6Addresses"
endpointID <- o .: "EndpointID"
gateway <- o .: "Gateway"
globalIP6 <- o .: "GlobalIPv6Address"
globalIP6Len <- o .: "GlobalIPv6PrefixLen"
ip <- o .: "IPAddress"
ipLen <- o .: "IPPrefixLen"
ip6Gateway <- o .: "IPv6Gateway"
mac <- o .: "MacAddress"
networks <- o .: "Networks"
return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
parseJSON _ = fail "NetworkSettings is not an object."
data Container = Container
{ containerId :: ContainerID
, containerNames :: [Text]
, containerImageName :: Text
, containerImageId :: ImageID
, containerCommand :: Text
, containerCreatedAt :: Int
, containerState :: State
, containerStatus :: Maybe Text
, containerPorts :: [ContainerPortInfo]
, containerLabels :: [Label]
, containerNetworks :: [Network]
, containerMounts :: [Mount]
} deriving (Show, Eq)
instance FromJSON Container where
parseJSON o@(JSON.Object v) =
Container <$> parseJSON o
<*> (v .: "Names")
<*> (v .: "Image")
<*> (v .: "ImageID")
<*> (v .: "Command")
<*> (v .: "Created")
<*> (v .: "State")
<*> (v .: "Status")
<*> (v .: "Ports")
<*> (v .: "Labels")
<*> (v .: "NetworkSettings" >>= parseNetworks)
<*> (v .: "Mounts")
where
parseNetworks (JSON.Object v) =
(v .: "Networks") >>= parseJSON
parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
parseJSON _ = fail "Container: Not a JSON object."
data State = Created | Restarting | Running | Paused | Exited | Dead
deriving (Eq, Show, Generic)
instance FromJSON State where
parseJSON (JSON.String "running") = return Running
parseJSON (JSON.String "created") = return Created
parseJSON (JSON.String "restarting") = return Restarting
parseJSON (JSON.String "paused") = return Paused
parseJSON (JSON.String "exited") = return Exited
parseJSON (JSON.String "dead") = return Dead
parseJSON s = fail $ "Unknown Status: " ++ show s
type Digest = Text
data Label = Label Name Value deriving (Eq, Show)
instance ToJSON [Label] where
toJSON [] = emptyJsonObject
toJSON (l:ls) = toJsonKeyVal (l:ls) key val
where key (Label k _) = T.unpack k
val (Label _ v) = v
instance FromJSON [Label] where
parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
where f accM k v = do
acc <- accM
value <- parseJSON v
return $ (Label k value):acc
parseJSON JSON.Null = return []
parseJSON _ = fail "Failed to parse Labels. Not an object."
type Tag = Text
data Image = DockerImage {
imageId :: ImageID
, imageCreated :: Integer
, imageParentId :: Maybe ImageID
, imageRepoTags :: [Tag]
, imageRepoDigests :: [Digest]
, imageSize :: Integer
, imageVirtualSize :: Integer
, imageLabels :: [Label]
} deriving (Show, Eq, Generic)
dropImagePrefix :: [a] -> [a]
dropImagePrefix = drop 5
instance FromJSON Image where
parseJSON (JSON.Object o) = do
imageId <- o .: "Id"
imageCreated <- o .: "Created"
imageParentId <- o .:? "ParentId"
imageRepoTags <- o .:? "RepoTags" .!= []
imageRepoDigests <- o .:? "RepoDigests" .!= []
imageSize <- o .: "Size"
imageVirtualSize <- o .: "VirtualSize"
imageLabels <- o .:? "Labels" .!= []
return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
parseJSON _ = fail "Failed to parse DockerImage."
data CreateOpts = CreateOpts {
containerConfig :: ContainerConfig
, hostConfig :: HostConfig
} deriving (Eq, Show)
instance ToJSON CreateOpts where
toJSON (CreateOpts cc hc) = do
let ccJSON = toJSON cc
let hcJSON = toJSON hc
case ccJSON of
JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
JSON.Object $ HM.insert "HostConfig" hcJSON o
_ -> error "ContainerConfig is not an object."
defaultContainerConfig :: Text -> ContainerConfig
defaultContainerConfig imageName = ContainerConfig {
hostname=Nothing
, domainname=Nothing
, user=Nothing
, attachStdin=False
, attachStdout=False
, image=imageName
, attachStderr=False
, exposedPorts=[]
, tty=False
, openStdin=False
, stdinOnce=False
, env=[]
, cmd=[]
, volumes=[]
, workingDir=Nothing
, entrypoint=Entrypoint []
, networkDisabled=Nothing
, macAddress=Nothing
, labels=[]
, stopSignal=SIGTERM
}
defaultHostConfig :: HostConfig
defaultHostConfig = HostConfig {
binds=[]
, containerIDFile=Nothing
, logConfig=LogDriverConfig JsonFile []
, networkMode=NetworkBridge
, portBindings=[]
, restartPolicy=RestartOff
, volumeDriver=Nothing
, volumesFrom=[]
, capAdd=[]
, capDrop=[]
, dns=[]
, dnsOptions=[]
, dnsSearch=[]
, extraHosts=[]
, ipcMode=Nothing
, links=[]
, oomScoreAdj=Nothing
, privileged=False
, publishAllPorts=False
, readonlyRootfs=False
, securityOpt=[]
, shmSize=Nothing
, resources=defaultContainerResources
}
defaultContainerResources :: ContainerResources
defaultContainerResources = ContainerResources {
cpuShares=Nothing
, blkioWeight=Nothing
, blkioWeightDevice=Nothing
, blkioDeviceReadBps=Nothing
, blkioDeviceWriteBps=Nothing
, blkioDeviceReadIOps=Nothing
, blkioDeviceWriteIOps=Nothing
, cpuPeriod=Nothing
, cpusetCpus=Nothing
, cpusetMems=Nothing
, devices=[]
, kernelMemory=Nothing
, memory=Nothing
, memoryReservation=Nothing
, memorySwap=Nothing
, oomKillDisable=Just False
, ulimits=[]
}
defaultCreateOpts :: T.Text -> CreateOpts
defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }
data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
defaultStartOpts :: StartOpts
defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
data DeleteOpts = DeleteOpts {
deleteVolumes :: Bool
, force :: Bool
} deriving (Eq, Show)
data BuildOpts = BuildOpts {
buildImageName :: Text
, buildDockerfileName :: Text
, buildQuiet :: Bool
, buildNoCache :: Bool
, buildRemoveItermediate :: Bool
, buildForceRemoveIntermediate :: Bool
, buildPullParent :: Bool
} deriving (Eq, Show)
defaultBuildOpts :: Text -> BuildOpts
defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
, buildDockerfileName = "Dockerfile"
, buildQuiet = False
, buildNoCache = False
, buildRemoveItermediate = True
, buildForceRemoveIntermediate = False
, buildPullParent = False
}
defaultDeleteOpts :: DeleteOpts
defaultDeleteOpts = DeleteOpts { deleteVolumes = False, force = False }
type Timestamp = Integer
data TailLogOpt = Tail Integer | All deriving (Eq, Show)
data LogOpts = LogOpts {
stdout :: Bool
, stderr :: Bool
, since :: Maybe Timestamp
, timestamps :: Bool
, tail :: TailLogOpt
} deriving (Eq, Show)
defaultLogOpts :: LogOpts
defaultLogOpts = LogOpts { stdout = True
, stderr = True
, since = Nothing
, timestamps = True
, tail = All
}
data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
instance ToJSON VolumePermission where
toJSON ReadWrite = "rw"
toJSON ReadOnly = "ro"
instance FromJSON VolumePermission where
parseJSON "rw" = return ReadWrite
parseJSON "ro" = return ReadOnly
parseJSON "RW" = return ReadWrite
parseJSON "RO" = return ReadOnly
parseJSON _ = fail "Failed to parse VolumePermission"
newtype Volume = Volume FilePath deriving (Eq, Show)
instance ToJSON [Volume] where
toJSON [] = emptyJsonObject
toJSON (v:vs) = toJsonKey (v:vs) getKey
where getKey (Volume v) = v
instance FromJSON [Volume] where
parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o
parseJSON (JSON.Null) = return []
parseJSON _ = fail "Volume is not an object"
data Bind = Bind { hostSrc :: Text
, containerDest :: Text
, volumePermission :: Maybe VolumePermission
} deriving (Eq, Show)
instance FromJSON Bind where
parseJSON (JSON.String t) = case T.split (== ':') t of
[src, dest] -> return $ Bind src dest Nothing
[src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite
[src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly
_ -> fail "Could not parse Bind"
parseJSON _ = fail "Bind is not a string"
data Device = Device {
pathOnHost :: FilePath
, pathInContainer :: FilePath
, cgroupPermissions :: Text
} deriving (Eq, Show, Generic)
instance ToJSON Device where
toJSON = genericToJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
instance FromJSON Device where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
type ContainerName = Text
data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq, Show)
instance FromJSON VolumeFrom where
parseJSON (JSON.String t) = case T.split (== ':') t of
[vol] -> return $ VolumeFrom vol Nothing
[vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite
[vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly
_ -> fail "Could not parse VolumeFrom"
parseJSON _ = fail "VolumeFrom is not a string"
instance ToJSON VolumeFrom where
toJSON (VolumeFrom n p) = case p of
Nothing -> toJSON $ n <> ":" <> "rw"
Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
instance ToJSON Bind where
toJSON (Bind src dest mode) = toJSON $ case mode of
Nothing -> T.concat[src, ":", dest]
Just m -> T.concat[src, ":", dest, ":", (T.pack $ show m)]
data Link = Link Text (Maybe Text) deriving (Eq, Show)
instance FromJSON Link where
parseJSON (JSON.String t) = case T.split (== ':') t of
[f] -> return $ Link f Nothing
[f,s] -> return $ Link f $ Just s
_ -> fail "Could not parse Link"
parseJSON _ = fail "Link is not a string"
instance ToJSON Link where
toJSON (Link n1 n2) = toJSON $ case n2 of
Nothing -> T.concat[n1, ":", n1]
Just n -> T.concat[n1, ":", n]
data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
instance FromJSON LogDriverType where
parseJSON (JSON.String "json-file") = return JsonFile
parseJSON (JSON.String "syslog") = return Syslog
parseJSON (JSON.String "journald") = return Journald
parseJSON (JSON.String "gelf") = return Gelf
parseJSON (JSON.String "fluentd") = return Fluentd
parseJSON (JSON.String "awslogs") = return AwsLogs
parseJSON (JSON.String "splunk") = return Splunk
parseJSON (JSON.String "etwlogs") = return Etwlogs
parseJSON (JSON.String "none") = return LoggingDisabled
parseJSON _ = fail "Unknown LogDriverType"
instance ToJSON LogDriverType where
toJSON JsonFile = JSON.String "json-file"
toJSON Syslog = JSON.String "syslog"
toJSON Journald = JSON.String "journald"
toJSON Gelf = JSON.String "gelf"
toJSON Fluentd = JSON.String "fluentd"
toJSON AwsLogs = JSON.String "awslogs"
toJSON Splunk = JSON.String "splunk"
toJSON Etwlogs = JSON.String "etwlogs"
toJSON LoggingDisabled = JSON.String "none"
data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)
instance ToJSON [LogDriverOption] where
toJSON [] = emptyJsonObject
toJSON (o:os) = toJsonKeyVal (o:os) key val
where key (LogDriverOption n _) = T.unpack n
val (LogDriverOption _ v) = v
instance FromJSON [LogDriverOption] where
parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
where f accM k v = do
acc <- accM
value <- parseJSON v
return $ (LogDriverOption k value):acc
parseJSON JSON.Null = return []
parseJSON _ = fail "Failed to parse LogDriverOptions"
data LogDriverConfig = LogDriverConfig LogDriverType [LogDriverOption] deriving (Eq, Show)
instance ToJSON LogDriverConfig where
toJSON (LogDriverConfig driverType []) = object ["Type" .= driverType]
toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions]
instance FromJSON LogDriverConfig where
parseJSON (JSON.Object o) = do
typ <- o .: "Type"
opts <- o .: "Config"
return $ LogDriverConfig typ opts
parseJSON _ = fail "LogDriverConfig is not an object"
data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text
deriving (Eq, Show, Ord)
instance FromJSON NetworkMode where
parseJSON (JSON.String "bridge") = return NetworkBridge
parseJSON (JSON.String "host") = return NetworkHost
parseJSON (JSON.String "none") = return NetworkDisabled
parseJSON (JSON.String n) = return $ NetworkNamed n
parseJSON _ = fail "Unknown NetworkMode"
instance ToJSON NetworkMode where
toJSON NetworkBridge = JSON.String "bridge"
toJSON NetworkHost = JSON.String "host"
toJSON NetworkDisabled = JSON.String "none"
toJSON (NetworkNamed n) = JSON.String n
data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
instance Show PortType where
show TCP = "tcp"
show UDP = "udp"
instance ToJSON PortType where
toJSON TCP = "tcp"
toJSON UDP = "udp"
instance FromJSON PortType where
parseJSON val = case val of
"tcp" -> return TCP
"udp" -> return UDP
_ -> fail "PortType: Invalid port type."
data PortBinding = PortBinding {
containerPort :: Port
, portType :: PortType
, hostPorts :: [HostPort]
} deriving (Eq, Show)
portAndType2Text :: Port -> PortType -> Text
portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t)
addBind :: Bind -> CreateOpts -> CreateOpts
addBind b c = c{hostConfig=hc{binds=obs <> [b]}}
where hc = hostConfig c
obs = binds $ hostConfig c
setCmd :: Text -> CreateOpts -> CreateOpts
setCmd ccmd c = c{containerConfig=cc{cmd=[ccmd]}}
where cc = containerConfig c
addLink :: Link -> CreateOpts -> CreateOpts
addLink l c = c{hostConfig=hc{links=ols <> [l]}}
where hc = hostConfig c
ols = links $ hostConfig c
addVolume :: Volume -> CreateOpts -> CreateOpts
addVolume v c = c{containerConfig=cc{volumes=oldvs <> [v]}}
where cc = containerConfig c
oldvs = volumes cc
addVolumeFrom :: VolumeFrom -> CreateOpts -> CreateOpts
addVolumeFrom vf c = c{hostConfig=hc{volumesFrom=oldvfs <> [vf]}}
where hc = hostConfig c
oldvfs = volumesFrom hc
addPortBinding :: PortBinding -> CreateOpts -> CreateOpts
addPortBinding pb c = c{hostConfig=hc{portBindings=pbs <> [pb]}}
where hc = hostConfig c
pbs = portBindings $ hostConfig c
addExposedPort :: ExposedPort -> CreateOpts -> CreateOpts
addExposedPort ep c = c{containerConfig=cc{exposedPorts=oldeps <> [ep]}}
where cc = containerConfig c
oldeps = exposedPorts cc
instance FromJSON [PortBinding] where
parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
where
f accM k v = case T.split (== '/') k of
[port', portType'] -> do
port <- parseIntegerText port'
portType <- parseJSON $ JSON.String portType'
acc <- accM
hps <- parseJSON v
return $ (PortBinding port portType hps):acc
_ -> fail "Could not parse PortBindings"
parseJSON (JSON.Null) = return []
parseJSON _ = fail "PortBindings is not an object"
instance ToJSON [PortBinding] where
toJSON [] = emptyJsonObject
toJSON (p:ps) = toJsonKeyVal (p:ps) key val
where key p = T.unpack $ portAndType2Text (containerPort p) (portType p)
val p = hostPorts p
data HostPort = HostPort {
hostIp :: Text
, hostPost :: Port
}
deriving (Eq, Show)
instance ToJSON HostPort where
toJSON (HostPort i p) = object ["HostPort" .= show p, "HostIp" .= i]
instance FromJSON HostPort where
parseJSON (JSON.Object o) = do
p <- o .: "HostPort" >>= parseIntegerText
i <- o .: "HostIp"
return $ HostPort i p
parseJSON _ = fail "HostPort is not an object."
type RetryCount = Integer
data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
instance FromJSON RestartPolicy where
parseJSON (JSON.Object o) = do
(name :: Text) <- o .: "Name"
case name of
"always" -> return RestartAlways
"unless-stopped" -> return RestartUnlessStopped
"on-failure" -> do
retry <- o .: "MaximumRetryCount"
return $ RestartOnFailure retry
"no" -> return RestartOff
_ -> fail "Could not parse RestartPolicy"
parseJSON _ = fail "RestartPolicy is not an object"
instance ToJSON RestartPolicy where
toJSON RestartAlways = object ["Name" .= JSON.String "always"]
toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
toJSON RestartOff = object ["Name" .= JSON.String "no"]
data Isolation = Default | Process | Hyperv deriving (Eq, Show)
newtype UTSMode = UTSMode Text deriving (Eq, Show)
data HostConfig = HostConfig
{ binds :: [Bind]
, containerIDFile :: Maybe FilePath
, logConfig :: LogDriverConfig
, networkMode :: NetworkMode
, portBindings :: [PortBinding]
, restartPolicy :: RestartPolicy
, volumeDriver :: Maybe Text
, volumesFrom :: [VolumeFrom]
, capAdd :: [Text]
, capDrop :: [Text]
, dns :: [Text]
, dnsOptions :: [Text]
, dnsSearch :: [Text]
, extraHosts :: [Text]
, ipcMode :: Maybe Text
, links :: [Link]
, oomScoreAdj :: Maybe Integer
, privileged :: Bool
, publishAllPorts :: Bool
, readonlyRootfs :: Bool
, securityOpt :: [Text]
, shmSize :: Maybe Integer
, resources :: ContainerResources
} deriving (Eq, Show, Generic)
instance FromJSON HostConfig where
parseJSON v@(JSON.Object o) = HostConfig
<$> o .: "Binds"
<*> o .: "ContainerIDFile"
<*> o .: "LogConfig"
<*> o .: "NetworkMode"
<*> o .: "PortBindings"
<*> o .: "RestartPolicy"
<*> o .: "VolumeDriver"
<*> o .: "VolumesFrom"
<*> o .: "CapAdd"
<*> o .: "CapDrop"
<*> o .: "Dns"
<*> o .: "DnsOptions"
<*> o .: "DnsSearch"
<*> o .: "ExtraHosts"
<*> o .: "IpcMode"
<*> o .:? "Links" .!= []
<*> o .: "OomScoreAdj"
<*> o .: "Privileged"
<*> o .: "PublishAllPorts"
<*> o .: "ReadonlyRootfs"
<*> o .: "SecurityOpt"
<*> o .: "ShmSize"
<*> parseJSON v
parseJSON _ = fail "HostConfig is not an object."
instance ToJSON HostConfig where
toJSON HostConfig{..} =
let arr = [
"Binds" .= binds
, "ContainerIDFile" .= containerIDFile
, "LogConfig" .= logConfig
, "NetworkMode" .= networkMode
, "PortBindings" .= portBindings
, "RestartPolicy" .= restartPolicy
, "VolumeDriver" .= volumeDriver
, "VolumesFrom" .= volumesFrom
, "CapAdd" .= capAdd
, "CapDrop" .= capDrop
, "Dns" .= dns
, "DnsOptions" .= dnsOptions
, "DnsSearch" .= dnsSearch
, "ExtraHosts" .= extraHosts
, "IpcMode" .= ipcMode
, "Links" .= links
, "OomScoreAdj" .= oomScoreAdj
, "Privileged" .= privileged
, "PublishAllPorts" .= publishAllPorts
, "ReadonlyRootfs" .= readonlyRootfs
, "SecurityOpt" .= securityOpt
, "ShmSize" .= shmSize
]
in
object $ arr <> ( resourcesArr resources)
where
resourcesArr ContainerResources{..} = [
"CpuShares" .= cpuShares
, "BlkioWeight" .= blkioWeight
, "BlkioWeightDevice" .= blkioWeightDevice
, "BlkioDeviceReadBps" .= blkioDeviceReadBps
, "BlkioDeviceWriteBps" .= blkioDeviceWriteBps
, "BlkioDeviceReadIOps" .= blkioDeviceReadIOps
, "BlkioDeviceWriteIOps" .= blkioDeviceWriteIOps
, "CpuPeriod" .= cpuPeriod
, "CpusetCpus" .= cpusetCpus
, "CpusetMems" .= cpusetMems
, "Devices" .= devices
, "KernelMemory" .= kernelMemory
, "Memory" .= memory
, "MemoryReservation" .= memoryReservation
, "MemorySwap" .= memorySwap
, "OomKillDisable" .= oomKillDisable
, "Ulimits" .= ulimits
]
data Ulimit = Ulimit {
ulimitName :: Text
, ulimitSoft :: Integer
, ulimitHard :: Integer
} deriving (Eq, Show, Generic)
instance FromJSON Ulimit where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = drop 5}
instance ToJSON Ulimit where
toJSON = genericToJSON defaultOptions {
fieldLabelModifier = drop 5}
data DeviceWeight = DeviceWeight {
deviceWeightPath :: FilePath
, deviceWeightWeight :: Text
}
deriving (Show, Eq)
instance FromJSON DeviceWeight where
parseJSON (JSON.Object o) = DeviceWeight
<$> o .: "Path"
<*> o .: "Weight"
parseJSON _ = fail "DeviceWeight is not an object."
instance ToJSON DeviceWeight where
toJSON (DeviceWeight p w) = object [
"Path" .= p
, "Weight" .= w
]
data DeviceRate = DeviceRate {
deviceRatePath :: FilePath
, deviceRateRate :: Text
}
deriving (Show, Eq)
instance FromJSON DeviceRate where
parseJSON (JSON.Object o) = DeviceRate
<$> o .: "Path"
<*> o .: "Rate"
parseJSON _ = fail "DeviceRate is not an object."
instance ToJSON DeviceRate where
toJSON (DeviceRate p r) = object [
"Path" .= p
, "Rate" .= r
]
data MemoryConstraintSize = B | MB | GB deriving (Eq, Show)
data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)
instance ToJSON MemoryConstraint where
toJSON (MemoryConstraint x B) = toJSON x
toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024
toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024
instance FromJSON MemoryConstraint where
parseJSON (JSON.Number x) = case (floatingOrInteger x) of
Left (_ :: Double) -> fail "Failed to parse MemoryConstraint"
Right i -> return $ MemoryConstraint i B
parseJSON _ = fail "Failed to parse MemoryConstraint"
data ContainerResources = ContainerResources {
cpuShares :: Maybe Integer
, blkioWeight :: Maybe Integer
, blkioWeightDevice :: Maybe [DeviceWeight]
, blkioDeviceReadBps :: Maybe [DeviceRate]
, blkioDeviceWriteBps :: Maybe [DeviceRate]
, blkioDeviceReadIOps :: Maybe [DeviceRate]
, blkioDeviceWriteIOps :: Maybe [DeviceRate]
, cpuPeriod :: Maybe Integer
, cpusetCpus :: Maybe Text
, cpusetMems :: Maybe Text
, devices :: [Device]
, kernelMemory :: Maybe MemoryConstraint
, memory :: Maybe MemoryConstraint
, memoryReservation :: Maybe MemoryConstraint
, memorySwap :: Maybe MemoryConstraint
, oomKillDisable :: Maybe Bool
, ulimits :: [Ulimit]
} deriving (Eq, Show, Generic)
instance FromJSON ContainerResources where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
type Port = Integer
type Name = Text
type Value = Text
data EnvVar = EnvVar Name Value
deriving (Eq, Show)
instance FromJSON EnvVar where
parseJSON (JSON.String env) =
let (n, v') = T.break (== '=') env in
let v = T.drop 1 v' in
return $ EnvVar n v
parseJSON _ = fail "EnvVar is not a string"
instance ToJSON EnvVar where
toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v
data ExposedPort = ExposedPort Port PortType deriving (Eq, Show)
instance FromJSON [ExposedPort] where
parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
where
f accM k _ = case T.split (== '/') k of
[port', portType'] -> do
port <- parseIntegerText port'
portType <- parseJSON $ JSON.String portType'
acc <- accM
return $ (ExposedPort port portType):acc
_ -> fail "Could not parse ExposedPorts"
parseJSON (JSON.Null) = return []
parseJSON _ = fail "ExposedPorts is not an object"
instance ToJSON [ExposedPort] where
toJSON [] = emptyJsonObject
toJSON (p:ps) = toJsonKey (p:ps) key
where key (ExposedPort p t) = show p <> slash <> show t
slash = T.unpack "/"
data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)
instance ToJSON Entrypoint where
toJSON (Entrypoint (e:es)) = toJSON (e:es)
toJSON (Entrypoint []) = JSON.Null
instance FromJSON Entrypoint where
parseJSON (JSON.String e) = return $ Entrypoint [e]
parseJSON (JSON.Array ar) = do
arr <- mapM parseJSON (V.toList ar)
return $ Entrypoint arr
parseJSON JSON.Null = return $ Entrypoint []
parseJSON _ = fail "Failed to parse Entrypoint"
data ContainerConfig = ContainerConfig {
hostname :: Maybe Text
, domainname :: Maybe Text
, user :: Maybe Text
, attachStdin :: Bool
, attachStdout :: Bool
, attachStderr :: Bool
, exposedPorts :: [ExposedPort]
, tty :: Bool
, openStdin :: Bool
, stdinOnce :: Bool
, env :: [EnvVar]
, cmd :: [Text]
, image :: Text
, volumes :: [Volume]
, workingDir :: Maybe FilePath
, entrypoint :: Entrypoint
, networkDisabled :: Maybe Bool
, macAddress :: Maybe Text
, labels :: [Label]
, stopSignal :: Signal
} deriving (Eq, Show, Generic)
instance ToJSON ContainerConfig where
toJSON = genericToJSON defaultOptions {
fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
instance FromJSON ContainerConfig where
parseJSON (JSON.Object o) = do
hostname <- o .:? "Hostname"
domainname <- o .:? "Domainname"
user <- o .:? "User"
attachStdin <- o .: "AttachStdin"
attachStdout <- o .: "AttachStdout"
attachStderr <- o .: "AttachStderr"
exposedPorts <- o .:? "ExposedPorts" .!= []
tty <- o .: "Tty"
openStdin <- o .: "OpenStdin"
stdinOnce <- o .: "StdinOnce"
env <- o .: "Env"
cmd <- o .: "Cmd"
image <- o .: "Image"
volumes <- o .: "Volumes"
workingDir <- o .:? "WorkingDir"
entrypoint <- o .: "Entrypoint"
networkDisabled <- o .:? "networkDisabled"
macAddress <- o .:? "MacAddress"
labels <- o .:? "Labels" .!= []
stopSignal <- o .: "StopSignal"
return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled
macAddress labels stopSignal
parseJSON _ = fail "NetworkSettings is not an object."
parseIntegerText :: (Monad m) => Text -> m Integer
parseIntegerText t = case readMaybe $ T.unpack t of
Nothing ->
fail "Could not parse Integer"
Just i ->
return i
toJsonKey :: Foldable t => t a -> (a -> String) -> JSON.Value
toJsonKey vs getKey = JSON.Object $ foldl f HM.empty vs
where f acc x = HM.insert (T.pack $ getKey x) (JSON.Object HM.empty) acc
toJsonKeyVal :: (Foldable t, JSON.ToJSON r) => t a -> (a -> String) -> (a -> r) -> JSON.Value
toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
where f acc x = HM.insert (T.pack $ getKey x) (toJSON $ getVal x) acc
emptyJsonObject :: JSON.Value
emptyJsonObject = JSON.Object HM.empty