diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -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 diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -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 diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -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 diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -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" diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -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- where 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) diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -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