docker 0.5.1.1 → 0.6.0.0

raw patch · 6 files changed

+221/−23 lines, 6 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• docker.cabal +2/−2
• src/Docker/Client/Api.hs +20/−2
• src/Docker/Client/Http.hs +15/−1
• src/Docker/Client/Internal.hs +8/−1
• src/Docker/Client/Types.hs +110/−11
• tests/tests.hs +66/−6

@@ -1,5 +1,5 @@ name:                docker-version:             0.5.1.1+version:             0.6.0.0 synopsis:            An API client for docker written in Haskell description:         See API documentation below. homepage:            https://github.com/denibertovic/docker-hs@@ -25,7 +25,7 @@   exposed-modules:     Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils   -- other-modules:       Docker.Internal   build-depends:       base >= 4.7 && < 5-                     , aeson >= 0.9.0 && < 1.4.0+                     , aeson >= 0.9.0 && < 2.0.0                      , blaze-builder >= 0.4.0 && < 0.5.0                      , bytestring >= 0.10.0 && < 0.11.0                      , containers >= 0.5.0 && < 0.6.0

@@ -18,8 +18,12 @@     , getContainerLogsStream     -- * Images     , listImages+    , deleteImage     , buildImageFromDockerfile     , pullImage+    -- * Network+    , createNetwork+    , removeNetwork     -- * Other     , getDockerVersion     ) where@@ -90,6 +94,12 @@ listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image]) listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse +-- | Deletes an image with the given 'ImageID'.+-- See "ImageDeleteOpts" for options and use 'defaultImageDeleteOpts' for sane+-- defaults.+deleteImage :: forall m. (MonadIO m, MonadMask m) => ImageDeleteOpts -> ImageID -> DockerT m (Either DockerError ())+deleteImage dopts iid = requestUnit DELETE $ DeleteImageEndpoint dopts iid+ -- | Creates a docker container but does __not__ start it. See -- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts' -- for some sane defaults.@@ -135,9 +145,9 @@ unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid  -- | Deletes a container with the given 'ContainerID'.--- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane+-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane -- defaults.-deleteContainer :: forall m. (MonadIO m, MonadMask m) => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())+deleteContainer :: forall m. (MonadIO m, MonadMask m) => ContainerDeleteOpts -> ContainerID -> DockerT m (Either DockerError ()) deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid  -- | Gets 'ContainerDetails' for a given 'ContainerID'.@@ -206,4 +216,12 @@ -- the image from a tarball or a URL. pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b) pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)++-- | Creates network+createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)+createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts)  >>= parseResponse++-- | Removes a network+removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())+removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid 

@@ -273,4 +273,18 @@         Nothing     else         Just $ DockerInvalidStatusCode st-+statusCodeToError (DeleteImageEndpoint _ _) st =+    if st == status200 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st+statusCodeToError (CreateNetworkEndpoint _) st =+    if st == status201 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st+statusCodeToError (RemoveNetworkEndpoint _) st =+    if st == status204 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st

@@ -57,7 +57,7 @@ getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =             encodeURLWithQuery    [v, "containers", fromContainerID cid, "logs"] query         where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]-getEndpoint v (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =+getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =             encodeURLWithQuery [v, "containers", fromContainerID cid] query         where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))] getEndpoint v (InspectContainerEndpoint cid) =@@ -75,6 +75,9 @@         where query = [("fromImage", Just n), ("tag", Just t)]               n = encodeQ $ T.unpack name               t = encodeQ $ T.unpack tag+getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]+getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]+getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]  getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing@@ -94,6 +97,10 @@  getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing++getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing  getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"

