18fefc4 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

Refactor Labels data type

As with Volumes and various port datatypes we are changing the hard to use Labels newtype and just falling back on [Label].

commit18fefc428a85c2e4bce64d101827bb64515a15cc authorDeni Bertovic <deni@denibertovic.com> dateSun 4 Sep 2016, 15:04 (10 years ago) parent43796ac

2 files changed+53−14

compare with master

unifiedsplit

src/Docker/Client/Types.hs+39−13 tests/tests.hs+14−1

src/Docker/Client/Types.hs+39−13

@@ -24,7 +24,7 @@ module Docker.Client.Types (

2424 , ContainerState(..)

2525 , Status(..)

2626 , Digest

27− , Labels(..)

27+ , Label(..)

2828 , Tag

2929 , Image(..)

3030 , dropImagePrefix

@@ -492,7 +492,7 @@ data Container = Container

492492 , containerCreatedAt :: Int

493493 , containerStatus :: Status

494494 , containerPorts :: [ContainerPortInfo]

495− , containerLabels :: Labels

495+ , containerLabels :: [Label]

496496 , containerNetworks :: Networks

497497 , containerMounts :: [Mount]

498498 } deriving (Show, Eq)

@@ -535,13 +535,24 @@ instance FromJSON Status where

535535type Digest = Text

536536

537537-- | Container and Image Labels.

538−newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)

538+data Label = Label Name Value deriving (Eq, Show)

539539

540−instance FromJSON Labels where

541− parseJSON val = Labels <$> parseJSON val

542540

543−instance ToJSON Labels where

544− toJSON (Labels kvs) = object [k .= v | (k,v) <- (M.toList kvs)]

541+-- If there are multiple lables with the same Name in the list

542+-- then the last one wins.

543+instance ToJSON [Label] where

544+ toJSON [] = JSON.Object HM.empty

545+ toJSON (l:ls) = JSON.Object $ foldl f HM.empty (l:ls)

546+ where f acc (Label n v) = HM.insert n (toJSON v) acc

547+

548+instance FromJSON [Label] where

549+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o

550+ where f accM k v = do

551+ acc <- accM

552+ value <- parseJSON v

553+ return $ (Label k value):acc

554+ parseJSON JSON.Null = return []

555+ parseJSON _ = fail "Failed to parse Labels. Not an object."

545556

546557-- | Alias for Tags.

547558type Tag = Text

@@ -555,7 +566,7 @@ data Image = DockerImage {

555566 , imageRepoDigests :: Maybe [Digest]

556567 , imageSize :: Integer

557568 , imageVirtualSize :: Integer

558− , imageLabels :: Maybe Labels

569+ , imageLabels :: [Label]

559570 } deriving (Show, Eq, Generic)

560571

561572-- | Helper function used for dropping the "image" prefix when serializing

@@ -563,9 +574,22 @@ data Image = DockerImage {

563574dropImagePrefix :: [a] -> [a]

564575dropImagePrefix = drop 5

565576

577+

566578instance FromJSON Image where

567− parseJSON = genericParseJSON defaultOptions {

568− fieldLabelModifier = dropImagePrefix}

579+ parseJSON (JSON.Object o) = do

580+ imageId <- o .: "Id"

581+ imageCreated <- o .: "Created"

582+ imageParentId <- o .:? "ParentId"

583+ imageRepoTags <- o .: "RepoTags"

584+ imageRepoDigests <- o .:? "RepoDigests"

585+ imageSize <- o .: "Size"

586+ imageVirtualSize <- o .: "VirtualSize"

587+ imageLabels <- case HM.lookup "Labels" o of

588+ Just ls -> parseJSON ls

589+ Nothing -> return []

590+ return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels

591+ parseJSON _ = fail "Failed to parse DockerImage."

592+

569593

570594-- | Options used for creating a Container.

571595data CreateOpts = CreateOpts {

@@ -604,7 +628,7 @@ defaultContainerConfig imageName = ContainerConfig {

604628 , entrypoint=Nothing

605629 , networkDisabled=Nothing

606630 , macAddress=Nothing

607− , labels=Nothing

631+ , labels=[]

608632 , stopSignal=SIGTERM

609633 }

610634

@@ -1329,7 +1353,7 @@ data ContainerConfig = ContainerConfig {

13291353 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?

13301354 , macAddress :: Maybe Text

13311355 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.

1332− , labels :: Maybe Labels

1356+ , labels :: [Label]

13331357 , stopSignal :: Signal

13341358 } deriving (Eq, Show, Generic)

13351359

@@ -1359,7 +1383,9 @@ instance FromJSON ContainerConfig where

13591383 entrypoint <- o .:? "Entrypoint"

13601384 networkDisabled <- o .:? "networkDisabled"

13611385 macAddress <- o .:? "MacAddress"

1362− labels <- o .:? "Labels"

1386+ labels <- case HM.lookup "Labels" o of

1387+ Just ls -> parseJSON ls

1388+ Nothing -> return []

13631389 stopSignal <- o .: "StopSignal"

13641390 return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled

13651391 macAddress labels stopSignal

tests/tests.hs+14−1

@@ -78,6 +78,19 @@ testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP

7878 testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

7979 sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

8080

81+testLabelsJson :: TestTree

82+testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]

83+ where

84+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1

85+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2

86+ testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"

87+ sampleLS = [Label key1 val1, Label key2 val2]

88+ key1 = "com.example.some-label"

89+ val1 = "some-value"

90+ key2 = "something"

91+ val2 = "value"

92+

93+

8194testVolumesJson :: TestTree

8295testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]

8396 where

@@ -92,7 +105,7 @@ integrationTests = testGroup "Integration Tests" [

92105 testCase "Run a dummy container and read its log" testRunAndReadLog]

93106

94107jsonTests :: TestTree

95−jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson]

108+jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson]

96109

97110setup :: IO ()

98111setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()