@@ -0,0 +1,1592 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Docker.Client.Types (
5+ Endpoint(..)
6+ , URL
7+ , ApiVersion
8+ , ContainerID
9+ , fromContainerID
10+ , toContainerID
11+ , ImageID
12+ , fromImageID
13+ , toImageID
14+ , NetworkID
15+ , fromNetworkID
16+ , toNetworkID
17+ , Timeout(..)
18+ , StatusCode(..)
19+ , Signal(..)
20+ , ContainerDetails(..)
21+ , DockerClientOpts(..)
22+ , defaultClientOpts
23+ , ListOpts(..)
24+ , defaultListOpts
25+ , DockerVersion(..)
26+ , ContainerPortInfo(..)
27+ , Container(..)
28+ , ContainerState(..)
29+ , State(..)
30+ , Digest
31+ , Label(..)
32+ , Tag
33+ , Image(..)
34+ , Entrypoint(..)
35+ , dropImagePrefix
36+ , CreateOpts(..)
37+ , BuildOpts(..)
38+ , defaultBuildOpts
39+ , defaultCreateOpts
40+ , DetachKeys(..)
41+ , StartOpts(..)
42+ , defaultStartOpts
43+ , ContainerDeleteOpts(..)
44+ , defaultContainerDeleteOpts
45+ , ImageDeleteOpts(..)
46+ , defaultImageDeleteOpts
47+ , Timestamp
48+ , TailLogOpt(..)
49+ , LogOpts(..)
50+ , defaultLogOpts
51+ , CreateNetworkOpts(..)
52+ , defaultCreateNetworkOpts
53+ , VolumePermission(..)
54+ , Bind(..)
55+ , Volume(..)
56+ , Device(..)
57+ , ContainerName
58+ , VolumeFrom(..)
59+ , Link(..)
60+ , LogDriverType(..)
61+ , LogDriverOption(..)
62+ , LogDriverConfig(..)
63+ , NetworkMode(..)
64+ , PortType(..)
65+-- , NetworkInterface(..)
66+ , Network(..)
67+ , NetworkSettings(..)
68+ , NetworkOptions(..)
69+ , Mount(..)
70+ , PortBinding(..)
71+ , HostPort(..)
72+ , RetryCount
73+ , RestartPolicy(..)
74+ , Isolation(..)
75+ , UTSMode(..)
76+ , HostConfig(..)
77+ , defaultHostConfig
78+ , NetworkingConfig(..)
79+ , EndpointConfig(..)
80+ , Ulimit(..)
81+ , ContainerResources(..)
82+ , defaultContainerResources
83+ , Port
84+ , Name
85+ , Value
86+ , EnvVar(..)
87+ , ContainerConfig(..)
88+ , defaultContainerConfig
89+ , ExposedPort(..)
90+ , DeviceWeight(..)
91+ , DeviceRate(..)
92+ , addPortBinding
93+ , addExposedPort
94+ , addBind
95+ , setCmd
96+ , addLink
97+ , addVolume
98+ , addVolumeFrom
99+ , MemoryConstraint(..)
100+ , MemoryConstraintSize(..)
101+ ) where
102+
103+import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
104+ genericToJSON, object, parseJSON, toJSON,
105+ (.!=), (.:), (.:?), (.=))
106+import qualified Data.Aeson as JSON
107+import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
108+import Data.Char (isAlphaNum, toUpper)
109+import qualified Data.HashMap.Strict as HM
110+import Data.Monoid ((<>))
111+import Data.Scientific (floatingOrInteger)
112+import Data.Text (Text)
113+import qualified Data.Text as T
114+import Data.Time.Clock (UTCTime)
115+import qualified Data.Vector as V
116+import GHC.Generics (Generic)
117+import Prelude hiding (all, tail)
118+import Text.Read (readMaybe)
119+
120+-- | List of Docker Engine API endpoints
121+data Endpoint =
122+ VersionEndpoint
123+ | ListContainersEndpoint ListOpts
124+ | ListImagesEndpoint ListOpts
125+ | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
126+ | StartContainerEndpoint StartOpts ContainerID
127+ | StopContainerEndpoint Timeout ContainerID
128+ | WaitContainerEndpoint ContainerID
129+ | KillContainerEndpoint Signal ContainerID
130+ | RestartContainerEndpoint Timeout ContainerID
131+ | PauseContainerEndpoint ContainerID
132+ | UnpauseContainerEndpoint ContainerID
133+ | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.
134+ -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
136+ | InspectContainerEndpoint ContainerID
137+ | BuildImageEndpoint BuildOpts FilePath
138+ | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)
139+ | DeleteImageEndpoint ImageDeleteOpts ImageID
140+ | CreateNetworkEndpoint CreateNetworkOpts
141+ | RemoveNetworkEndpoint NetworkID
142+ deriving (Eq, Show)
143+
144+-- | We should newtype this
145+type URL = Text
146+
147+-- | We should newtype this
148+type ApiVersion = Text
149+
150+
151+-- | ID of a contianer
152+newtype ContainerID = ContainerID Text
153+ deriving (Eq, Show)
154+
155+-- | Used for extracting the id of the container from the newtype
156+fromContainerID :: ContainerID -> Text
157+fromContainerID (ContainerID t) = t
158+
159+-- | Used for parsing a Text value into a ContainerID. We apply some basic
160+-- validation here.
161+toContainerID :: Text -> Maybe ContainerID
162+toContainerID t =
163+ if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
164+ Just $ ContainerID t
165+ else
166+ Nothing
167+
168+-- ID of an image.
169+newtype ImageID = ImageID Text
170+ deriving (Eq, Show)
171+
172+-- | Used for extracting the id of the image from the newtype.
173+fromImageID :: ImageID -> Text
174+fromImageID (ImageID t) = t
175+
176+-- | Helper function used for parsing a Text value into an ImageID. For now
177+-- just basic validation is used.
178+toImageID :: Text -> Maybe ImageID
179+toImageID t =
180+ if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
181+ Just $ ImageID t
182+ else
183+ Nothing
184+
185+-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
186+data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
187+
188+data StatusCode = StatusCode Int
189+
190+instance ToJSON StatusCode where
191+ toJSON (StatusCode c) = object ["StatusCode" .= c]
192+
193+instance FromJSON StatusCode where
194+ parseJSON (JSON.Object o) = do
195+ c <- o .: "StatusCode"
196+ if c >= 0 && c <= 255 then
197+ return (StatusCode c)
198+ else
199+ fail "Unknown exit code"
200+ parseJSON _ = fail "Unknown exit code"
201+
202+-- TODO: Add more Signals or use an existing lib
203+-- | Signal used for sending to the process running in the container.
204+-- The default signal is SIGTERM.
205+data Signal = SIGHUP
206+ | SIGINT
207+ | SIGQUIT
208+ | SIGSTOP
209+ | SIGTERM
210+ | SIGUSR1
211+ | SIG Integer
212+ | SIGKILL deriving (Eq, Show)
213+
214+instance FromJSON Signal where
215+ parseJSON (JSON.String "SIGTERM") = return SIGTERM
216+ parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
217+ parseJSON (JSON.String "SIGINT") = return SIGINT
218+ parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
219+ parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
220+ parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
221+ parseJSON _ = fail "Unknown Signal"
222+
223+instance ToJSON Signal where
224+ toJSON SIGHUP = "SIGHUP"
225+ toJSON SIGINT = "SIGINT"
226+ toJSON SIGQUIT = "SIGQUIT"
227+ toJSON SIGSTOP = "SIGSTOP"
228+ toJSON SIGTERM = "SIGTERM"
229+ toJSON SIGUSR1 = "SIGUSR1"
230+ toJSON (SIG i) = toJSON i
231+ toJSON SIGKILL = "SIGKILL"
232+
233+data ContainerDetails = ContainerDetails {
234+ appArmorProfile :: Text
235+ , args :: [Text]
236+ , containerDetailsConfig :: ContainerConfig
237+ , created :: UTCTime
238+ , driver :: Text
239+ -- , execIDs -- Not sure what this is in 1.24 spec.
240+ , containerDetailsHostConfig :: HostConfig
241+ , hostnamePath :: FilePath
242+ , hostsPath :: FilePath
243+ , logPath :: FilePath
244+ , containerDetailsId :: ContainerID
245+ , containerDetailsImage :: ImageID
246+ , mountLabel :: Text
247+ , name :: Text
248+ , networkSettings :: NetworkSettings
249+ , path :: FilePath
250+ , processLabel :: Text
251+ , resolveConfPath :: FilePath
252+ , restartCount :: Int
253+ , containerDetailsState :: ContainerState
254+ , mounts :: [Mount]
255+ }
256+ deriving (Eq, Show, Generic)
257+
258+-- | Data type used for parsing the mount information from a container
259+-- list.
260+data Mount = Mount {
261+ mountName :: Maybe Text -- this is optional
262+ , mountSource :: FilePath
263+ , mountDestination :: FilePath
264+ , mountDriver :: Maybe Text
265+ -- , mountMode :: Maybe VolumePermission -- apparently this can be null
266+ , mountRW :: Bool
267+ , mountPropogation :: Text
268+ }
269+ deriving (Eq, Show, Generic)
270+
271+instance FromJSON Mount where
272+ parseJSON (JSON.Object o) = do
273+ name <- o .:? "Name"
274+ src <- o .: "Source"
275+ dest <- o .: "Destination"
276+ driver <- o .:? "Driver"
277+ -- mode <- o .: "Mode"
278+ rw <- o .: "RW"
279+ prop <- o .: "Propagation"
280+ return $ Mount name src dest driver rw prop
281+ parseJSON _ = fail "Mount is not an object"
282+
283+-- | Data type used for parsing the container state from a list of
284+-- containers.
285+data ContainerState = ContainerState {
286+ containerError :: Text
287+ , exitCode :: Int
288+ , finishedAt :: Maybe UTCTime -- Note: Is this a maybe?
289+ , oomKilled :: Bool
290+ , dead :: Bool
291+ , paused :: Bool
292+ , pid :: Int
293+ , restarting :: Bool
294+ , running :: Bool
295+ , startedAt :: UTCTime
296+ , state :: State
297+ }
298+ deriving (Eq, Show, Generic)
299+
300+instance FromJSON ContainerState where
301+ parseJSON (JSON.Object o) = do
302+ err <- o .: "Error"
303+ exit <- o .: "ExitCode"
304+ finished <- o .:? "FinishedAt"
305+ oomKilled <- o .: "OOMKilled"
306+ dead <- o .: "Dead"
307+ paused <- o .: "Paused"
308+ pid <- o .: "Pid"
309+ restarting <- o .: "Restarting"
310+ running <- o .: "Running"
311+ started <- o .: "StartedAt"
312+ st <- o .: "Status"
313+ return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st
314+ parseJSON _ = fail "ContainerState is not an object"
315+
316+
317+-- | Client options used to configure the remote engine we're talking to
318+data DockerClientOpts = DockerClientOpts {
319+ apiVer :: ApiVersion
320+ , baseUrl :: URL
321+ }
322+ deriving (Eq, Show)
323+
324+-- | Default "DockerClientOpts" used for talking to the docker engine.
325+defaultClientOpts :: DockerClientOpts
326+defaultClientOpts = DockerClientOpts {
327+ apiVer = "v1.24"
328+ , baseUrl = "http://127.0.0.1:2375"
329+ }
330+
331+-- | List options used for filtering the list of container or images.
332+data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
333+
334+-- | Default "ListOpts". Doesn't list stopped containers.
335+defaultListOpts :: ListOpts
336+defaultListOpts = ListOpts { all=False }
337+
338+-- | Data type used for represneting the version of the docker engine
339+-- remote API.
340+data DockerVersion = DockerVersion {
341+ version :: Text
342+ , apiVersion :: ApiVersion
343+ , gitCommit :: Text
344+ , goVersion :: Text
345+ , os :: Text
346+ , arch :: Text
347+ , kernelVersion :: Text
348+ , buildTime :: Text
349+ } deriving (Show, Eq, Generic)
350+
351+
352+instance ToJSON DockerVersion where
353+ toJSON = genericToJSON defaultOptions {
354+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
355+
356+instance FromJSON DockerVersion where
357+ parseJSON = genericParseJSON defaultOptions {
358+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
359+
360+instance FromJSON ContainerDetails where
361+ parseJSON v@(JSON.Object o) = do
362+ appArmor <- o .: "AppArmorProfile"
363+ args <- o .: "Args"
364+ config <- o .: "Config"
365+ created <- o .: "Created"
366+ driver <- o .: "Driver"
367+ hostConfig <- o .: "HostConfig"
368+ hostnamePath <- o .: "HostnamePath"
369+ hostsPath <- o .: "HostsPath"
370+ logPath <- o .: "LogPath"
371+ id <- parseJSON v
372+ image <- o .: "Image"
373+ mountLabel <- o .: "MountLabel"
374+ name <- o .: "Name"
375+ networkSettings <- o .: "NetworkSettings"
376+ path <- o .: "Path"
377+ processLabel <- o .: "ProcessLabel"
378+ resolveConfPath <- o .: "ResolvConfPath"
379+ restartCount <- o .: "RestartCount"
380+ state <- o .: "State"
381+ mounts <- o .: "Mounts"
382+ return $ ContainerDetails appArmor args config created driver hostConfig hostnamePath hostsPath logPath id image mountLabel name networkSettings path processLabel resolveConfPath restartCount state mounts
383+ parseJSON _ = fail "ContainerDetails is not an object"
384+
385+instance ToJSON ContainerID where
386+ toJSON (ContainerID cid) = object ["Id" .= cid]
387+
388+instance FromJSON ContainerID where
389+ parseJSON (JSON.Object o) = do
390+ cid <- o .: "Id"
391+ case toContainerID cid of
392+ Nothing ->
393+ fail "Invalid ContainerID"
394+ Just cid ->
395+ return cid
396+ parseJSON _ = fail "ContainerID is not an object."
397+
398+instance ToJSON ImageID where
399+ toJSON (ImageID iid) = JSON.String iid
400+
401+instance FromJSON ImageID where
402+ parseJSON (JSON.String t) = case toImageID t of
403+ Nothing ->
404+ fail "Invalid ImageID"
405+ Just iid ->
406+ return iid
407+ parseJSON _ = fail "ImageID is not an object."
408+
409+-- | Data type used for representing the information of various ports that
410+-- a contianer may expose.
411+data ContainerPortInfo = ContainerPortInfo {
412+ ipAddressInfo :: Maybe Text
413+ , privatePortInfo :: Port
414+ , publicPortInfo :: Maybe Port
415+ , portTypeInfo :: Maybe PortType
416+ } deriving (Eq, Show)
417+
418+instance FromJSON ContainerPortInfo where
419+ parseJSON (JSON.Object v) =
420+ ContainerPortInfo <$> (v .:? "IP")
421+ <*> (v .: "PrivatePort")
422+ <*> (v .:? "PublicPort")
423+ <*> (v .:? "Type")
424+ parseJSON _ = fail "ContainerPortInfo: Not a JSON object."
425+
426+-- For inspecting container details.
427+-- | Data type used for parsing the network information of each container
428+-- when listing them.
429+data NetworkOptions = NetworkOptions {
430+-- ipamConfig :: Maybe Text -- Don't see in 1.24
431+-- , links :: Maybe Text -- Don't see in 1.24
432+-- , aliases :: Maybe Text -- Don't see in 1.24
433+ networkOptionsId :: Text
434+ , networkOptionsEndpointId :: Text
435+ , networkOptionsGateway :: Text
436+ , networkOptionsIpAddress :: Text -- Note: Parse this?
437+ , networkOptionsIpPrefixLen :: Int
438+ , networkOptionsIpV6Gateway :: Maybe Text
439+ , networkOptionsGlobalIPv6Address :: Maybe Text
440+ , networkOptionsGlobalIPv6PrefixLen :: Maybe Int
441+ , networkOptionsMacAddress :: Text
442+ } deriving (Eq, Show)
443+
444+instance FromJSON NetworkOptions where
445+ parseJSON (JSON.Object o) = do
446+ networkId <- o .: "NetworkID"
447+ endpointId <- o .: "EndpointID"
448+ gateway <- o .: "Gateway"
449+ ip <- o .: "IPAddress"
450+ ipLen <- o .: "IPPrefixLen"
451+ ip6Gateway <- o .:? "IPv6Gateway"
452+ globalIP6 <- o .:? "GlobalIPv6Address"
453+ globalIP6Len <- o .:? "GlobalIPv6PrefixLen"
454+ mac <- o .: "MacAddress"
455+ return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac
456+ parseJSON _ = fail "NetworkOptions is not an object"
457+
458+-- TODO: Not sure what this is used for anymore.
459+data Network = Network NetworkMode NetworkOptions
460+ deriving (Eq, Show)
461+
462+instance {-# OVERLAPPING #-} FromJSON [Network] where
463+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
464+ where
465+ f accM k' v' = do
466+ acc <- accM
467+ k <- parseJSON $ JSON.String k'
468+ v <- parseJSON v'
469+ return $ (Network k v):acc
470+ parseJSON _ = fail "Networks is not an object"
471+
472+-- | Data type reprsenting the various network settings a container can have.
473+data NetworkSettings = NetworkSettings {
474+ networkSettingsBridge :: Text
475+ , networkSettingsSandboxId :: Text
476+ , networkSettingsHairpinMode :: Bool
477+ , networkSettingsLinkLocalIPv6Address :: Text
478+ , networkSettingsLinkLocalIPv6PrefixLen :: Int
479+ , networkSettingsPorts :: [PortBinding]
480+ , networkSettingsSandboxKey :: Text
481+ , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
482+ , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
483+ , networkSettingsEndpointID :: Text
484+ , networkSettingsGateway :: Text
485+ , networkSettingsGlobalIPv6Address :: Text
486+ , networkSettingsGlobalIPv6PrefixLen :: Int
487+ , networkSettingsIpAddress :: Text
488+ , networkSettingsIpPrefixLen :: Int
489+ , networkSettingsIpv6Gateway :: Text
490+ , networkSettingsMacAddress :: Text
491+ , networkSettingsNetworks :: [Network]
492+ }
493+ deriving (Eq, Show)
494+
495+instance FromJSON NetworkSettings where
496+ parseJSON (JSON.Object o) = do
497+ bridge <- o .: "Bridge"
498+ sandbox <- o .: "SandboxID"
499+ hairpin <- o .: "HairpinMode"
500+ localIP6 <- o .: "LinkLocalIPv6Address"
501+ localIP6Len <- o .: "LinkLocalIPv6PrefixLen"
502+ ports <- o .: "Ports" -- .!= []
503+ sandboxKey <- o .: "SandboxKey"
504+ secondaryIP <- o .: "SecondaryIPAddresses"
505+ secondayIP6 <- o .: "SecondaryIPv6Addresses"
506+ endpointID <- o .: "EndpointID"
507+ gateway <- o .: "Gateway"
508+ globalIP6 <- o .: "GlobalIPv6Address"
509+ globalIP6Len <- o .: "GlobalIPv6PrefixLen"
510+ ip <- o .: "IPAddress"
511+ ipLen <- o .: "IPPrefixLen"
512+ ip6Gateway <- o .: "IPv6Gateway"
513+ mac <- o .: "MacAddress"
514+ networks <- o .: "Networks"
515+ return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
516+ parseJSON _ = fail "NetworkSettings is not an object."
517+
518+-- | Data type used for parsing a list of containers.
519+data Container = Container
520+ { containerId :: ContainerID
521+ , containerNames :: [Text]
522+ , containerImageName :: Text
523+ , containerImageId :: ImageID
524+ , containerCommand :: Text
525+ , containerCreatedAt :: Int
526+ , containerState :: State
527+ , containerStatus :: Maybe Text
528+ , containerPorts :: [ContainerPortInfo]
529+ , containerLabels :: [Label]
530+ , containerNetworks :: [Network]
531+ , containerMounts :: [Mount]
532+ } deriving (Show, Eq)
533+
534+instance FromJSON Container where
535+ parseJSON o@(JSON.Object v) =
536+ Container <$> parseJSON o
537+ <*> (v .: "Names")
538+ <*> (v .: "Image")
539+ <*> (v .: "ImageID") -- Doesn't exist anymore
540+ <*> (v .: "Command") -- Doesn't exist anymore
541+ <*> (v .: "Created")
542+ <*> (v .: "State")
543+ <*> (v .: "Status")
544+ <*> (v .: "Ports")
545+ <*> (v .: "Labels")
546+ <*> (v .: "NetworkSettings" >>= parseNetworks)
547+ <*> (v .: "Mounts")
548+ where
549+ parseNetworks (JSON.Object v) =
550+ (v .: "Networks") >>= parseJSON
551+ parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
552+ parseJSON _ = fail "Container: Not a JSON object."
553+
554+-- | Represents the state of the container life cycle.
555+data State = Created | Restarting | Running | Paused | Exited | Dead
556+ deriving (Eq, Show, Generic)
557+
558+instance FromJSON State where
559+ parseJSON (JSON.String "running") = return Running
560+ parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
561+ parseJSON (JSON.String "restarting") = return Restarting
562+ parseJSON (JSON.String "paused") = return Paused
563+ parseJSON (JSON.String "exited") = return Exited
564+ parseJSON (JSON.String "dead") = return Dead
565+ parseJSON s = fail $ "Unknown Status: " ++ show s
566+
567+-- | Alias for representing a RepoDigest. We could newtype this and add
568+-- some validation.
569+type Digest = Text
570+
571+-- | Container and Image Labels.
572+data Label = Label Name Value deriving (Eq, Show)
573+
574+
575+-- If there are multiple lables with the same Name in the list
576+-- then the last one wins.
577+instance {-# OVERLAPPING #-} ToJSON [Label] where
578+ toJSON [] = emptyJsonObject
579+ toJSON (l:ls) = toJsonKeyVal (l:ls) key val
580+ where key (Label k _) = T.unpack k
581+ val (Label _ v) = v
582+
583+instance {-# OVERLAPPING #-} FromJSON [Label] where
584+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
585+ where f accM k v = do
586+ acc <- accM
587+ value <- parseJSON v
588+ return $ (Label k value):acc
589+ parseJSON JSON.Null = return []
590+ parseJSON _ = fail "Failed to parse Labels. Not an object."
591+
592+-- | Alias for Tags.
593+type Tag = Text
594+
595+-- | Data type used for parsing information from a list of images.
596+data Image = DockerImage {
597+ imageId :: ImageID
598+ , imageCreated :: Integer
599+ , imageParentId :: Maybe ImageID
600+ , imageRepoTags :: [Tag]
601+ , imageRepoDigests :: [Digest]
602+ , imageSize :: Integer
603+ , imageVirtualSize :: Integer
604+ , imageLabels :: [Label]
605+ } deriving (Show, Eq, Generic)
606+
607+-- | Helper function used for dropping the "image" prefix when serializing
608+-- the Image data type to and from json.
609+dropImagePrefix :: [a] -> [a]
610+dropImagePrefix = drop 5
611+
612+
613+instance FromJSON Image where
614+ parseJSON (JSON.Object o) = do
615+ imageId <- o .: "Id"
616+ imageCreated <- o .: "Created"
617+ imageParentId <- o .:? "ParentId"
618+ imageRepoTags <- o .:? "RepoTags" .!= []
619+ imageRepoDigests <- o .:? "RepoDigests" .!= []
620+ imageSize <- o .: "Size"
621+ imageVirtualSize <- o .: "VirtualSize"
622+ imageLabels <- o .:? "Labels" .!= []
623+ return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
624+ parseJSON _ = fail "Failed to parse DockerImage."
625+
626+-- | Alias for Aliases.
627+type Alias = Text
628+
629+-- | EndpointsConfig is container configuration for a specific network
630+newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)
631+
632+instance ToJSON EndpointConfig where
633+ toJSON (EndpointConfig aliases) = JSON.object
634+ [ "Aliases" .= aliases
635+ ]
636+
637+-- | Alias for endpoint name
638+type EndpointName = Text
639+
640+-- | Data type for the NetworkingConfig section of the container settings
641+newtype NetworkingConfig = NetworkingConfig
642+ { endpointsConfig :: HM.HashMap EndpointName EndpointConfig
643+ } deriving (Eq, Show)
644+
645+instance ToJSON NetworkingConfig where
646+ toJSON (NetworkingConfig endpointsConfig) = JSON.object
647+ [ "EndpointsConfig" .= endpointsConfig
648+ ]
649+
650+-- | Options used for creating a Container.
651+data CreateOpts = CreateOpts {
652+ containerConfig :: ContainerConfig
653+ , hostConfig :: HostConfig
654+ , networkingConfig :: NetworkingConfig
655+ } deriving (Eq, Show)
656+
657+instance ToJSON CreateOpts where
658+ toJSON (CreateOpts cc hc nc) = do
659+ let ccJSON = toJSON cc
660+ let hcJSON = toJSON hc
661+ case ccJSON of
662+ JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
663+ let o1 = HM.insert "HostConfig" hcJSON o
664+ let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1
665+ JSON.Object o2
666+ _ -> error "ContainerConfig is not an object." -- This should never happen.
667+
668+-- | Container configuration used for creating a container with sensible
669+-- defaults.
670+defaultContainerConfig :: Text -> ContainerConfig
671+defaultContainerConfig imageName = ContainerConfig {
672+ hostname=Nothing
673+ , domainname=Nothing
674+ , user=Nothing
675+ , attachStdin=False
676+ , attachStdout=False
677+ , image=imageName
678+ , attachStderr=False
679+ , exposedPorts=[]
680+ , tty=False
681+ , openStdin=False
682+ , stdinOnce=False
683+ , env=[]
684+ , cmd=[]
685+ , volumes=[]
686+ , workingDir=Nothing
687+ , entrypoint=Entrypoint []
688+ , networkDisabled=Nothing
689+ , macAddress=Nothing
690+ , labels=[]
691+ , stopSignal=SIGTERM
692+ }
693+
694+-- | Default host confiratuon used for creating a container.
695+defaultHostConfig :: HostConfig
696+defaultHostConfig = HostConfig {
697+ binds=[]
698+ , containerIDFile=Nothing
699+ , logConfig=LogDriverConfig JsonFile []
700+ , networkMode=NetworkBridge
701+ , portBindings=[]
702+ , restartPolicy=RestartOff
703+ , volumeDriver=Nothing
704+ , volumesFrom=[]
705+ , capAdd=[]
706+ , capDrop=[]
707+ , dns=[]
708+ , dnsOptions=[]
709+ , dnsSearch=[]
710+ , extraHosts=[]
711+ , ipcMode=Nothing
712+ , links=[]
713+ , oomScoreAdj=Nothing
714+ , privileged=False
715+ , publishAllPorts=False
716+ , readonlyRootfs=False
717+ , securityOpt=[]
718+ , shmSize=Nothing
719+ , resources=defaultContainerResources
720+ }
721+
722+-- Default container resource contstraints (None).
723+defaultContainerResources :: ContainerResources
724+defaultContainerResources = ContainerResources {
725+ cpuShares=Nothing
726+ , blkioWeight=Nothing
727+ , blkioWeightDevice=Nothing
728+ , blkioDeviceReadBps=Nothing
729+ , blkioDeviceWriteBps=Nothing
730+ , blkioDeviceReadIOps=Nothing
731+ , blkioDeviceWriteIOps=Nothing
732+ , cpuPeriod=Nothing
733+ , cpusetCpus=Nothing
734+ , cpusetMems=Nothing
735+ , devices=[]
736+ , kernelMemory=Nothing
737+ , memory=Nothing
738+ , memoryReservation=Nothing
739+ , memorySwap=Nothing
740+ , oomKillDisable=Just False
741+ , ulimits=[]
742+ }
743+
744+-- | Default create options when creating a container. You only need to
745+-- specify an image name and the rest is all sensible defaults.
746+defaultCreateOpts :: T.Text -> CreateOpts
747+defaultCreateOpts imageName = CreateOpts
748+ { containerConfig = defaultContainerConfig imageName
749+ , hostConfig = defaultHostConfig
750+ , networkingConfig = NetworkingConfig HM.empty
751+ }
752+
753+-- | Override the key sequence for detaching a container.
754+-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
755+data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
756+
757+-- | Options for starting a container.
758+data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
759+
760+-- | Default options for staring a container.
761+defaultStartOpts :: StartOpts
762+defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
763+
764+-- | Options for deleting a container.
765+data ContainerDeleteOpts = ContainerDeleteOpts {
766+ deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
767+ , force :: Bool -- ^ If the container is still running force deletion anyway.
768+ } deriving (Eq, Show)
769+
770+-- TODO: Add support for container build constraints
771+-- | Options for when building images from a Dockerfile
772+data BuildOpts = BuildOpts {
773+ buildImageName :: Text -- ^ Image name in the form of name:tag; ie. myimage:latest.:w
774+ , buildDockerfileName :: Text -- ^ Name of dockerfile (default: Dockerfile)
775+ , buildQuiet :: Bool
776+ , buildNoCache :: Bool -- ^ Do not use cache when building the image.
777+ , buildRemoveItermediate :: Bool -- ^ Remove intermediate containers after a successful build (default true).
778+ , buildForceRemoveIntermediate :: Bool -- ^ Always remove intermediate containers.
779+ , buildPullParent :: Bool -- ^ Always attempt to pull a newer version of the *parent* image (ie. FROM debian:jessie).
780+ } deriving (Eq, Show)
781+
782+defaultBuildOpts :: Text -> BuildOpts
783+defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
784+ , buildDockerfileName = "Dockerfile"
785+ , buildQuiet = False
786+ , buildNoCache = False
787+ , buildRemoveItermediate = True
788+ , buildForceRemoveIntermediate = False
789+ , buildPullParent = False
790+ }
791+
792+-- | Default options for deleting a container. Most of the time we DON'T
793+-- want to delete the container's volumes or force delete it if it's
794+-- running.
795+defaultContainerDeleteOpts :: ContainerDeleteOpts
796+defaultContainerDeleteOpts = ContainerDeleteOpts { deleteVolumes = False, force = False }
797+
798+-- | Image delete opts
799+data ImageDeleteOpts = ImageDeleteOpts deriving (Eq, Show)
800+
801+-- | Sane image deletion defaults
802+defaultImageDeleteOpts :: ImageDeleteOpts
803+defaultImageDeleteOpts = ImageDeleteOpts
804+
805+-- | Timestamp alias.
806+type Timestamp = Integer
807+
808+-- | Used for requesting N number of lines when tailing a containers log
809+-- output.
810+data TailLogOpt = Tail Integer | All deriving (Eq, Show)
811+
812+
813+-- | Log options used when requesting the log output from a container.
814+data LogOpts = LogOpts {
815+ stdout :: Bool
816+ , stderr :: Bool
817+ , since :: Maybe Timestamp
818+ , timestamps :: Bool
819+ , tail :: TailLogOpt
820+ } deriving (Eq, Show)
821+
822+-- | Sensible default for log options.
823+defaultLogOpts :: LogOpts
824+defaultLogOpts = LogOpts { stdout = True
825+ , stderr = True
826+ , since = Nothing
827+ , timestamps = True
828+ , tail = All
829+ }
830+
831+-- | Options for creating a network
832+data CreateNetworkOpts = CreateNetworkOpts
833+ { createNetworkName :: Text -- ^ The network's name
834+ , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.
835+ , createNetworkDriver :: Text -- ^ Name of the network driver plugin to use.
836+ , createNetworkInternal :: Bool -- ^ Restrict external access to the network.
837+ , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.
838+ } deriving (Eq, Show)
839+
840+-- | Sensible defalut for create network options
841+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts
842+defaultCreateNetworkOpts name =
843+ CreateNetworkOpts
844+ { createNetworkName = name
845+ , createNetworkCheckDuplicate = False
846+ , createNetworkDriver = "bridge"
847+ , createNetworkInternal = True
848+ , createNetworkEnableIPv6 = False
849+ }
850+
851+instance ToJSON CreateNetworkOpts where
852+ toJSON opts =
853+ object
854+ [ "Name" .= createNetworkName opts
855+ , "CheckDuplicate" .= createNetworkCheckDuplicate opts
856+ , "Driver" .= createNetworkDriver opts
857+ , "Internal" .= createNetworkInternal opts
858+ , "EnableIPv6" .= createNetworkEnableIPv6 opts
859+ ]
860+
861+-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
862+-- | Set permissions on volumes that you mount in the container.
863+data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
864+
865+instance ToJSON VolumePermission where
866+ toJSON ReadWrite = "rw"
867+ toJSON ReadOnly = "ro"
868+
869+instance FromJSON VolumePermission where
870+ parseJSON "rw" = return ReadWrite
871+ parseJSON "ro" = return ReadOnly
872+ parseJSON "RW" = return ReadWrite
873+ parseJSON "RO" = return ReadOnly
874+ parseJSON _ = fail "Failed to parse VolumePermission"
875+
876+-- | Used for marking a directory in the container as "exposed" hence
877+-- taking it outside of the COW filesystem and making it mountable
878+-- in other containers using "VolumesFrom". The volume usually get's
879+-- created somewhere in @/var/lib/docker/volumes@ (depending on the volume
880+-- driver used).
881+-- The CLI example is:
882+--
883+-- @
884+-- docker run --name app -v \/opt\/data -it myapp:latest
885+-- docker run --name app2 --volumes-from app \/bin\/bash -c "ls -l \/opt\/data"
886+-- @
887+newtype Volume = Volume FilePath deriving (Eq, Show)
888+
889+instance {-# OVERLAPPING #-} ToJSON [Volume] where
890+ toJSON [] = emptyJsonObject
891+ toJSON (v:vs) = toJsonKey (v:vs) getKey
892+ where getKey (Volume v) = v
893+
894+instance {-# OVERLAPPING #-} FromJSON [Volume] where
895+ parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o
896+ parseJSON (JSON.Null) = return []
897+ parseJSON _ = fail "Volume is not an object"
898+
899+
900+data Bind = Bind { hostSrc :: Text
901+ , containerDest :: Text
902+ , volumePermission :: Maybe VolumePermission
903+ } deriving (Eq, Show)
904+
905+instance FromJSON Bind where
906+ parseJSON (JSON.String t) = case T.split (== ':') t of
907+ [src, dest] -> return $ Bind src dest Nothing
908+ [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite
909+ [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly
910+ _ -> fail "Could not parse Bind"
911+ parseJSON _ = fail "Bind is not a string"
912+
913+data Device = Device {
914+ pathOnHost :: FilePath
915+ , pathInContainer :: FilePath
916+ , cgroupPermissions :: Text
917+ } deriving (Eq, Show, Generic)
918+
919+instance ToJSON Device where
920+ toJSON = genericToJSON defaultOptions {
921+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
922+
923+instance FromJSON Device where
924+ parseJSON = genericParseJSON defaultOptions {
925+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
926+
927+type ContainerName = Text
928+
929+data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq, Show)
930+
931+instance FromJSON VolumeFrom where
932+ parseJSON (JSON.String t) = case T.split (== ':') t of
933+ [vol] -> return $ VolumeFrom vol Nothing
934+ [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite
935+ [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly
936+ _ -> fail "Could not parse VolumeFrom"
937+ parseJSON _ = fail "VolumeFrom is not a string"
938+
939+instance ToJSON VolumeFrom where
940+ toJSON (VolumeFrom n p) = case p of
941+ Nothing -> toJSON $ n <> ":" <> "rw"
942+ Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
943+
944+instance ToJSON Bind where
945+ toJSON (Bind src dest mode) = toJSON $ case mode of
946+ Nothing -> T.concat[src, ":", dest]
947+ Just m -> T.concat[src, ":", dest, ":", (T.pack $ show m)]
948+
949+data Link = Link Text (Maybe Text) deriving (Eq, Show)
950+
951+instance FromJSON Link where
952+ parseJSON (JSON.String t) = case T.split (== ':') t of
953+ [f] -> return $ Link f Nothing
954+ [f,s] -> return $ Link f $ Just s
955+ _ -> fail "Could not parse Link"
956+ parseJSON _ = fail "Link is not a string"
957+
958+instance ToJSON Link where
959+ toJSON (Link n1 n2) = toJSON $ case n2 of
960+ Nothing -> T.concat[n1, ":", n1] -- use same name in container
961+ Just n -> T.concat[n1, ":", n] -- used specified name in container
962+
963+-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
964+data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
965+
966+instance FromJSON LogDriverType where
967+ parseJSON (JSON.String "json-file") = return JsonFile
968+ parseJSON (JSON.String "syslog") = return Syslog
969+ parseJSON (JSON.String "journald") = return Journald
970+ parseJSON (JSON.String "gelf") = return Gelf
971+ parseJSON (JSON.String "fluentd") = return Fluentd
972+ parseJSON (JSON.String "awslogs") = return AwsLogs
973+ parseJSON (JSON.String "splunk") = return Splunk
974+ parseJSON (JSON.String "etwlogs") = return Etwlogs
975+ parseJSON (JSON.String "none") = return LoggingDisabled
976+ parseJSON _ = fail "Unknown LogDriverType"
977+
978+instance ToJSON LogDriverType where
979+ toJSON JsonFile = JSON.String "json-file"
980+ toJSON Syslog = JSON.String "syslog"
981+ toJSON Journald = JSON.String "journald"
982+ toJSON Gelf = JSON.String "gelf"
983+ toJSON Fluentd = JSON.String "fluentd"
984+ toJSON AwsLogs = JSON.String "awslogs"
985+ toJSON Splunk = JSON.String "splunk"
986+ toJSON Etwlogs = JSON.String "etwlogs"
987+ toJSON LoggingDisabled = JSON.String "none"
988+
989+data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)
990+
991+instance {-# OVERLAPPING #-} ToJSON [LogDriverOption] where
992+ toJSON [] = emptyJsonObject
993+ toJSON (o:os) = toJsonKeyVal (o:os) key val
994+ where key (LogDriverOption n _) = T.unpack n
995+ val (LogDriverOption _ v) = v
996+
997+instance {-# OVERLAPPING #-} FromJSON [LogDriverOption] where
998+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
999+ where f accM k v = do
1000+ acc <- accM
1001+ value <- parseJSON v
1002+ return $ (LogDriverOption k value):acc
1003+ parseJSON JSON.Null = return []
1004+ parseJSON _ = fail "Failed to parse LogDriverOptions"
1005+
1006+data LogDriverConfig = LogDriverConfig LogDriverType [LogDriverOption] deriving (Eq, Show)
1007+
1008+instance ToJSON LogDriverConfig where
1009+ toJSON (LogDriverConfig driverType []) = object ["Type" .= driverType]
1010+ toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions]
1011+
1012+instance FromJSON LogDriverConfig where
1013+ parseJSON (JSON.Object o) = do
1014+ typ <- o .: "Type"
1015+ opts <- o .: "Config"
1016+ return $ LogDriverConfig typ opts
1017+ parseJSON _ = fail "LogDriverConfig is not an object"
1018+
1019+-- TODO: Add container:<name|id> mode
1020+data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text
1021+ deriving (Eq, Show, Ord)
1022+
1023+instance FromJSON NetworkMode where
1024+ parseJSON (JSON.String "bridge") = return NetworkBridge
1025+ parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these.
1026+ parseJSON (JSON.String "none") = return NetworkDisabled
1027+ parseJSON (JSON.String n) = return $ NetworkNamed n
1028+ parseJSON _ = fail "Unknown NetworkMode"
1029+
1030+instance ToJSON NetworkMode where
1031+ toJSON NetworkBridge = JSON.String "bridge"
1032+ toJSON NetworkHost = JSON.String "host"
1033+ toJSON NetworkDisabled = JSON.String "none"
1034+ toJSON (NetworkNamed n) = JSON.String n
1035+
1036+newtype NetworkID = NetworkID Text
1037+ deriving (Eq, Show)
1038+
1039+-- | Used for extracting the id of the container from the newtype
1040+fromNetworkID :: NetworkID -> Text
1041+fromNetworkID (NetworkID t) = t
1042+
1043+-- | Used for parsing a Text value into a NetworkID.
1044+toNetworkID :: Text -> Maybe NetworkID
1045+toNetworkID t = Just $ NetworkID t
1046+
1047+instance FromJSON NetworkID where
1048+ parseJSON (JSON.Object o) = do
1049+ nid <- o .: "Id"
1050+ return $ NetworkID nid
1051+ parseJSON _ = fail "NetworkID is not an object."
1052+
1053+instance ToJSON NetworkID where
1054+ toJSON (NetworkID nid) = object ["Id" .= nid]
1055+
1056+data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
1057+
1058+instance Show PortType where
1059+ show TCP = "tcp"
1060+ show UDP = "udp"
1061+
1062+instance ToJSON PortType where
1063+ toJSON TCP = "tcp"
1064+ toJSON UDP = "udp"
1065+
1066+instance FromJSON PortType where
1067+ parseJSON val = case val of
1068+ "tcp" -> return TCP
1069+ "udp" -> return UDP
1070+ _ -> fail "PortType: Invalid port type."
1071+
1072+-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
1073+--
1074+-- instance FromJSON NetworkInterface where
1075+-- parseJSON (JSON.String v) = return $ NetworkInterface v
1076+-- parseJSON _ = fail "Network interface is not a string."
1077+--
1078+-- instance ToJSON NetworkInterface where
1079+-- toJSON (NetworkInterface i) = JSON.String i
1080+
1081+-- | This datastructure models mapping a Port from the container onto the
1082+-- host system s that the service running in the container can be accessed from
1083+-- the outside world. We either map a port onto all interfaces (default) or onto a specific
1084+-- interface like `127.0.0.1`.
1085+-- __NOTE__: We should disallow duplicate port bindings as the ToJSON
1086+-- instance will only send the last one.
1087+-- { <port>/<protocol>: [{ "HostPort": "<port>" }] }
1088+data PortBinding = PortBinding {
1089+ containerPort :: Port
1090+ , portType :: PortType
1091+ , hostPorts :: [HostPort]
1092+ } deriving (Eq, Show)
1093+
1094+portAndType2Text :: Port -> PortType -> Text
1095+portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t)
1096+
1097+
1098+-- | A helper function to more easily add a bind mount to existing
1099+-- "CreateOpts" records.
1100+addBind :: Bind -> CreateOpts -> CreateOpts
1101+addBind b c = c{hostConfig=hc{binds=obs <> [b]}}
1102+ where hc = hostConfig c
1103+ obs = binds $ hostConfig c
1104+
1105+-- | Helper function for adding a Command to and existing
1106+-- CreateOpts record.
1107+setCmd :: Text -> CreateOpts -> CreateOpts
1108+setCmd ccmd c = c{containerConfig=cc{cmd=[ccmd]}}
1109+ where cc = containerConfig c
1110+
1111+-- | Helper function for adding a "Link" to and existing
1112+-- CreateOpts record.
1113+addLink :: Link -> CreateOpts -> CreateOpts
1114+addLink l c = c{hostConfig=hc{links=ols <> [l]}}
1115+ where hc = hostConfig c
1116+ ols = links $ hostConfig c
1117+
1118+-- | Helper function for adding a "Volume" to and existing
1119+-- CreateOpts record.
1120+addVolume :: Volume -> CreateOpts -> CreateOpts
1121+addVolume v c = c{containerConfig=cc{volumes=oldvs <> [v]}}
1122+ where cc = containerConfig c
1123+ oldvs = volumes cc
1124+
1125+-- | Helper function for adding a "VolumeFrom" to and existing
1126+-- CreateOpts record.
1127+addVolumeFrom :: VolumeFrom -> CreateOpts -> CreateOpts
1128+addVolumeFrom vf c = c{hostConfig=hc{volumesFrom=oldvfs <> [vf]}}
1129+ where hc = hostConfig c
1130+ oldvfs = volumesFrom hc
1131+
1132+-- | A convenience function that adds PortBindings to and exiting
1133+-- "CreateOpts" record. Useful with 'defaultCreateOpts'
1134+-- Example:
1135+--
1136+-- >>> let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
1137+-- >>> addPortBinding pb $ defaultCreateOpts "nginx:latest"
1138+addPortBinding :: PortBinding -> CreateOpts -> CreateOpts
1139+addPortBinding pb c = c{hostConfig=hc{portBindings=pbs <> [pb]}}
1140+ where hc = hostConfig c
1141+ pbs = portBindings $ hostConfig c
1142+
1143+-- | Helper function for adding a "ExposedPort" to and existing
1144+-- CreateOpts record.
1145+addExposedPort :: ExposedPort -> CreateOpts -> CreateOpts
1146+addExposedPort ep c = c{containerConfig=cc{exposedPorts=oldeps <> [ep]}}
1147+ where cc = containerConfig c
1148+ oldeps = exposedPorts cc
1149+
1150+
1151+instance {-# OVERLAPPING #-} FromJSON [PortBinding] where
1152+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1153+ where
1154+ f accM k v = case T.split (== '/') k of
1155+ [port', portType'] -> do
1156+ port <- parseIntegerText port'
1157+ portType <- parseJSON $ JSON.String portType'
1158+ acc <- accM
1159+ hps <- parseJSON v
1160+ return $ (PortBinding port portType hps):acc
1161+ _ -> fail "Could not parse PortBindings"
1162+ parseJSON (JSON.Null) = return []
1163+ parseJSON _ = fail "PortBindings is not an object"
1164+
1165+instance {-# OVERLAPPING #-} ToJSON [PortBinding] where
1166+ toJSON [] = emptyJsonObject
1167+ toJSON (p:ps) = toJsonKeyVal (p:ps) key val
1168+ where key p = T.unpack $ portAndType2Text (containerPort p) (portType p)
1169+ val p = hostPorts p
1170+
1171+data HostPort = HostPort {
1172+ hostIp :: Text
1173+ , hostPost :: Port
1174+ }
1175+ deriving (Eq, Show)
1176+
1177+instance ToJSON HostPort where
1178+ toJSON (HostPort i p) = object ["HostPort" .= show p, "HostIp" .= i]
1179+
1180+instance FromJSON HostPort where
1181+ parseJSON (JSON.Object o) = do
1182+ p <- o .: "HostPort" >>= parseIntegerText
1183+ i <- o .: "HostIp"
1184+ return $ HostPort i p
1185+ parseJSON _ = fail "HostPort is not an object."
1186+
1187+-- { "Name": "on-failure" , "MaximumRetryCount": 2}
1188+type RetryCount = Integer
1189+data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
1190+
1191+instance FromJSON RestartPolicy where
1192+ parseJSON (JSON.Object o) = do
1193+ (name :: Text) <- o .: "Name"
1194+ case name of
1195+ "always" -> return RestartAlways
1196+ "unless-stopped" -> return RestartUnlessStopped
1197+ "on-failure" -> do
1198+ retry <- o .: "MaximumRetryCount"
1199+ return $ RestartOnFailure retry
1200+ "no" -> return RestartOff
1201+ _ -> fail "Could not parse RestartPolicy"
1202+ parseJSON _ = fail "RestartPolicy is not an object"
1203+
1204+instance ToJSON RestartPolicy where
1205+ toJSON RestartAlways = object ["Name" .= JSON.String "always"]
1206+ toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
1207+ toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
1208+ toJSON RestartOff = object ["Name" .= JSON.String "no"]
1209+
1210+data Isolation = Default | Process | Hyperv deriving (Eq, Show)
1211+
1212+newtype UTSMode = UTSMode Text deriving (Eq, Show)
1213+
1214+-- TODO: Add Tmpfs : List of tmpfs (mounts) used for the container
1215+-- TODO: Add UTSMode : UTS namespace to use for the container
1216+-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container
1217+data HostConfig = HostConfig
1218+ { binds :: [Bind]
1219+ , containerIDFile :: Maybe FilePath -- 1.24: Only in responses, not create
1220+ , logConfig :: LogDriverConfig
1221+ , networkMode :: NetworkMode
1222+ , portBindings :: [PortBinding]
1223+ , restartPolicy :: RestartPolicy
1224+ , volumeDriver :: Maybe Text
1225+ , volumesFrom :: [VolumeFrom]
1226+ , capAdd :: [Text]
1227+ , capDrop :: [Text]
1228+ , dns :: [Text]
1229+ , dnsOptions :: [Text]
1230+ , dnsSearch :: [Text]
1231+ , extraHosts :: [Text]
1232+ -- , groupAdd :: [Integer] -- 1.24: Missing from inspecting container details... Going to omit for now.
1233+ , ipcMode :: Maybe Text -- 1.24: Only in inspect, not create
1234+ , links :: [Link]
1235+ , oomScoreAdj :: Maybe Integer
1236+ -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit
1237+ , privileged :: Bool
1238+ , publishAllPorts :: Bool
1239+ , readonlyRootfs :: Bool
1240+ , securityOpt :: [Text]
1241+ -- , utsMode :: UTSMode -- 1.24: Don't see this
1242+ , shmSize :: Maybe Integer
1243+ -- , consoleSize :: Integer -- 1.24: Don't see this
1244+ -- , isolation :: Isolation -- 1.24: Don't see this
1245+ , resources :: ContainerResources
1246+ } deriving (Eq, Show, Generic)
1247+
1248+instance FromJSON HostConfig where
1249+ parseJSON v@(JSON.Object o) = HostConfig
1250+ <$> o .: "Binds"
1251+ <*> o .: "ContainerIDFile"
1252+ <*> o .: "LogConfig"
1253+ <*> o .: "NetworkMode"
1254+ <*> o .: "PortBindings"
1255+ <*> o .: "RestartPolicy"
1256+ <*> o .: "VolumeDriver"
1257+ <*> o .: "VolumesFrom"
1258+ <*> o .: "CapAdd"
1259+ <*> o .: "CapDrop"
1260+ <*> o .: "Dns"
1261+ <*> o .: "DnsOptions"
1262+ <*> o .: "DnsSearch"
1263+ <*> o .: "ExtraHosts"
1264+ <*> o .: "IpcMode"
1265+ <*> o .:? "Links" .!= []
1266+ <*> o .: "OomScoreAdj"
1267+ <*> o .: "Privileged"
1268+ <*> o .: "PublishAllPorts"
1269+ <*> o .: "ReadonlyRootfs"
1270+ <*> o .: "SecurityOpt"
1271+ <*> o .: "ShmSize"
1272+ <*> parseJSON v
1273+ parseJSON _ = fail "HostConfig is not an object."
1274+
1275+instance ToJSON HostConfig where
1276+ toJSON HostConfig{..} =
1277+ let arr = [
1278+ "Binds" .= binds
1279+ , "ContainerIDFile" .= containerIDFile
1280+ , "LogConfig" .= logConfig
1281+ , "NetworkMode" .= networkMode
1282+ , "PortBindings" .= portBindings
1283+ , "RestartPolicy" .= restartPolicy
1284+ , "VolumeDriver" .= volumeDriver
1285+ , "VolumesFrom" .= volumesFrom
1286+ , "CapAdd" .= capAdd
1287+ , "CapDrop" .= capDrop
1288+ , "Dns" .= dns
1289+ , "DnsOptions" .= dnsOptions
1290+ , "DnsSearch" .= dnsSearch
1291+ , "ExtraHosts" .= extraHosts
1292+ , "IpcMode" .= ipcMode
1293+ , "Links" .= links
1294+ , "OomScoreAdj" .= oomScoreAdj
1295+ , "Privileged" .= privileged
1296+ , "PublishAllPorts" .= publishAllPorts
1297+ , "ReadonlyRootfs" .= readonlyRootfs
1298+ , "SecurityOpt" .= securityOpt
1299+ , "ShmSize" .= shmSize
1300+ ]
1301+ in
1302+ object $ arr <> ( resourcesArr resources)
1303+
1304+ where
1305+ -- JP: Not sure if this is better than a separate ToJSON instance with a bunch of `HM.insert`s.
1306+ resourcesArr ContainerResources{..} = [
1307+ "CpuShares" .= cpuShares
1308+ , "BlkioWeight" .= blkioWeight
1309+ , "BlkioWeightDevice" .= blkioWeightDevice
1310+ , "BlkioDeviceReadBps" .= blkioDeviceReadBps
1311+ , "BlkioDeviceWriteBps" .= blkioDeviceWriteBps
1312+ , "BlkioDeviceReadIOps" .= blkioDeviceReadIOps
1313+ , "BlkioDeviceWriteIOps" .= blkioDeviceWriteIOps
1314+ , "CpuPeriod" .= cpuPeriod
1315+ , "CpusetCpus" .= cpusetCpus
1316+ , "CpusetMems" .= cpusetMems
1317+ , "Devices" .= devices
1318+ , "KernelMemory" .= kernelMemory
1319+ , "Memory" .= memory
1320+ , "MemoryReservation" .= memoryReservation
1321+ , "MemorySwap" .= memorySwap
1322+ , "OomKillDisable" .= oomKillDisable
1323+ , "Ulimits" .= ulimits
1324+ ]
1325+
1326+
1327+
1328+
1329+-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }
1330+-- { "Name": "nofile", "Soft": 1024, "Hard": 2048 }
1331+data Ulimit = Ulimit {
1332+ ulimitName :: Text
1333+ , ulimitSoft :: Integer
1334+ , ulimitHard :: Integer
1335+ } deriving (Eq, Show, Generic)
1336+
1337+instance FromJSON Ulimit where
1338+ parseJSON = genericParseJSON defaultOptions {
1339+ fieldLabelModifier = drop 5}
1340+
1341+instance ToJSON Ulimit where
1342+ toJSON = genericToJSON defaultOptions {
1343+ fieldLabelModifier = drop 5}
1344+
1345+data DeviceWeight = DeviceWeight {
1346+ deviceWeightPath :: FilePath
1347+ , deviceWeightWeight :: Text
1348+ }
1349+ deriving (Show, Eq)
1350+
1351+instance FromJSON DeviceWeight where
1352+ parseJSON (JSON.Object o) = DeviceWeight
1353+ <$> o .: "Path"
1354+ <*> o .: "Weight"
1355+ parseJSON _ = fail "DeviceWeight is not an object."
1356+
1357+instance ToJSON DeviceWeight where
1358+ toJSON (DeviceWeight p w) = object [
1359+ "Path" .= p
1360+ , "Weight" .= w
1361+ ]
1362+
1363+data DeviceRate = DeviceRate {
1364+ deviceRatePath :: FilePath
1365+ , deviceRateRate :: Text
1366+ }
1367+ deriving (Show, Eq)
1368+
1369+instance FromJSON DeviceRate where
1370+ parseJSON (JSON.Object o) = DeviceRate
1371+ <$> o .: "Path"
1372+ <*> o .: "Rate"
1373+ parseJSON _ = fail "DeviceRate is not an object."
1374+
1375+instance ToJSON DeviceRate where
1376+ toJSON (DeviceRate p r) = object [
1377+ "Path" .= p
1378+ , "Rate" .= r
1379+ ]
1380+
1381+data MemoryConstraintSize = B | MB | GB deriving (Eq, Show)
1382+
1383+data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)
1384+
1385+instance ToJSON MemoryConstraint where
1386+ toJSON (MemoryConstraint x B) = toJSON x
1387+ toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024
1388+ toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024
1389+
1390+instance FromJSON MemoryConstraint where
1391+ parseJSON (JSON.Number x) = case (floatingOrInteger x) of
1392+ Left (_ :: Double) -> fail "Failed to parse MemoryConstraint"
1393+ Right i -> return $ MemoryConstraint i B
1394+ -- The docker daemon will always return the number as bytes (integer), regardless of how we set them (using MB or GB)
1395+ parseJSON _ = fail "Failed to parse MemoryConstraint"
1396+
1397+data ContainerResources = ContainerResources {
1398+ cpuShares :: Maybe Integer
1399+ -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
1400+ , blkioWeight :: Maybe Integer
1401+ , blkioWeightDevice :: Maybe [DeviceWeight]
1402+ , blkioDeviceReadBps :: Maybe [DeviceRate] -- TODO: Not Text
1403+ , blkioDeviceWriteBps :: Maybe [DeviceRate] -- TODO: Not Text
1404+ , blkioDeviceReadIOps :: Maybe [DeviceRate] -- TODO: Not Text
1405+ , blkioDeviceWriteIOps :: Maybe [DeviceRate] -- TODO: Not Text
1406+ , cpuPeriod :: Maybe Integer
1407+ -- , cpuQuota :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1408+ , cpusetCpus :: Maybe Text
1409+ , cpusetMems :: Maybe Text
1410+ , devices :: [Device]
1411+ -- , diskQuota :: Integer -- Don't see this ins 1.24.
1412+ , kernelMemory :: Maybe MemoryConstraint
1413+ , memory :: Maybe MemoryConstraint
1414+ , memoryReservation :: Maybe MemoryConstraint
1415+ , memorySwap :: Maybe MemoryConstraint
1416+ -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1417+ , oomKillDisable :: Maybe Bool
1418+ -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1419+ , ulimits :: [Ulimit]
1420+ -- TODO: Missing from 1.24
1421+ -- StorageOpt :: [(Text, Text)]
1422+ -- VolumeDriver :: ??
1423+ -- EndpointsConfig :: ??
1424+ -- TODO: Only in inspect container in 1.24
1425+ -- CpuPercent :: Int +
1426+ -- MaximumIOps :: Int +
1427+ -- MaximumIOBps :: Int +
1428+ -- LxcConf :: [??] +
1429+ } deriving (Eq, Show, Generic)
1430+
1431+-- instance ToJSON ContainerResources where
1432+-- toJSON = genericToJSON defaultOptions {
1433+-- fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1434+
1435+instance FromJSON ContainerResources where
1436+ parseJSON = genericParseJSON defaultOptions {
1437+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1438+
1439+type Port = Integer
1440+
1441+type Name = Text
1442+type Value = Text
1443+
1444+data EnvVar = EnvVar Name Value
1445+ deriving (Eq, Show)
1446+
1447+instance FromJSON EnvVar where
1448+ parseJSON (JSON.String env) =
1449+ let (n, v') = T.break (== '=') env in
1450+ let v = T.drop 1 v' in
1451+ return $ EnvVar n v
1452+ parseJSON _ = fail "EnvVar is not a string"
1453+
1454+instance ToJSON EnvVar where
1455+ toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v
1456+
1457+-- | ExposedPort represents a port (and it's type)
1458+-- that a container should expose to other containers or the host system.
1459+-- `NOTE`: This does not automatically expose the port onto the host
1460+-- system but rather it just tags it. It's best to be used with
1461+-- the PublishAllPorts flag. It is also useful for
1462+-- the daemon to know which Environment variables to
1463+-- inject into a container linking to our container.
1464+-- Example linking a Postgres container named db would inject the following
1465+-- environment variables automatically if we set the corresponding
1466+--
1467+-- ExposedPort:
1468+--
1469+-- @
1470+-- DB_PORT_5432_TCP_PORT="5432"
1471+-- DB_PORT_5432_TCP_PROTO="tcp"
1472+-- DB_PORT_5432_TCP="tcp://172.17.0.1:5432"
1473+-- @
1474+data ExposedPort = ExposedPort Port PortType deriving (Eq, Show)
1475+
1476+instance {-# OVERLAPPING #-} FromJSON [ExposedPort] where
1477+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1478+ where
1479+ f accM k _ = case T.split (== '/') k of
1480+ [port', portType'] -> do
1481+ port <- parseIntegerText port'
1482+ portType <- parseJSON $ JSON.String portType'
1483+ acc <- accM
1484+ return $ (ExposedPort port portType):acc
1485+ _ -> fail "Could not parse ExposedPorts"
1486+ parseJSON (JSON.Null) = return []
1487+ parseJSON _ = fail "ExposedPorts is not an object"
1488+
1489+instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1490+ toJSON [] = emptyJsonObject
1491+ toJSON (p:ps) = toJsonKey (p:ps) key
1492+ where key (ExposedPort p t) = show p <> slash <> show t
1493+ slash = T.unpack "/"
1494+
1495+data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)
1496+
1497+instance ToJSON Entrypoint where
1498+ toJSON (Entrypoint (e:es)) = toJSON (e:es)
1499+ toJSON (Entrypoint []) = JSON.Null
1500+
1501+instance FromJSON Entrypoint where
1502+ parseJSON (JSON.String e) = return $ Entrypoint [e]
1503+ parseJSON (JSON.Array ar) = do
1504+ arr <- mapM parseJSON (V.toList ar)
1505+ return $ Entrypoint arr
1506+ parseJSON JSON.Null = return $ Entrypoint []
1507+ parseJSON _ = fail "Failed to parse Entrypoint"
1508+
1509+
1510+data ContainerConfig = ContainerConfig {
1511+ hostname :: Maybe Text
1512+ , domainname :: Maybe Text
1513+ , user :: Maybe Text
1514+ , attachStdin :: Bool
1515+ , attachStdout :: Bool
1516+ , attachStderr :: Bool
1517+ , exposedPorts :: [ExposedPort]
1518+ -- , publishService :: Text -- Don't see this in 1.24
1519+ , tty :: Bool
1520+ , openStdin :: Bool
1521+ , stdinOnce :: Bool
1522+ , env :: [EnvVar]
1523+ , cmd :: [Text]
1524+ -- , argsEscaped :: Bool -- Don't see this in 1.24
1525+ , image :: Text
1526+ , volumes :: [Volume]
1527+ , workingDir :: Maybe FilePath
1528+ , entrypoint :: Entrypoint
1529+ , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1530+ , macAddress :: Maybe Text
1531+ -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1532+ , labels :: [Label]
1533+ , stopSignal :: Signal
1534+ } deriving (Eq, Show, Generic)
1535+
1536+
1537+instance ToJSON ContainerConfig where
1538+ toJSON = genericToJSON defaultOptions {
1539+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1540+
1541+instance FromJSON ContainerConfig where
1542+ parseJSON (JSON.Object o) = do
1543+ hostname <- o .:? "Hostname"
1544+ domainname <- o .:? "Domainname"
1545+ user <- o .:? "User"
1546+ attachStdin <- o .: "AttachStdin"
1547+ attachStdout <- o .: "AttachStdout"
1548+ attachStderr <- o .: "AttachStderr"
1549+ exposedPorts <- o .:? "ExposedPorts" .!= []
1550+ tty <- o .: "Tty"
1551+ openStdin <- o .: "OpenStdin"
1552+ stdinOnce <- o .: "StdinOnce"
1553+ env <- o .: "Env"
1554+ cmd <- o .: "Cmd"
1555+ image <- o .: "Image"
1556+ volumes <- o .: "Volumes"
1557+ workingDir <- o .:? "WorkingDir"
1558+ entrypoint <- o .: "Entrypoint"
1559+ networkDisabled <- o .:? "networkDisabled"
1560+ macAddress <- o .:? "MacAddress"
1561+ labels <- o .:? "Labels" .!= []
1562+ stopSignal <- o .: "StopSignal"
1563+ return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled
1564+ macAddress labels stopSignal
1565+ parseJSON _ = fail "NetworkSettings is not an object."
1566+
1567+#if MIN_VERSION_base(4,13,0)
1568+parseIntegerText :: (MonadFail m) => Text -> m Integer
1569+#else
1570+parseIntegerText :: (Monad m) => Text -> m Integer
1571+#endif
1572+parseIntegerText t = case readMaybe $ T.unpack t of
1573+ Nothing ->
1574+ fail "Could not parse Integer"
1575+ Just i ->
1576+ return i
1577+
1578+-- | Helper function for converting a data type [a] to a json dictionary
1579+-- like so {"something": {}, "something2": {}}
1580+toJsonKey :: Foldable t => t a -> (a -> String) -> JSON.Value
1581+toJsonKey vs getKey = JSON.Object $ foldl f HM.empty vs
1582+ where f acc x = HM.insert (T.pack $ getKey x) (JSON.Object HM.empty) acc
1583+
1584+-- | Helper function for converting a data type [a] to a json dictionary
1585+-- like so {"something": "val1", "something2": "val2"}
1586+toJsonKeyVal :: (Foldable t, JSON.ToJSON r) => t a -> (a -> String) -> (a -> r) -> JSON.Value
1587+toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
1588+ where f acc x = HM.insert (T.pack $ getKey x) (toJSON $ getVal x) acc
1589+
1590+-- | Helper function that return an empty dictionary "{}"
1591+emptyJsonObject :: JSON.Value
1592+emptyJsonObject = JSON.Object HM.empty