@@ -11,6 +11,9 @@     , ImageID     , fromImageID     , toImageID+    , NetworkID+    , fromNetworkID+    , toNetworkID     , Timeout(..)     , StatusCode(..)     , Signal(..)@@ -37,12 +40,16 @@     , DetachKeys(..)     , StartOpts(..)     , defaultStartOpts-    , DeleteOpts(..)-    , defaultDeleteOpts+    , ContainerDeleteOpts(..)+    , defaultContainerDeleteOpts+    , ImageDeleteOpts(..)+    , defaultImageDeleteOpts     , Timestamp     , TailLogOpt(..)     , LogOpts(..)     , defaultLogOpts+    , CreateNetworkOpts(..)+    , defaultCreateNetworkOpts     , VolumePermission(..)     , Bind(..)     , Volume(..)@@ -68,6 +75,8 @@     , UTSMode(..)     , HostConfig(..)     , defaultHostConfig+    , NetworkingConfig(..)+    , EndpointConfig(..)     , Ulimit(..)     , ContainerResources(..)     , defaultContainerResources@@ -123,10 +132,13 @@       | UnpauseContainerEndpoint ContainerID       | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.       -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.-      | DeleteContainerEndpoint DeleteOpts ContainerID+      | DeleteContainerEndpoint ContainerDeleteOpts ContainerID       | InspectContainerEndpoint ContainerID       | BuildImageEndpoint BuildOpts FilePath       | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)+      | DeleteImageEndpoint ImageDeleteOpts ImageID+      | CreateNetworkEndpoint CreateNetworkOpts+      | RemoveNetworkEndpoint NetworkID     deriving (Eq, Show)  -- | We should newtype this@@ -611,20 +623,46 @@         return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels     parseJSON _ = fail "Failed to parse DockerImage." +-- | Alias for Aliases.+type Alias = Text +-- | EndpointsConfig is container configuration for a specific network+newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)++instance ToJSON EndpointConfig where+  toJSON (EndpointConfig aliases) = JSON.object+    [ "Aliases" .= aliases+    ]++-- | Alias for endpoint name+type EndpointName = Text++-- | Data type for the NetworkingConfig section of the container settings+newtype NetworkingConfig = NetworkingConfig+  { endpointsConfig :: HM.HashMap EndpointName EndpointConfig+  } deriving (Eq, Show)++instance ToJSON NetworkingConfig where+  toJSON (NetworkingConfig endpointsConfig) = JSON.object+    [ "EndpointsConfig" .= endpointsConfig+    ]+ -- | Options used for creating a Container. data CreateOpts = CreateOpts {-                  containerConfig :: ContainerConfig-                , hostConfig      :: HostConfig+                  containerConfig  :: ContainerConfig+                , hostConfig       :: HostConfig+                , networkingConfig :: NetworkingConfig                 } deriving (Eq, Show)  instance ToJSON CreateOpts where-    toJSON (CreateOpts cc hc) = do+    toJSON (CreateOpts cc hc nc) = 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+                let o1 = HM.insert "HostConfig" hcJSON o+                let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1+                JSON.Object o2             _ -> error "ContainerConfig is not an object." -- This should never happen.  -- | Container configuration used for creating a container with sensible@@ -706,7 +744,11 @@ -- | Default create options when creating a container. You only need to -- specify an image name and the rest is all sensible defaults. defaultCreateOpts :: T.Text -> CreateOpts-defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }+defaultCreateOpts imageName = CreateOpts+  { containerConfig  = defaultContainerConfig imageName+  , hostConfig       = defaultHostConfig+  , networkingConfig = NetworkingConfig HM.empty+  }  -- | Override the key sequence for detaching a container. -- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.@@ -720,7 +762,7 @@ defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }  -- | Options for deleting a container.-data DeleteOpts = DeleteOpts {+data ContainerDeleteOpts = ContainerDeleteOpts {                   deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.                 , force         :: Bool -- ^ If the container is still running force deletion anyway.                 } deriving (Eq, Show)@@ -750,9 +792,16 @@ -- | Default options for deleting a container. Most of the time we DON'T -- want to delete the container's volumes or force delete it if it's -- running.-defaultDeleteOpts :: DeleteOpts-defaultDeleteOpts = DeleteOpts { deleteVolumes = False, force = False }+defaultContainerDeleteOpts :: ContainerDeleteOpts+defaultContainerDeleteOpts = ContainerDeleteOpts { deleteVolumes = False, force = False } +-- | Image delete opts+data ImageDeleteOpts = ImageDeleteOpts deriving (Eq, Show)++-- | Sane image deletion defaults+defaultImageDeleteOpts :: ImageDeleteOpts+defaultImageDeleteOpts = ImageDeleteOpts+ -- | Timestamp alias. type Timestamp = Integer @@ -779,6 +828,36 @@                          , tail = All                          } +-- | Options for creating a network+data CreateNetworkOpts = CreateNetworkOpts+  { createNetworkName           :: Text -- ^ The network's name+  , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.+  , createNetworkDriver         :: Text -- ^ Name of the network driver plugin to use.+  , createNetworkInternal       :: Bool -- ^ Restrict external access to the network.+  , createNetworkEnableIPv6     :: Bool -- ^ Enable IPv6 on the network.+  } deriving (Eq, Show)++-- | Sensible defalut for create network options+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts+defaultCreateNetworkOpts name =+  CreateNetworkOpts+  { createNetworkName = name+  , createNetworkCheckDuplicate = False+  , createNetworkDriver = "bridge"+  , createNetworkInternal = True+  , createNetworkEnableIPv6 = False+  }++instance ToJSON CreateNetworkOpts where+  toJSON opts =+    object+      [ "Name" .= createNetworkName opts+      , "CheckDuplicate" .= createNetworkCheckDuplicate opts+      , "Driver" .= createNetworkDriver opts+      , "Internal" .= createNetworkInternal opts+      , "EnableIPv6" .= createNetworkEnableIPv6 opts+      ]+ -- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z") -- | Set permissions on volumes that you mount in the container. data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)@@ -953,6 +1032,26 @@     toJSON NetworkHost      = JSON.String "host"     toJSON NetworkDisabled  = JSON.String "none"     toJSON (NetworkNamed n) = JSON.String n++newtype NetworkID = NetworkID Text+    deriving (Eq, Show)++-- | Used for extracting the id of the container from the newtype+fromNetworkID :: NetworkID -> Text+fromNetworkID (NetworkID t) = t++-- | Used for parsing a Text value into a NetworkID.+toNetworkID :: Text -> Maybe NetworkID+toNetworkID t = Just $ NetworkID t++instance FromJSON NetworkID where+  parseJSON (JSON.Object o) = do+    nid <- o .: "Id"+    return $ NetworkID nid+  parseJSON _ = fail "NetworkID is not an object."++instance ToJSON NetworkID where+  toJSON (NetworkID nid) = object ["Id" .= nid]  data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord) 

