on master help sign in
Merge branch 'dev' of https://github.com/jprider63/docker-hs into dev
commit70d77aa40894c90ef106a8017899f51abb2db9a1 authorDeni Bertovic <deni@denibertovic.com> dateWed 3 Aug 2016, 10:59 (10 years ago) parent35e5d764824356
2 files changed+176−66
src/Docker/Client/Types.hs+175−66 tests/tests.hs+1
src/Docker/Client/Types.hs+175−66
@@ -49,7 +49,7 @@ module Docker.Client.Types (
4949 , LogDriverConfig(..)
5050 , NetworkMode(..)
5151 , PortType(..)
52− , NetworkInterface(..)
52+-- , NetworkInterface(..)
5353 , Networks(..)
5454 , NetworkSettings(..)
5555 , NetworkOptions(..)
@@ -73,6 +73,8 @@ module Docker.Client.Types (
7373 , ContainerConfig(..)
7474 , defaultContainerConfig
7575 , ExposedPorts(..)
76+ , DeviceWeight(..)
77+ , DeviceRate(..)
7678 ) where
7779
7880import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
@@ -282,11 +284,8 @@ instance FromJSON DockerVersion where
282284 parseJSON = genericParseJSON defaultOptions {
283285 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
284286
285−-- instance ToJSON ContainerDetails where
286−-- toJSON = error "TODO"
287−
288287instance FromJSON ContainerDetails where
289− parseJSON (JSON.Object o) = do
288+ parseJSON v@(JSON.Object o) = do
290289 appArmor <- o .: "AppArmorProfile"
291290 args <- o .: "Args"
292291 config <- o .: "Config"
@@ -296,7 +295,7 @@ instance FromJSON ContainerDetails where
296295 hostnamePath <- o .: "HostnamePath"
297296 hostsPath <- o .: "HostsPath"
298297 logPath <- o .: "LogPath"
299− id <- o .: "Id"
298+ id <- parseJSON v
300299 image <- o .: "Image"
301300 mountLabel <- o .: "MountLabel"
302301 name <- o .: "Name"
@@ -401,7 +400,7 @@ data NetworkSettings = NetworkSettings {
401400 , networkSettingsHairpinMode :: Bool
402401 , networkSettingsLinkLocalIPv6Address :: Text
403402 , networkSettingsLinkLocalIPv6PrefixLen :: Int
404− , networkSettingsPorts :: [Port] -- TODO: 1.24 spec is unclear
403+ , networkSettingsPorts :: PortBindings
405404 , networkSettingsSandboxKey :: Text
406405 , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
407406 , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
@@ -411,8 +410,8 @@ data NetworkSettings = NetworkSettings {
411410 , networkSettingsGlobalIPv6PrefixLen :: Int
412411 , networkSettingsIpAddress :: Text
413412 , networkSettingsIpPrefixLen :: Int
414− , networkSettingsIpv6Gateway
415− , networkSettingsMacAddress
413+ , networkSettingsIpv6Gateway :: Text
414+ , networkSettingsMacAddress :: Text
416415 , networkSettingsNetworks :: Networks
417416 }
418417 deriving (Eq, Show)
@@ -424,7 +423,7 @@ instance FromJSON NetworkSettings where
424423 hairpin <- o .: "HairpinMode"
425424 localIP6 <- o .: "LinkLocalIPv6Address"
426425 localIP6Len <- o .: "LinkLocalIPv6PrefixLen"
427− ports <- o .:? "Ports" .!= []
426+ ports <- o .: "Ports" -- .!= []
428427 sandboxKey <- o .: "SandboxKey"
429428 secondaryIP <- o .: "SecondaryIPAddresses"
430429 secondayIP6 <- o .: "SecondaryIPv6Addresses"
@@ -438,7 +437,7 @@ instance FromJSON NetworkSettings where
438437 mac <- o .: "MacAddress"
439438 networks <- o .: "Networks"
440439 return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
441− parseJSON _ = fail "NetworkSettings is not an Object"
440+ parseJSON _ = fail "NetworkSettings is not an object."
442441
443442data Container = Container
444443 { containerId :: ContainerID
@@ -539,7 +538,7 @@ defaultContainerConfig imageName = ContainerConfig {
539538 , attachStdout=False
540539 , image=imageName
541540 , attachStderr=False
542− , exposedPorts=ExposedPorts M.empty
541+ , exposedPorts=Nothing -- ExposedPorts M.empty
543542 , tty=False
544543 , openStdin=False
545544 , stdinOnce=False
@@ -548,7 +547,7 @@ defaultContainerConfig imageName = ContainerConfig {
548547 , volumes=Nothing
549548 , workingDir=Nothing
550549 , entrypoint=Nothing
551− , networkDisabled=False
550+ , networkDisabled=Nothing
552551 , macAddress=Nothing
553552 , labels=Nothing
554553 , stopSignal=SIGTERM
@@ -575,7 +574,7 @@ defaultHostConfig = HostConfig {
575574 , oomScoreAdj=Nothing
576575 , privileged=False
577576 , publishAllPorts=False
578− , readOnlyRootfs=False
577+ , readonlyRootfs=False
579578 , securityOpt=[]
580579 , shmSize=Nothing
581580 , resources=defaultContainerResources
@@ -804,14 +803,14 @@ instance FromJSON PortType where
804803 "udp" -> return UDP
805804 _ -> fail "PortType: Invalid port type."
806805
807−newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
808−
809−instance FromJSON NetworkInterface where
810− parseJSON (JSON.String v) = return $ NetworkInterface v
811− parseJSON _ = fail "Network interface is not a string."
812−
813−instance ToJSON NetworkInterface where
814− toJSON (NetworkInterface i) = JSON.String i
806+-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
807+--
808+-- instance FromJSON NetworkInterface where
809+-- parseJSON (JSON.String v) = return $ NetworkInterface v
810+-- parseJSON _ = fail "Network interface is not a string."
811+--
812+-- instance ToJSON NetworkInterface where
813+-- toJSON (NetworkInterface i) = JSON.String i
815814
816815-- | This datastructure models mapping a Port from the container onto the
817816-- host system s that the service running in the container can be accessed from
@@ -824,7 +823,7 @@ newtype PortBindings = PortBindings [PortBinding]
824823data PortBinding = PortBinding {
825824 containerPort :: Port
826825 , portType :: PortType
827− , hostPorts :: HostPorts
826+ , hostPorts :: [HostPort]
828827 } deriving (Eq, Show)
829828
830829
@@ -854,37 +853,39 @@ instance ToJSON PortBindings where
854853 toJSON (PortBindings []) = JSON.Object HM.empty
855854 toJSON (PortBindings (p:ps)) = toJSON (p:ps)
856855
857−data HostPort = HostPort NetworkInterface Port
856+data HostPort = HostPort {
857+ hostIp :: Text
858+ , hostPost :: Port
859+ }
858860 deriving (Eq, Show)
859861
860862instance ToJSON HostPort where
861− toJSON (HostPort i p) = object ["HostPort" .= p, "HostIP" .= i]
863+ toJSON (HostPort i p) = object ["HostPort" .= show p, "HostIp" .= i]
862864
863865instance FromJSON HostPort where
864866 parseJSON (JSON.Object o) = do
865− p <- o .: "HostPort"
866− i <- o .: "HostIP"
867+ p <- o .: "HostPort" >>= parseIntegerText
868+ i <- o .: "HostIp"
867869 return $ HostPort i p
868870 parseJSON _ = fail "HostPort is not an object."
869871
870−newtype HostPorts = HostPorts [HostPort]
871− deriving (Eq, Show)
872−
873−
874−instance ToJSON HostPorts where
875− toJSON (HostPorts hps) = toJSON hps
876−
877−instance FromJSON HostPorts where
878− parseJSON (JSON.Object o) = do
879− HostPorts <$> HM.foldlWithKey' f (return []) o
880−
881− where
882− f accM k v = do
883− acc <- accM
884− p' <- parseJSON v
885− p <- parseIntegerText p'
886− return $ (HostPort (NetworkInterface k) p):acc
887− parseJSON _ = fail "HostPorts is not an object"
872+-- newtype HostPorts = HostPorts [HostPort]
873+-- deriving (Eq, Show)
874+--
875+-- instance ToJSON HostPorts where
876+-- toJSON (HostPorts hps) = toJSON hps
877+--
878+-- instance FromJSON HostPorts where
879+-- parseJSON (JSON.Object o) = do
880+-- HostPorts <$> HM.foldlWithKey' f (return []) o
881+--
882+-- where
883+-- f accM k v = do
884+-- acc <- accM
885+-- p' <- parseJSON v
886+-- p <- parseIntegerText p'
887+-- return $ (HostPort (NetworkInterface k) p):acc
888+-- parseJSON _ = fail $ "HostPorts is not an object"
888889
889890-- { "Name": "on-failure" , "MaximumRetryCount": 2}
890891type RetryCount = Integer
@@ -899,7 +900,7 @@ instance FromJSON RestartPolicy where
899900 "on-failure" -> do
900901 retry <- o .: "MaximumRetryCount"
901902 return $ RestartOnFailure retry
902− "" -> return RestartOff -- Note: Is this correct? 1.24 spec is unclear.
903+ "off" -> return RestartOff
903904 _ -> fail "Could not parse RestartPolicy"
904905 parseJSON _ = fail "RestartPolicy is not an object"
905906
@@ -938,7 +939,7 @@ data HostConfig = HostConfig
938939 -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit
939940 , privileged :: Bool
940941 , publishAllPorts :: Bool
941− , readOnlyRootfs :: Bool
942+ , readonlyRootfs :: Bool
942943 , securityOpt :: [Text]
943944 -- , utsMode :: UTSMode -- 1.24: Don't see this
944945 , shmSize :: Maybe Integer
@@ -948,12 +949,84 @@ data HostConfig = HostConfig
948949 } deriving (Eq, Show, Generic)
949950
950951instance FromJSON HostConfig where
951− parseJSON = genericParseJSON defaultOptions {
952− fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
952+ parseJSON v@(JSON.Object o) = HostConfig
953+ <$> o .: "Binds"
954+ <*> o .: "ContainerIDFile"
955+ <*> o .: "LogConfig"
956+ <*> o .: "NetworkMode"
957+ <*> o .: "PortBindings"
958+ <*> o .: "RestartPolicy"
959+ <*> o .: "VolumeDriver"
960+ <*> o .: "VolumesFrom"
961+ <*> o .: "CapAdd"
962+ <*> o .: "CapDrop"
963+ <*> o .: "Dns"
964+ <*> o .: "DnsOptions"
965+ <*> o .: "DnsSearch"
966+ <*> o .: "ExtraHosts"
967+ <*> o .: "IpcMode"
968+ <*> o .:? "Links" .!= []
969+ <*> o .: "OomScoreAdj"
970+ <*> o .: "Privileged"
971+ <*> o .: "PublishAllPorts"
972+ <*> o .: "ReadonlyRootfs"
973+ <*> o .: "SecurityOpt"
974+ <*> o .: "ShmSize"
975+ <*> parseJSON v
976+ parseJSON _ = fail "HostConfig is not an object."
953977
954978instance ToJSON HostConfig where
955− toJSON = genericToJSON defaultOptions {
956− fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
979+ toJSON HostConfig{..} =
980+ let arr = [
981+ "Binds" .= binds
982+ , "ContainerIDFile" .= containerIDFile
983+ , "LogConfig" .= logConfig
984+ , "NetworkMode" .= networkMode
985+ , "PortBindings" .= portBindings
986+ , "RestartPolicy" .= restartPolicy
987+ , "VolumeDriver" .= volumeDriver
988+ , "VolumesFrom" .= volumesFrom
989+ , "CapAdd" .= capAdd
990+ , "CapDrop" .= capDrop
991+ , "Dns" .= dns
992+ , "DnsOptions" .= dnsOptions
993+ , "DnsSearch" .= dnsSearch
994+ , "ExtraHosts" .= extraHosts
995+ , "IpcMode" .= ipcMode
996+ , "Links" .= links
997+ , "OomScoreAdj" .= oomScoreAdj
998+ , "Privileged" .= privileged
999+ , "PublishAllPorts" .= publishAllPorts
1000+ , "ReadonlyRootfs" .= readonlyRootfs
1001+ , "SecurityOpt" .= securityOpt
1002+ , "ShmSize" .= shmSize
1003+ ]
1004+ in
1005+ object $ arr <> ( resourcesArr resources)
1006+
1007+ where
1008+ -- JP: Not sure if this is better than a separate ToJSON instance with a bunch of `HM.insert`s.
1009+ resourcesArr ContainerResources{..} = [
1010+ "CpuShares" .= cpuShares
1011+ , "BlkioWeight" .= blkioWeight
1012+ , "BlkioWeightDevice" .= blkioWeightDevice
1013+ , "BlkioDeviceReadBps" .= blkioDeviceReadBps
1014+ , "BlkioDeviceWriteBps" .= blkioDeviceWriteBps
1015+ , "BlkioDeviceReadIOps" .= blkioDeviceReadIOps
1016+ , "BlkioDeviceWriteIOps" .= blkioDeviceWriteIOps
1017+ , "CpuPeriod" .= cpuPeriod
1018+ , "CpusetCpus" .= cpusetCpus
1019+ , "CpusetMems" .= cpusetMems
1020+ , "Devices" .= devices
1021+ , "KernelMemory" .= kernelMemory
1022+ , "Memory" .= memory
1023+ , "MemoryReservation" .= memoryReservation
1024+ , "MemorySwap" .= memorySwap
1025+ , "OomKillDisable" .= oomKillDisable
1026+ , "Ulimits" .= ulimits
1027+ ]
1028+
1029+
9571030
9581031
9591032-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }
@@ -972,18 +1045,54 @@ instance ToJSON Ulimit where
9721045 toJSON = genericToJSON defaultOptions {
9731046 fieldLabelModifier = drop 5}
9741047
1048+data DeviceWeight = DeviceWeight {
1049+ deviceWeightPath :: FilePath
1050+ , deviceWeightWeight :: Text
1051+ }
1052+ deriving (Show, Eq)
1053+
1054+instance FromJSON DeviceWeight where
1055+ parseJSON (JSON.Object o) = DeviceWeight
1056+ <$> o .: "Path"
1057+ <*> o .: "Weight"
1058+ parseJSON _ = fail "DeviceWeight is not an object."
1059+
1060+instance ToJSON DeviceWeight where
1061+ toJSON (DeviceWeight p w) = object [
1062+ "Path" .= p
1063+ , "Weight" .= w
1064+ ]
1065+
1066+data DeviceRate = DeviceRate {
1067+ deviceRatePath :: FilePath
1068+ , deviceRateRate :: Text
1069+ }
1070+ deriving (Show, Eq)
1071+
1072+instance FromJSON DeviceRate where
1073+ parseJSON (JSON.Object o) = DeviceRate
1074+ <$> o .: "Path"
1075+ <*> o .: "Rate"
1076+ parseJSON _ = fail "DeviceRate is not an object."
1077+
1078+instance ToJSON DeviceRate where
1079+ toJSON (DeviceRate p r) = object [
1080+ "Path" .= p
1081+ , "Rate" .= r
1082+ ]
1083+
9751084data ContainerResources = ContainerResources {
9761085 cpuShares :: Maybe Integer
9771086 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
978− , blkioWeight :: Maybe Text
979− , blkioWeightDevice :: Maybe Text
980− , blkioDeviceReadBps :: Maybe Text
981− , blkioDeviceWriteBps :: Maybe Text
982− , blkioDeviceReadIOps :: Maybe Text
983− , blkioDeviceWriteIOps :: Maybe Text
1087+ , blkioWeight :: Maybe Integer
1088+ , blkioWeightDevice :: Maybe [DeviceWeight]
1089+ , blkioDeviceReadBps :: Maybe [DeviceRate] -- TODO: Not Text
1090+ , blkioDeviceWriteBps :: Maybe [DeviceRate] -- TODO: Not Text
1091+ , blkioDeviceReadIOps :: Maybe [DeviceRate] -- TODO: Not Text
1092+ , blkioDeviceWriteIOps :: Maybe [DeviceRate] -- TODO: Not Text
9841093 , cpuPeriod :: Maybe Integer
9851094 -- , cpuQuota :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
986− , cpusetCpus :: Maybe Integer
1095+ , cpusetCpus :: Maybe Text
9871096 , cpusetMems :: Maybe Text
9881097 , devices :: [Device]
9891098 -- , diskQuota :: Integer -- Don't see this ins 1.24.
@@ -1006,13 +1115,13 @@ data ContainerResources = ContainerResources {
10061115 -- LxcConf :: [??] +
10071116 } deriving (Eq, Show, Generic)
10081117
1009−instance ToJSON ContainerResources where
1010− toJSON = genericToJSON defaultOptions {
1011− fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1118+-- instance ToJSON ContainerResources where
1119+-- toJSON = genericToJSON defaultOptions {
1120+-- fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
10121121
10131122instance FromJSON ContainerResources where
10141123 parseJSON = genericParseJSON defaultOptions {
1015− fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1124+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
10161125
10171126type Port = Integer
10181127
@@ -1074,7 +1183,7 @@ data ContainerConfig = ContainerConfig {
10741183 , attachStdin :: Bool
10751184 , attachStdout :: Bool
10761185 , attachStderr :: Bool
1077− , exposedPorts :: ExposedPorts
1186+ , exposedPorts :: Maybe ExposedPorts -- Note: Should we expand the JSON instance and take away the Maybe?
10781187 -- , publishService :: Text -- Don't see this in 1.24
10791188 , tty :: Bool
10801189 , openStdin :: Bool
@@ -1086,9 +1195,9 @@ data ContainerConfig = ContainerConfig {
10861195 , volumes :: Maybe Volumes
10871196 , workingDir :: Maybe FilePath
10881197 , entrypoint :: Maybe Text -- Can be null?
1089− , networkDisabled :: Bool
1198+ , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
10901199 , macAddress :: Maybe Text
1091− -- , onBuild :: Text -- For 1.24, only see this in the inspect response.
1200+ -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
10921201 , labels :: Maybe Labels
10931202 , stopSignal :: Signal
10941203 } deriving (Eq, Show, Generic)
@@ -1101,7 +1210,7 @@ instance FromJSON ContainerConfig where
11011210 parseJSON = genericParseJSON defaultOptions {
11021211 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
11031212
1104−parseIntegerText :: (Monad m) =>Text -> m Integer
1213+parseIntegerText :: (Monad m) => Text -> m Integer
11051214parseIntegerText t = case readMaybe $ T.unpack t of
11061215 Nothing ->
11071216 fail "Could not parse Integer"
tests/tests.hs+1
@@ -60,6 +60,7 @@ testRunAndReadLog = runDocker $ do
6060 containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest"))
6161 c <- fromRight containerId
6262 status1 <- startContainer defaultStartOpts c
63+ _ <- inspectContainer c >>= fromRight
6364 lift $ threadDelay 300000 -- give 300ms for the application to finish
6465 lift $ assert $ status1 == Right ()
6566 status2 <- killContainer SIGTERM c