@@ -2,6 +2,7 @@  module Main where +import           Data.Either               (rights) import           Prelude                   hiding (all) import qualified Test.QuickCheck.Monadic   as QCM import           Test.Tasty@@ -14,6 +15,7 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Class (lift) import qualified Data.Aeson                as JSON+import           Data.Aeson                ((.=)) import           Data.Aeson.Lens           (key, _Array, _Null, _Object,                                             _String, _Value) import qualified Data.ByteString           as B@@ -22,7 +24,7 @@ import qualified Data.HashMap.Strict       as HM import           Data.Int                  (Int) import qualified Data.Map                  as M-import           Data.Maybe                (fromJust, isJust)+import           Data.Maybe                (fromJust, isJust, isNothing, listToMaybe) import           Data.Monoid import           Data.Text                 (Text, unpack) import qualified Data.Vector               as V@@ -38,6 +40,7 @@  -- opts = defaultClientOpts testImageName = "docker-hs/test"+imageToDeleteFullName = "hello-world:latest"  toStrict1 = B.concat . BL.toChunks @@ -71,13 +74,27 @@   where     imageFullName = testImageName <> ":latest" +testDeleteImage :: IO ()+testDeleteImage = runDocker $ do+  (Just img) <- findTestImage+  result <- deleteImage defaultImageDeleteOpts (imageId img)+  lift $ assert $ isRight result+  maybeTestImageAfter <- findTestImage+  lift $ assert $ isNothing maybeTestImageAfter+  where+    findTestImage =+      do+        images <- listImages defaultListOpts >>= fromRight+        return $ listToMaybe+               $ filter (elem imageToDeleteFullName . imageRepoTags) images+ testListContainers :: IO () testListContainers =   runDocker $   do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing      c <- fromRight containerId      res <- listContainers $ ListOpts { all=True }-     deleteContainer (DeleteOpts True True) c+     deleteContainer (ContainerDeleteOpts True True) c      lift $ assert $ isRight res  testBuildFromDockerfile :: IO ()@@ -88,11 +105,19 @@     r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir     lift $ assert $ isRight r + testRunAndReadLog :: IO ()-testRunAndReadLog =+testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty++testRunAndReadLogWithNetworking :: IO ()+testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]++testRunAndReadLogHelper :: NetworkingConfig -> IO ()+testRunAndReadLogHelper networkingConfig =   runDocker $   do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}-     containerId <- createContainer (CreateOpts containerConfig defaultHostConfig) Nothing+     createdNetworks <- rights <$> mapM createNetworkWithName networkNames+     containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing      c <- fromRight containerId      status1 <- startContainer defaultStartOpts c      _ <- inspectContainer c >>= fromRight@@ -100,12 +125,25 @@      lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1      logs <- getContainerLogs defaultLogOpts c >>= fromRight      lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)-     status3 <- deleteContainer (DeleteOpts True True) c+     status3 <- deleteContainer (ContainerDeleteOpts True True) c      lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3+     mapM_ removeNetwork createdNetworks   where     isRightUnit (Right ()) = True     isRightUnit _          = False+    networkNames = HM.keys $ endpointsConfig networkingConfig+    createNetworkWithName name = createNetwork $+      (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True } +testCreateRemoveNetwork :: IO ()+testCreateRemoveNetwork = do+  runDocker $ do+    createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"+    lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus+    nid <- fromRight createStatus+    removeStatus <- removeNetwork nid+    lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus+ testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]   where@@ -184,6 +222,20 @@       testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==         Just (EnvVar "cellar" "door") +testNetworkingConfigJson :: TestTree+testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]+  where+    testSampleEncode =+      let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]+       in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==+        JSON.object+          [ "EndpointsConfig" .= JSON.object+            [ "custom-network" .= JSON.object+              [ "Aliases" .= (["cellar", "door"] :: [Text])+              ]+            ]+          ]+ integrationTests :: TestTree integrationTests =   testGroup@@ -191,9 +243,12 @@     [ testCase "Get docker version" testDockerVersion     , testCase "Build image from Dockerfile" testBuildFromDockerfile     , testCase "Find image by name" testFindImage+    , testCase "Delete image" testDeleteImage     , testCase "List containers" testListContainers     , testCase "Run a dummy container and read its log" testRunAndReadLog+    , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking     , testCase "Try to stop a container that doesn't exist" testStopNonexisting+    , testCase "Create and remove a network" testCreateRemoveNetwork     ]  jsonTests :: TestTree@@ -206,10 +261,15 @@     , testLogDriverOptionsJson     , testEntrypointJson     , testEnvVarJson+    , testNetworkingConfigJson     ]  setup :: IO ()-setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return ()+setup =+  mapM_ system+        [ "docker pull " ++ unpack imageToDeleteFullName+        , "docker build -t " ++ unpack testImageName ++ " tests"+        ]  isLeft = not . isRight