diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Deni Bertovic +Copyright (c) 2016, Deni Bertovic All rights reserved. diff --git a/Network/Docker.hs b/Network/Docker.hs deleted file mode 100644 --- a/Network/Docker.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Docker where - -import Control.Applicative ((<$>), (<*>)) -import Control.Lens -import Data.Aeson (FromJSON, ToJSON, decode, - eitherDecode, toJSON) -import Data.Aeson.Lens (key, _String) -import Data.Aeson.TH -import qualified Data.ByteString.Lazy as L -import Data.Char -import qualified Data.Text as T -import Network.Docker.Options -import Network.Docker.Types -import Network.HTTP.Client.OpenSSL -import Network.Wreq -import OpenSSL (withOpenSSL) -import OpenSSL.Session (SSLContext, context) -import qualified OpenSSL.Session as SSL -import Pipes -import qualified Pipes.ByteString as PB -import qualified Pipes.HTTP as PH -import Text.Printf (printf) - - -defaultClientOpts :: DockerClientOpts -defaultClientOpts = DockerClientOpts - { apiVersion = "v1.12" - , baseUrl = "http://127.0.0.1:3128/" - , ssl = NoSSL - } - -constructUrl :: URL -> ApiVersion -> Endpoint -> URL -constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint - -constructRelativeUrl url = url :: String - -decodeResponse r = decode <$> (^. responseBody) <$> r - -getOutOfResponse k r = (^? responseBody . key k . _String) r - -getResponseStatusCode r = (^. responseStatus) r - -fullUrl :: DockerClientOpts -> Endpoint -> URL -fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) endpoint - -setupSSLCtx :: SSLOptions -> IO SSLContext -setupSSLCtx (SSLOptions key cert) = do - ctx <- SSL.context - SSL.contextSetPrivateKeyFile ctx key - SSL.contextSetCertificateFile ctx cert - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 - return ctx - - -mkOpts c = defaults & manager .~ Left (opensslManagerSettings c) - -getSSL - :: SSLOptions - -> String - -> IO (Response L.ByteString) -getSSL sopts url = withOpenSSL $ getWith (mkOpts $ setupSSLCtx sopts) url - -postSSL - :: ToJSON a - => SSLOptions - -> String - -> a - -> IO (Response L.ByteString) -postSSL sopts url = withOpenSSL . postWith (mkOpts $ setupSSLCtx sopts) url . toJSON - -_dockerGetQuery :: Endpoint -> DockerClientOpts -> IO(Response L.ByteString) -_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} = - get (fullUrl clientOpts endpoint) -_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} = - getSSL sslOpts (fullUrl clientOpts endpoint) - -_dockerPostQuery :: ToJSON a => Endpoint -> DockerClientOpts -> a -> IO (Response L.ByteString) -_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} postObject = - post (fullUrl clientOpts endpoint) (toJSON postObject) -_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} postObject = - postSSL sslOpts (fullUrl clientOpts endpoint) postObject - -emptyPost = "" :: String -_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (toJSON emptyPost) - -_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint) - -getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion) -getDockerVersion = decodeResponse . _dockerGetQuery "/version" - -getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer]) -getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json" - -getAllDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer]) -getAllDockerContainers = decodeResponse . _dockerGetQuery "/containers/json?all=true" - -getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage]) -getDockerImages = decodeResponse . _dockerGetQuery "/images/json" - -getAllDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage]) -getAllDockerImages = decodeResponse . _dockerGetQuery "/images/json?all=true" - -createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text) -createContainer clientOpts createOpts = getOutOfResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts) - -startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status) -startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts - -stopContainer :: DockerClientOpts -> String -> IO (Status) -stopContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/stop" containerId) clientOpts - -killContainer :: DockerClientOpts -> String -> IO (Status) -killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts - -restartContainer :: DockerClientOpts -> String -> IO (Status) -restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts - -pauseContainer :: DockerClientOpts -> String -> IO (Status) -pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts - -unpauseContainer :: DockerClientOpts -> String -> IO (Status) -unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts - -deleteContainer :: DockerClientOpts -> String -> IO (Status) -deleteContainer = deleteContainerWithOpts defaultDeleteOpts - -deleteContainerWithOpts :: DeleteOpts -> DockerClientOpts -> String -> IO (Status) -deleteContainerWithOpts (DeleteOpts removeVolumes force) clientOpts containerId = (^. responseStatus) <$> _dockerEmptyDeleteQuery req clientOpts - where req = printf "/containers/%s?v=%s;force=%s" containerId (show removeVolumes) (show force) - -getContainerLogsStream :: DockerClientOpts -> String -> IO () -getContainerLogsStream clientOpts containerId = do - req <- PH.parseUrl (fullUrl clientOpts url) - let req' = req {PH.method = "GET"} - PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout - where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId) - -getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString) -getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts - where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId) - diff --git a/Network/Docker/Options.hs b/Network/Docker/Options.hs deleted file mode 100644 --- a/Network/Docker/Options.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Network.Docker.Options where - -import Data.Aeson.TH -import Network.Docker.Utils - -dopts :: Options -dopts = defaultOptions { - fieldLabelModifier = strip_underscore - } - - - diff --git a/Network/Docker/Types.hs b/Network/Docker/Types.hs deleted file mode 100644 --- a/Network/Docker/Types.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -module Network.Docker.Types where - -import Control.Applicative -import Control.Lens.TH -import Data.Aeson -import Data.Aeson.TH -import Data.Bool -import qualified Data.ByteString.Lazy as BS -import Data.Default -import qualified Data.Map as Map -import qualified Data.Text as T -import GHC.Generics -import Network.Docker.Options -import Network.Wreq.Types (Postable) -import OpenSSL.Session (SSLContext) -import Prelude hiding (id) - -type URL = String -type ApiVersion = String -type Endpoint = String - -type Tag = String -type IP = String -type Port = Int -type PortType = String - -data SSL = NoSSL | SSL SSLOptions deriving Show - -data DockerClientOpts = DockerClientOpts { - apiVersion :: ApiVersion - , baseUrl :: URL - , ssl :: SSL - } deriving (Show) - - -data SSLOptions = SSLOptions { - optionsKey :: FilePath - , optionsCert :: FilePath - } deriving Show - - -data ResourceId = ResourceId { _id :: String } deriving (Show, Eq) - - -data DockerImage = DockerImage - { _imageId :: ResourceId - , _imageCreatedAt :: Int - , _parentId :: Maybe String - , _repoTags :: [Tag] - , _size :: Int - , _virtualSize :: Int - } deriving (Show, Eq) - - -data DockerVersion = DockerVersion - { _Version :: String - , _GitCommit :: String - , _GoVersion :: String - , _Arch :: String - , _KernelVersion :: String - } deriving (Show, Eq) - - --- The JSON looks likes this: --- "Ports":[{"IP":"0.0.0.0","PrivatePort":55555,"PublicPort":55555,"Type":"tcp"}] - -data PortMap = PortMap - { _ip :: IP - , _privatePort :: Port - , _publicPort :: Port - , _type :: PortType - } deriving (Show, Eq) - -data DeleteOpts = DeleteOpts - { removeVolumes :: Bool - , force :: Bool - } - -defaultDeleteOpts = DeleteOpts False False - - -data DockerContainer = DockerContainer - { _containerId :: ResourceId - , _containerImageId :: ResourceId - , _command :: String - , _containerCreatedAt :: Int - , _names :: [String] - , _status :: String - , _ports :: Maybe [PortMap] - } deriving (Show, Eq) - - -data CreateContainerOpts = CreateContainerOpts - { _hostname :: String - , _user :: String - , _memory :: Int - , _memorySwap :: Int - , _attachStdin :: Bool - , _attachStdout :: Bool - , _attachStderr :: Bool - , _portSpecs :: Maybe Object - , _tty :: Bool - , _openStdin :: Bool - , _stdinOnce :: Bool - , _env :: Maybe Object - , _cmd :: [String] - , _image :: String - , _volumes :: Maybe Object - , _volumesFrom :: Maybe Object - , _workingDir :: String - , _disableNetwork :: Bool - , _exposedPorts :: Maybe Object - } deriving (Show) - -defaultCreateOpts = CreateContainerOpts { - _hostname = "" - , _user = "" - , _memory = 0 - , _memorySwap = 0 - , _attachStdin = False - , _attachStdout = False - , _attachStderr = False - , _portSpecs = Nothing - , _tty = False - , _openStdin = False - , _stdinOnce = False - , _env = Nothing - , _cmd = [] - , _image = "debian" - , _volumes = Nothing - , _volumesFrom = Nothing - , _workingDir = "" - , _disableNetwork = False - , _exposedPorts = Nothing - } - -instance ToJSON CreateContainerOpts where - toJSON (CreateContainerOpts {..}) = object - [ "Hostname" .= _hostname - , "User" .= _user - , "Memory" .= _memory - , "MemorySwap" .= _memorySwap - , "AttachStdin" .= _attachStdin - , "AttachStdout" .= _attachStdout - , "AttachStderr" .= _attachStderr - , "PortSpecs" .= _portSpecs - , "Tty" .= _tty - , "OpenStdin" .= _openStdin - , "StdinOnce" .= _stdinOnce - , "Env" .= _env - , "Cmd" .= _cmd - , "Image" .= _image - , "Volumes" .= _volumes - , "VolumesFrom" .= _volumesFrom - , "WrokingDir" .= _workingDir - , "DisableNetwork" .= _disableNetwork - , "ExposedPorts" .= _exposedPorts - ] - --- data CreateContainerResponse = CreateContainerResponse --- { _createdContainerId :: String --- , _warnings :: Maybe [T.Text] --- } deriving (Show) - -data StartContainerOpts = StartContainerOpts - { _Binds :: [T.Text] - , _Links :: [T.Text] - , _LxcConf :: [(T.Text, T.Text)] - , _PortBindings :: [((Int,T.Text),Int)] - , _PublishAllPorts :: Bool - , _Privileged :: Bool - , _Dns :: [T.Text] - , _VolumesFrom :: [T.Text] - , _RestartPolicy :: RestartPolicy - } deriving (Show) - -defaultStartOpts = StartContainerOpts - { _Binds = [] - , _Links = [] - , _LxcConf = [] - , _PortBindings = [] - , _PublishAllPorts = False - , _Privileged = False - , _Dns = [] - , _VolumesFrom = [] - , _RestartPolicy = RestartNever - } - -instance ToJSON StartContainerOpts where - toJSON (StartContainerOpts {..}) = object - [ "Binds" .= _Binds - , "Links" .= _Links - , "LxcConf" .= _LxcConf - , "PortBindings" .= object (map (\((h,p),c)->T.concat [T.pack (show h),"/",p] .= [object ["HostPort" .= show c]]) _PortBindings) - , "PublishAllPorts" .= _PublishAllPorts - , "Privileged" .= _Privileged - , "Dns" .= _Dns - , "VolumesFrom" .= _VolumesFrom - , "RestartPolicy" .= _RestartPolicy - ] - -data RestartPolicy = RestartNever - | RestartAlways - | RestartOnFailure Int - deriving (Show) - -instance ToJSON RestartPolicy where - toJSON RestartNever = object ["Name" .= (""::String), "MaximumRetryCount" .= (0::Int) ] - toJSON RestartAlways = object ["Name" .= ("always"::String), "MaximumRetryCount" .= (0::Int) ] - toJSON (RestartOnFailure n) = object ["Name" .= ("on-failure"::String), "MaximumRetryCount" .= n ] - -makeClassy ''ResourceId - --- makeLenses ''CreateContainerResponse -makeLenses ''DockerImage -makeLenses ''DockerContainer -makeLenses ''CreateContainerOpts - -instance HasResourceId DockerImage where - resourceId = imageId - -instance FromJSON DockerImage where - parseJSON (Object v) = - DockerImage <$> ResourceId <$> (v .: "Id") - <*> (v .: "Created") - <*> (v .:? "ParentId") - <*> (v .: "RepoTags") - <*> (v .: "Size") - <*> (v .: "VirtualSize") - -instance FromJSON PortMap where - parseJSON (Object v) = - PortMap <$> (v .: "IP") - <*> (v .: "PrivatePort") - <*> (v .: "PublicPort") - <*> (v .: "Type") - -instance HasResourceId DockerContainer where - resourceId = containerId - -instance FromJSON DockerContainer where - parseJSON (Object v) = - DockerContainer <$> (ResourceId <$> (v .: "Id")) - <*> (ResourceId <$> (v .: "Id")) - <*> (v .: "Command") - <*> (v .: "Created") - <*> (v .: "Names") - <*> (v .: "Status") - <*> (v .:? "Ports") - --- instance FromJSON CreateContainerResponse where --- parseJSON (Object v) = --- CreateContainerResponse <$> (v .: "Id") --- <*> (v .:? "warnings") - -$(deriveJSON dopts ''DockerVersion) - diff --git a/Network/Docker/Utils.hs b/Network/Docker/Utils.hs deleted file mode 100644 --- a/Network/Docker/Utils.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Network.Docker.Utils where - -import Data.Char - -strip_underscore :: String -> String -strip_underscore (_:xs) = xs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,26 @@ -# Docker Remote API wrapper for Haskell +# An API client for docker written in Haskell -## Work in progress +| Master | Dev | +| -------| ---- | +| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) | [![dev](https://travis-ci.org/denibertovic/docker-hs.svg?branch=dev)](https://travis-ci.org/denibertovic/docker-hs) | + + +## Current state + +**Not production ready yet!** + +The library is going through a **total rewrite**. + +See [Issue #12](https://github.com/denibertovic/docker-hs/issues/12) for things +that need to happen before a new release. + + +## Contributing + +If you wish to contribute please see the Issue mentioned above or any issue tagged with "help wanted". +Make sure to submit your PR's against the `dev` branch. + +Please consider filling an Issue first and discuss design decisions and implementation details before +writing any code. This is so that no development cycles go to waste on implementing a feature that +might not get merged either because of implementation details or other reasons. + diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -1,16 +1,13 @@ --- Initial docker.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: docker -version: 0.2.0.4 -synopsis: Haskell wrapper for Docker Remote API --- description: +version: 0.3.0.0 +synopsis: An API client for docker written in Haskell +description: See README.md homepage: https://github.com/denibertovic/docker-hs license: BSD3 license-file: LICENSE -author: Deni Bertovic -maintainer: deni@denibertovic.com --- copyright: +author: Deni Bertovic , James Parker +maintainer: Deni Bertovic +copyright: BSD3 category: Network build-type: Simple extra-source-files: README.md @@ -18,52 +15,56 @@ stability: experimental library - exposed-modules: Network.Docker, Network.Docker.Options, Network.Docker.Types, Network.Docker.Utils - -- other-modules: - other-extensions: OverloadedStrings, DeriveFunctor, FlexibleContexts, TemplateHaskell - build-depends: base >= 4.7 && < 4.9 - , lens >= 4.2 - , aeson >= 0.7 - , lens-aeson - , bytestring >= 0.10 - , text >= 1.1 - , wreq >= 0.3 - , containers >= 0.5 - , data-default >= 0.5.3 - , network-uri >= 2.6.0.1 - , pipes-http >= 1.0.0 - , pipes >= 4.1.2 - , pipes-text >= 0.0.0.12 - , pipes-bytestring >= 2.1.0 - , HsOpenSSL - , http-client-openssl - -- hs-source-dirs: + default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances + hs-source-dirs: src + exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http + -- other-modules: Docker.Internal + build-depends: base >= 4.7 && < 5 + , aeson >= 0.9.0 && < 1.1.0 + , blaze-builder >= 0.4.0 && < 0.5.0 + , bytestring >= 0.10.0 && < 0.11.0 + , containers >= 0.5.0 && < 0.6.0 + , data-default-class >= 0.0.1 && < 0.2.0 + , http-client >= 0.4.0 && < 0.6.0 + , http-types >= 0.9 && < 0.10.0 + , mtl >= 2.0.0 && < 3.0.0 + , network >= 2.6.0 + , text >= 1.0.0 && < 2.0.0 + , time >= 1.5.0 && < 1.7.0 + , scientific >= 0.3.0 && < 0.4.0 + , tls >= 1.3.7 && < 1.4.0 + , unordered-containers >= 0.2.0 && < 0.3.0 + , x509 >= 1.6.0 && < 1.7.0 + , x509-store >= 1.6.0 && < 1.7.0 + , x509-system >= 1.6.0 && < 1.7.0 default-language: Haskell2010 + ghc-options: -Wall -fno-warn-name-shadowing -test-suite tests - build-depends: base >= 4.7 && < 4.9 +test-suite docker-hs-tests + build-depends: base >= 4.7 && < 5 + , bytestring + , connection , docker - , lens >= 4.2 - , aeson >= 0.7 + , aeson + , containers + , unordered-containers + , http-client + , http-client-tls + , http-types + , tasty + , tasty-hunit + , tasty-quickcheck + , text + , lens , lens-aeson - , bytestring >= 0.10 - , text >= 1.1 - , wreq >= 0.3 - , containers >= 0.5 - , data-default >= 0.5.3 - , pipes >= 4.1.2 - , pipes-http >= 1.0.0 - , pipes-text >= 0.0.0.12 - , pipes-bytestring >= 2.1.0 - , tasty >= 0.10.1 - , tasty-quickcheck >= 0.8.2 - , QuickCheck >= 2.7 - , tasty-hunit >= 0.8 + , transformers + , QuickCheck , process - , http-types - , HsOpenSSL - , http-client-openssl type: exitcode-stdio-1.0 main-is: tests.hs hs-source-dirs: tests default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/denibertovic/docker-hs diff --git a/src/Docker/Client.hs b/src/Docker/Client.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module : Docker.Client +Copyright : (c) Deni Bertovic, 2016 +License : BSD3 +Maintainer : deni@denibertovic.com +Stability : experimental +Portability : POSIX + += Getting started + +Creating a container: + +We're going to create a nginx container and we're going to map port @80@ from within the container to port @8000@ on +the host. + +@ +import Docker.Client + +runNginxContainer :: IO ContainerID +runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do + let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000] + let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest" + cid <- createContainer myCreateOpts + case cid of + Left err -> error $ show err + Right i -> do + _ <- startContainer defaultStartOpts i + return i +@ + +Let's start out nginx container: + +>>> cid <- runNginxContainer + + +Visit http://localhost:8000 and verify that nginx is running. + +Let's stop the container now: + +@ +stopNginxContainer :: ContainerID -> IO () +stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do + r <- stopContainer DefaultTimeout cid + case r of + Left err -> error "I failed to stop the container" + Right _ -> return () +@ + +>>> stopNginxContainer cid + +Let's start a Postgres container by mapping the \/tmp directory from within the container to the +\/tmp directory on the host. That way we make sure that the data we write to \/tmp in the container will +persist on the host file system. + +@ +runPostgresContainer :: IO ContainerID +runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do + let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432] + let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5" + cid <- createContainer myCreateOpts + case cid of + Left err -> error $ show err + Right i -> do + _ <- startContainer defaultStartOpts i + return i +@ + += Get Docker API Version + +>>> runDockerT (defaultClientOpts, defaultHttpHandler) $ getDockerVersion +Right (DockerVersion {version = "1.12.0", apiVersion = "1.24", gitCommit = "8eab29e", goVersion = "go1.6.3", os = "linux", arch = "amd64", kernelVersion = "4.6.0-1-amd64", buildTime = "2016-07-28T21:46:40.664812891+00:00"}) + += Setup SSL Authentication + +Let's create a custom 'HttpHandler' that uses a client's certificate and private key for SSL authentication. +It also accepts a self-signed CA certificate which is specified via 'clientParamsSetCA'. +This handler can replace 'defaultHttpHandler' in the arguments to 'runDockerT'. + +@ +let host = "domain.name" +let port = fromInteger 4000 +let privKey = "path\/to\/private\/key" +let cert = "path\/to\/certificate" +let ca = "path\/to\/CA" +paramsE <- clientParamsWithClientAuthentication host port privKey cert +case paramsE of + Left err -> + error err + Right params' -> do + params <- clientParamsSetCA params' ca + settings <- HTTP.mkManagerSettings (TLSSettings params) Nothing + manager <- newManager settings + return $ httpHandler manager +@ + + +-} +module Docker.Client ( + -- * Client functions + module Docker.Client.Api + -- * Types + , module Docker.Client.Types + -- * Http + , module Docker.Client.Http + ) where + +import Docker.Client.Api +import Docker.Client.Http +import Docker.Client.Types diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client/Api.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Docker.Client.Api ( + -- * Containers + listContainers + , createContainer + , startContainer + , stopContainer + , killContainer + , restartContainer + , pauseContainer + , unpauseContainer + , deleteContainer + , inspectContainer + , getContainerLogs + -- * Images + , listImages + -- * Other + , getDockerVersion + ) where + +import Control.Monad.Except (ExceptT (..), runExceptT, throwError) +import Control.Monad.Reader (ask, lift) +import Data.Aeson (FromJSON, eitherDecode') +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as Text +import Network.HTTP.Client (responseBody, responseStatus) +import Network.HTTP.Types (StdMethod (..)) + +import Docker.Client.Http +import Docker.Client.Types + +requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ()) +requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint + +requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response) +requestHelper verb endpoint = runExceptT $ do + (opts, httpHandler) <- lift ask + case mkHttpRequest verb endpoint opts of + Nothing -> + throwError $ DockerInvalidRequest endpoint + Just request -> do + response <- ExceptT $ lift $ httpHandler request + + -- Check status code. + let status = responseStatus response + maybe (return ()) throwError $ + statusCodeToError endpoint status + + return response + +parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a) +parseResponse (Left err) = + return $ Left err +parseResponse (Right response) = + -- Parse request body. + case eitherDecode' $ responseBody response of + Left err -> + return $ Left $ DockerClientDecodeError $ Text.pack err + Right r -> + return $ Right r + +-- | Gets the version of the docker engine remote API. +getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion) +getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse + +-- | Lists all running docker containers. Pass in @'defaultListOpts' {all +-- = True}@ to get a list of stopped containers as well. +listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container]) +listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse + +-- | Lists all docker images. +listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image]) +listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse + +-- | 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. +createContainer :: forall m. Monad m => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID) +createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse + +-- | Start a container from a given 'ContainerID' that we get from +-- 'createContainer'. See 'StartOpts' for a list of configuration options +-- for starting a container. Use 'defaultStartOpts' for sane defaults. +startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ()) +startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid + +-- | Attempts to stop a container with the given 'ContainerID' gracefully +-- (SIGTERM). +-- The docker daemon will wait for the given 'Timeout' and then send +-- a SIGKILL killing the container. +stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ()) +stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid + +-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same +-- as 'stopContainer' but you choose the signal directly. +killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ()) +killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid + +-- | Restarts a container with the given 'ContainerID'. +restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ()) +restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid + +-- | Pauses a container with the given 'ContainerID'. +pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ()) +pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid + +-- | Unpauses a container with the given 'ContainerID'. +unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ()) +unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid + +-- | Deletes a container with the given 'ContainerID'. +-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane +-- defaults. +deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ()) +deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid + +-- | Gets 'ContainerDetails' for a given 'ContainerID'. +inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails) +inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse + +-- | Get's container's logs for a given 'ContainerID'. +-- This will only work with the 'JsonFile' 'LogDriverType' as the other driver types disable +-- this endpoint and it will return a 'DockerError'. +-- +-- See 'LogOpts' for options that you can pass and +-- 'defaultLogOpts' for sane defaults. +-- +-- __NOTE__: Currently streaming logs is +-- not supported and this function will fetch the entire log that the +-- container produced in the json-file on disk. Depending on the logging +-- setup of the process in your container this can be a significant amount +-- which might block your application...so use with caution. +-- +-- The recommended method is to use one of the other 'LogDriverType's available (like +-- syslog) for creating your containers. +getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString) +getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid) + +-- TODO: Use http-conduit to output to a sink. +-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b) +-- getContainerLogsStream sink logopts cid = runResourceT $ do +-- response <- http request manager +-- responseBody response C.$$+- sink + diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client/Http.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Docker.Client.Http where + +import Control.Monad.Reader (ReaderT, runReaderT) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BL +import Data.Default.Class (def) +import Data.Monoid ((<>)) +import Data.Text.Encoding (encodeUtf8) +import Data.X509 (CertificateChain (..)) +import Data.X509.CertificateStore (makeCertificateStore) +import Data.X509.File (readKeyFile, readSignedObject) +import Network.HTTP.Client (defaultManagerSettings, httpLbs, + managerRawConnection, method, + newManager, parseUrl, + requestBody, requestHeaders) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client.Internal (makeConnection) +import Network.HTTP.Types (StdMethod, status101, status200, + status201, status204) +import Network.TLS (ClientHooks (..), + ClientParams (..), Shared (..), + Supported (..), + defaultParamsClient) +import Network.TLS.Extra (ciphersuite_strong) +import System.X509 (getSystemCertificateStore) + +import Control.Exception (try) +import Control.Monad.Except +import Control.Monad.Reader.Class +import Data.Text as T +import Data.Typeable (Typeable) +import qualified Network.HTTP.Types as HTTP +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SBS + + +import Docker.Client.Internal (getEndpoint, + getEndpointRequestBody) +import Docker.Client.Types (DockerClientOpts, Endpoint (..), + baseUrl) + +type Request = HTTP.Request +type Response = HTTP.Response BL.ByteString +type HttpVerb = StdMethod +type HttpHandler m = Request -> m (Either DockerError Response) + +data DockerError = DockerConnectionError + | DockerInvalidRequest Endpoint + | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint. + | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint. + | GenericDockerError Text deriving (Eq, Show, Typeable) + +newtype DockerT m a = DockerT { + unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a + } deriving (Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans + +instance Applicative m => Applicative (DockerT m) where + pure a = DockerT $ pure a + (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v + +instance Monad m => Monad (DockerT m) where + (DockerT m) >>= f = DockerT $ m >>= unDockerT . f + return = pure + +instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where + ask = DockerT ask + local f (DockerT m) = DockerT $ local f m + +instance MonadTrans DockerT where + lift m = DockerT $ lift m + +instance MonadIO m => MonadIO (DockerT m) where + liftIO = lift . liftIO + +runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a +runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h) + +-- The reason we return Maybe Request is because the parseURL function +-- might find out parameters are invalid and will fail to build a Request +-- Since we are the ones building the Requests this shouldn't happen, but would +-- benefit from testing that on all of our Endpoints +mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request +mkHttpRequest verb e opts = request + where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e) + initialR = parseUrl fullE + request' = case initialR of + Just ir -> + return $ ir {method = (encodeUtf8 . T.pack $ show verb), + requestHeaders = [("Content-Type", "application/json; charset=utf-8")]} + Nothing -> Nothing + request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body, + requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request' + -- Note: Do we need to set length header? + +defaultHttpHandler :: MonadIO m => HttpHandler m +defaultHttpHandler request = do + manager <- liftIO $ newManager defaultManagerSettings + httpHandler manager request + +httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m +httpHandler manager request = liftIO $ do + try (httpLbs request manager) >>= \res -> case res of + Right res -> return $ Right res + Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError + Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError + Left e -> return $ Left $ GenericDockerError (T.pack $ show e) + +-- | Connect to a unix domain socket (the default docker socket is +-- at \/var\/run\/docker.sock) +-- +-- Docker seems to ignore the hostname in requests sent over unix domain +-- sockets (and the port obviously doesn't matter either) +unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to + -> HttpHandler m +unixHttpHandler fp request = do + let mSettings = defaultManagerSettings + { managerRawConnection = return $ openUnixSocket fp} + manager <- liftIO $ newManager mSettings + httpHandler manager request + + where + openUnixSocket filePath _ _ _ = do + s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect s (S.SockAddrUnix filePath) + makeConnection (SBS.recv s 8096) + (SBS.sendAll s) + (S.sClose s) + +-- TODO: +-- Move this to http-client-tls or network? +-- Add CA. +-- Maybe change this to: HostName -> PortNumber -> ClientParams -> IO (Either String TLSSettings) +clientParamsWithClientAuthentication :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO (Either String ClientParams) +clientParamsWithClientAuthentication host port keyFile certificateFile = do + keys <- readKeyFile keyFile + cert <- readSignedObject certificateFile + case keys of + [key] -> + -- TODO: load keys/path from file + let params = (defaultParamsClient host $ BSC.pack $ show port) { + clientHooks = def + { onCertificateRequest = \_ -> return (Just (CertificateChain cert, key))} + , clientSupported = def + { supportedCiphers = ciphersuite_strong} + } + in + return $ Right params + _ -> + return $ Left $ "Could not read key file: " ++ keyFile + +clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams +clientParamsSetCA params path = do + userStore <- makeCertificateStore <$> readSignedObject path + systemStore <- getSystemCertificateStore + let store = userStore <> systemStore + let oldShared = clientShared params + return $ params { clientShared = oldShared + { sharedCAStore = store } + } + + +-- If the status is an error, returns a Just DockerError. Otherwise, returns Nothing. +statusCodeToError :: Endpoint -> HTTP.Status -> Maybe DockerError +statusCodeToError VersionEndpoint st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (ListContainersEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (ListImagesEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (CreateContainerEndpoint _ _) st = + if st == status201 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (StartContainerEndpoint _ _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (StopContainerEndpoint _ _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (KillContainerEndpoint _ _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (RestartContainerEndpoint _ _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (PauseContainerEndpoint _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (UnpauseContainerEndpoint _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (ContainerLogsEndpoint _ _ _) st = + if st == status200 || st == status101 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (DeleteContainerEndpoint _ _) st = + if st == status204 then + Nothing + else + Just $ DockerInvalidStatusCode st +statusCodeToError (InspectContainerEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st + + diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client/Internal.hs @@ -0,0 +1,75 @@ +module Docker.Client.Internal where + + +import Blaze.ByteString.Builder (toByteString) +import qualified Data.Aeson as JSON +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Network.HTTP.Types (Query, encodePath, + encodePathSegments) + +import Docker.Client.Types + + +encodeURL :: [T.Text] -> T.Text +encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps + +encodeURLWithQuery :: [T.Text] -> Query -> T.Text +encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q + +encodeQ :: String -> ByteString +encodeQ = encodeUtf8 . T.pack + +getEndpoint :: Endpoint -> T.Text +getEndpoint VersionEndpoint = encodeURL ["version"] +getEndpoint (ListContainersEndpoint _) = encodeURL ["containers", "json"] -- Make use of lsOpts here +getEndpoint (ListImagesEndpoint _) = encodeURL ["images", "json"] -- Make use of lsOpts here +getEndpoint (CreateContainerEndpoint _ cn) = case cn of + Just cn -> encodeURLWithQuery ["containers", "create"] [("name", Just (encodeQ $ T.unpack cn))] + Nothing -> encodeURL ["containers", "create"] +getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", fromContainerID cid, "start"] query + where query = case (detachKeys startOpts) of + WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))] + WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))] + DefaultDetachKey -> [] + ctrl = ['c', 't', 'r', 'l', '-'] +getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "stop"] query + where query = case t of + Timeout x -> [("t", Just (encodeQ $ show x))] + DefaultTimeout -> [] +getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query + where query = case s of + SIG x -> [("signal", Just (encodeQ $ show x))] + _ -> [("signal", Just (encodeQ $ show s))] +getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "restart"] query + where query = case t of + Timeout x -> [("t", Just (encodeQ $ show x))] + DefaultTimeout -> [] +getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"] +getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"] +-- Make use of since/timestamps/tail logopts here instead of ignoreing them +getEndpoint (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) = + encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query + where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))] +getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) = + encodeURLWithQuery ["containers", fromContainerID cid] query + where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))] +getEndpoint (InspectContainerEndpoint cid) = + encodeURLWithQuery ["containers", fromContainerID cid, "json"] [] + +getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString +getEndpointRequestBody VersionEndpoint = Nothing +getEndpointRequestBody (ListContainersEndpoint _) = Nothing +getEndpointRequestBody (ListImagesEndpoint _) = Nothing +getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts +getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing +getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing +getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing +getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing +getEndpointRequestBody (PauseContainerEndpoint _) = Nothing +getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing +getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing +getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing +getEndpointRequestBody (InspectContainerEndpoint _) = Nothing diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client/Types.hs @@ -0,0 +1,1423 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Docker.Client.Types ( + Endpoint(..) + , URL + , ApiVersion + , ContainerID + , fromContainerID + , toContainerID + , ImageID + , fromImageID + , toImageID + , Timeout(..) + , Signal(..) + , ContainerDetails(..) + , DockerClientOpts(..) + , defaultClientOpts + , ListOpts(..) + , defaultListOpts + , DockerVersion(..) + , ContainerPortInfo(..) + , Container(..) + , ContainerState(..) + , Status(..) + , Digest + , Label(..) + , Tag + , Image(..) + , dropImagePrefix + , CreateOpts(..) + , defaultCreateOpts + , DetachKeys(..) + , StartOpts(..) + , defaultStartOpts + , DeleteOpts(..) + , defaultDeleteOpts + , Timestamp + , TailLogOpt(..) + , LogOpts(..) + , defaultLogOpts + , VolumePermission(..) + , Bind(..) + , Volume(..) + , Device(..) + , ContainerName + , VolumeFrom(..) + , Link(..) + , LogDriverType(..) + , LogDriverOption(..) + , LogDriverConfig(..) + , NetworkMode(..) + , PortType(..) +-- , NetworkInterface(..) + , Network(..) + , NetworkSettings(..) + , NetworkOptions(..) + , Mount(..) + , PortBinding(..) + , HostPort(..) + , RetryCount + , RestartPolicy(..) + , Isolation(..) + , UTSMode(..) + , HostConfig(..) + , defaultHostConfig + , Ulimit(..) + , ContainerResources(..) + , defaultContainerResources + , Port + , Name + , Value + , EnvVar(..) + , ContainerConfig(..) + , defaultContainerConfig + , ExposedPort(..) + , DeviceWeight(..) + , DeviceRate(..) + , addPortBinding + , addExposedPort + , addBind + , setCmd + , addLink + , addVolume + , addVolumeFrom + ) where + +import Data.Aeson (FromJSON, ToJSON, genericParseJSON, + genericToJSON, object, parseJSON, toJSON, + (.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson as JSON +import Data.Aeson.Types (defaultOptions, fieldLabelModifier) +import Data.Char (isAlphaNum, toUpper) +import qualified Data.HashMap.Strict as HM +import Data.Monoid ((<>)) +import Data.Scientific (floatingOrInteger) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) +import Prelude hiding (all, tail) +import Text.Read (readMaybe) + +-- | List of Docker Engine API endpoints +data Endpoint = + VersionEndpoint + | ListContainersEndpoint ListOpts + | ListImagesEndpoint ListOpts + | CreateContainerEndpoint CreateOpts (Maybe ContainerName) + | StartContainerEndpoint StartOpts ContainerID + | StopContainerEndpoint Timeout ContainerID + | KillContainerEndpoint Signal ContainerID + | RestartContainerEndpoint Timeout ContainerID + | PauseContainerEndpoint ContainerID + | 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 + | InspectContainerEndpoint ContainerID + deriving (Eq, Show) + +-- | We should newtype this +type URL = Text + +-- | We should newtype this +type ApiVersion = Text + + +-- | ID of a contianer +newtype ContainerID = ContainerID Text + deriving (Eq, Show) + +-- | Used for extracting the id of the container from the newtype +fromContainerID :: ContainerID -> Text +fromContainerID (ContainerID t) = t + +-- | Used for parsing a Text value into a ContainerID. We apply some basic +-- validation here. +toContainerID :: Text -> Maybe ContainerID +toContainerID t = + if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist? + Just $ ContainerID t + else + Nothing + +-- ID of an image. +newtype ImageID = ImageID Text + deriving (Eq, Show) + +-- | Used for extracting the id of the image from the newtype. +fromImageID :: ImageID -> Text +fromImageID (ImageID t) = t + +-- | Helper function used for parsing a Text value into an ImageID. For now +-- just basic validation is used. +toImageID :: Text -> Maybe ImageID +toImageID t = + if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist? + Just $ ImageID t + else + Nothing + +-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds. +data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show) + +-- TODO: Add more Signals or use an existing lib +-- | Signal used for sending to the process running in the container. +-- The default signal is SIGTERM. +data Signal = SIGHUP + | SIGINT + | SIGQUIT + | SIGSTOP + | SIGTERM + | SIGUSR1 + | SIG Integer + | SIGKILL deriving (Eq, Show) + +instance FromJSON Signal where + parseJSON (JSON.String "SIGTERM") = return SIGTERM + parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these. + parseJSON (JSON.String "SIGINT") = return SIGINT + parseJSON (JSON.String "SIGQUIT") = return SIGQUIT + parseJSON (JSON.String "SIGSTOP") = return SIGSTOP + parseJSON (JSON.String "SIGUSR1") = return SIGUSR1 + parseJSON _ = fail "Unknown Signal" + +instance ToJSON Signal where + toJSON SIGHUP = "SIGHUP" + toJSON SIGINT = "SIGINT" + toJSON SIGQUIT = "SIGQUIT" + toJSON SIGSTOP = "SIGSTOP" + toJSON SIGTERM = "SIGTERM" + toJSON SIGUSR1 = "SIGUSR1" + toJSON (SIG i) = toJSON i + toJSON SIGKILL = "SIGKILL" + +data ContainerDetails = ContainerDetails { + appArmorProfile :: Text + , args :: [Text] + , containerDetailsConfig :: ContainerConfig + , created :: UTCTime + , driver :: Text + -- , execIDs -- Not sure what this is in 1.24 spec. + , containerDetailsHostConfig :: HostConfig + , hostnamePath :: FilePath + , hostsPath :: FilePath + , logPath :: FilePath + , containerDetailsId :: ContainerID + , containerDetailsImage :: ImageID + , mountLabel :: Text + , name :: Text + , networkSettings :: NetworkSettings + , path :: FilePath + , processLabel :: Text + , resolveConfPath :: FilePath + , restartCount :: Int + , state :: ContainerState + , mounts :: [Mount] + } + deriving (Eq, Show, Generic) + +-- | Data type used for parsing the mount information from a container +-- list. +data Mount = Mount { + mountName :: Text + , mountSource :: FilePath + , mountDestination :: FilePath + , mountDriver :: Text + , mountMode :: Maybe VolumePermission -- apparently this can be null + , mountRW :: Bool + , mountPropogation :: Text + } + deriving (Eq, Show, Generic) + +instance FromJSON Mount where + parseJSON (JSON.Object o) = do + name <- o .: "Name" + src <- o .: "Source" + dest <- o .: "Destination" + driver <- o .: "Driver" + mode <- o .: "Mode" + rw <- o .: "RW" + prop <- o .: "Propagation" + return $ Mount name src dest driver mode rw prop + parseJSON _ = fail "Mount is not an object" + +-- | Data type used for parsing the container state from a list of +-- containers. +data ContainerState = ContainerState { + containerError :: Text + , exitCode :: Int + , finishedAt :: Maybe UTCTime -- Note: Is this a maybe? + , oomKilled :: Bool + , dead :: Bool + , paused :: Bool + , pid :: Int + , restarting :: Bool + , running :: Bool + , startedAt :: UTCTime + , status :: Status + } + deriving (Eq, Show, Generic) + +instance FromJSON ContainerState where + parseJSON (JSON.Object o) = do + err <- o .: "Error" + exit <- o .: "ExitCode" + finished <- o .:? "FinishedAt" + oomKilled <- o .: "OOMKilled" + dead <- o .: "Dead" + paused <- o .: "Paused" + pid <- o .: "Pid" + restarting <- o .: "Restarting" + running <- o .: "Running" + started <- o .: "StartedAt" + st <- o .: "Status" + return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st + parseJSON _ = fail "ContainerState is not an object" + + +-- | Client options used to configure the remote engine we're talking to +data DockerClientOpts = DockerClientOpts { + apiVer :: ApiVersion + , baseUrl :: URL + } + deriving (Eq, Show) + +-- | Default "DockerClientOpts" used for talking to the docker engine. +defaultClientOpts :: DockerClientOpts +defaultClientOpts = DockerClientOpts { + apiVer = "v1.24" + , baseUrl = "http://127.0.0.1:2375" + } + +-- | List options used for filtering the list of container or images. +data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show) + +-- | Default "ListOpts". Doesn't list stopped containers. +defaultListOpts :: ListOpts +defaultListOpts = ListOpts { all=False } + +-- | Data type used for represneting the version of the docker engine +-- remote API. +data DockerVersion = DockerVersion { + version :: Text + , apiVersion :: ApiVersion + , gitCommit :: Text + , goVersion :: Text + , os :: Text + , arch :: Text + , kernelVersion :: Text + , buildTime :: Text + } deriving (Show, Eq, Generic) + + +instance ToJSON DockerVersion where + toJSON = genericToJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +instance FromJSON DockerVersion where + parseJSON = genericParseJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +instance FromJSON ContainerDetails where + parseJSON v@(JSON.Object o) = do + appArmor <- o .: "AppArmorProfile" + args <- o .: "Args" + config <- o .: "Config" + created <- o .: "Created" + driver <- o .: "Driver" + hostConfig <- o .: "HostConfig" + hostnamePath <- o .: "HostnamePath" + hostsPath <- o .: "HostsPath" + logPath <- o .: "LogPath" + id <- parseJSON v + image <- o .: "Image" + mountLabel <- o .: "MountLabel" + name <- o .: "Name" + networkSettings <- o .: "NetworkSettings" + path <- o .: "Path" + processLabel <- o .: "ProcessLabel" + resolveConfPath <- o .: "ResolvConfPath" + restartCount <- o .: "RestartCount" + state <- o .: "State" + mounts <- o .: "Mounts" + return $ ContainerDetails appArmor args config created driver hostConfig hostnamePath hostsPath logPath id image mountLabel name networkSettings path processLabel resolveConfPath restartCount state mounts + parseJSON _ = fail "ContainerDetails is not an object" + +instance ToJSON ContainerID where + toJSON (ContainerID cid) = object ["Id" .= cid] + +instance FromJSON ContainerID where + parseJSON (JSON.Object o) = do + cid <- o .: "Id" + case toContainerID cid of + Nothing -> + fail "Invalid ContainerID" + Just cid -> + return cid + parseJSON _ = fail "ContainerID is not an object." + +instance ToJSON ImageID where + toJSON (ImageID iid) = JSON.String iid + +instance FromJSON ImageID where + parseJSON (JSON.String t) = case toImageID t of + Nothing -> + fail "Invalid ImageID" + Just iid -> + return iid + parseJSON _ = fail "ImageID is not an object." + +-- | Data type used for representing the information of various ports that +-- a contianer may expose. +data ContainerPortInfo = ContainerPortInfo { + ipAddressInfo :: Maybe Text + , privatePortInfo :: Port + , publicPortInfo :: Maybe Port + , portTypeInfo :: Maybe PortType + } deriving (Eq, Show) + +instance FromJSON ContainerPortInfo where + parseJSON (JSON.Object v) = + ContainerPortInfo <$> (v .:? "IP") + <*> (v .: "PrivatePort") + <*> (v .:? "PublicPort") + <*> (v .:? "Type") + parseJSON _ = fail "ContainerPortInfo: Not a JSON object." + +-- For inspecting container details. +-- | Data type used for parsing the network information of each container +-- when listing them. +data NetworkOptions = NetworkOptions { +-- ipamConfig :: Maybe Text -- Don't see in 1.24 +-- , links :: Maybe Text -- Don't see in 1.24 +-- , aliases :: Maybe Text -- Don't see in 1.24 + networkOptionsId :: Text + , networkOptionsEndpointId :: Text + , networkOptionsGateway :: Text + , networkOptionsIpAddress :: Text -- Note: Parse this? + , networkOptionsIpPrefixLen :: Int + , networkOptionsIpV6Gateway :: Maybe Text + , networkOptionsGlobalIPv6Address :: Maybe Text + , networkOptionsGlobalIPv6PrefixLen :: Maybe Int + , networkOptionsMacAddress :: Text + } deriving (Eq, Show) + +instance FromJSON NetworkOptions where + parseJSON (JSON.Object o) = do + networkId <- o .: "NetworkID" + endpointId <- o .: "EndpointID" + gateway <- o .: "Gateway" + ip <- o .: "IPAddress" + ipLen <- o .: "IPPrefixLen" + ip6Gateway <- o .:? "IPv6Gateway" + globalIP6 <- o .:? "GlobalIPv6Address" + globalIP6Len <- o .:? "GlobalIPv6PrefixLen" + mac <- o .: "MacAddress" + return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac + parseJSON _ = fail "NetworkOptions is not an object" + +-- TODO: Not sure what this is used for anymore. +data Network = Network NetworkMode NetworkOptions + deriving (Eq, Show) + +instance FromJSON [Network] where + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + where + f accM k' v' = do + acc <- accM + k <- parseJSON $ JSON.String k' + v <- parseJSON v' + return $ (Network k v):acc + parseJSON _ = fail "Networks is not an object" + +-- | Data type reprsenting the various network settings a container can have. +data NetworkSettings = NetworkSettings { + networkSettingsBridge :: Text + , networkSettingsSandboxId :: Text + , networkSettingsHairpinMode :: Bool + , networkSettingsLinkLocalIPv6Address :: Text + , networkSettingsLinkLocalIPv6PrefixLen :: Int + , networkSettingsPorts :: [PortBinding] + , networkSettingsSandboxKey :: Text + , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear + , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear + , networkSettingsEndpointID :: Text + , networkSettingsGateway :: Text + , networkSettingsGlobalIPv6Address :: Text + , networkSettingsGlobalIPv6PrefixLen :: Int + , networkSettingsIpAddress :: Text + , networkSettingsIpPrefixLen :: Int + , networkSettingsIpv6Gateway :: Text + , networkSettingsMacAddress :: Text + , networkSettingsNetworks :: [Network] + } + deriving (Eq, Show) + +instance FromJSON NetworkSettings where + parseJSON (JSON.Object o) = do + bridge <- o .: "Bridge" + sandbox <- o .: "SandboxID" + hairpin <- o .: "HairpinMode" + localIP6 <- o .: "LinkLocalIPv6Address" + localIP6Len <- o .: "LinkLocalIPv6PrefixLen" + ports <- o .: "Ports" -- .!= [] + sandboxKey <- o .: "SandboxKey" + secondaryIP <- o .: "SecondaryIPAddresses" + secondayIP6 <- o .: "SecondaryIPv6Addresses" + endpointID <- o .: "EndpointID" + gateway <- o .: "Gateway" + globalIP6 <- o .: "GlobalIPv6Address" + globalIP6Len <- o .: "GlobalIPv6PrefixLen" + ip <- o .: "IPAddress" + ipLen <- o .: "IPPrefixLen" + ip6Gateway <- o .: "IPv6Gateway" + mac <- o .: "MacAddress" + networks <- o .: "Networks" + return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks + parseJSON _ = fail "NetworkSettings is not an object." + +-- | Data type used for parsing a list of containers. +data Container = Container + { containerId :: ContainerID + , containerNames :: [Text] + , containerImageName :: Text + , containerImageId :: ImageID + , containerCommand :: Text + , containerCreatedAt :: Int + , containerStatus :: Status + , containerPorts :: [ContainerPortInfo] + , containerLabels :: [Label] + , containerNetworks :: [Network] + , containerMounts :: [Mount] + } deriving (Show, Eq) + +instance FromJSON Container where + parseJSON (JSON.Object v) = + Container <$> (v .: "Id") + <*> (v .: "Names") + <*> (v .: "Image") + <*> (v .: "ImageID") + <*> (v .: "Command") + <*> (v .: "Created") + <*> (v .: "Status") + <*> (v .: "Ports") + <*> (v .: "Labels") + <*> (v .: "NetworkSettings" >>= parseNetworks) + <*> (v .: "Mounts") + where + parseNetworks (JSON.Object v) = + (v .: "Networks") >>= parseJSON + parseNetworks _ = fail "Container NetworkSettings: Not a JSON object." + + parseJSON _ = fail "Container: Not a JSON object." + +-- | Represents the status of the container life cycle. +data Status = Created | Restarting | Running | Paused | Exited | Dead + deriving (Eq, Show, Generic) + +instance FromJSON Status where + parseJSON (JSON.String "running") = return Running + parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these. + parseJSON (JSON.String "restarting") = return Restarting + parseJSON (JSON.String "paused") = return Paused + parseJSON (JSON.String "exited") = return Exited + parseJSON (JSON.String "dead") = return Dead + parseJSON _ = fail "Unknown Status" + +-- | Alias for representing a RepoDigest. We could newtype this and add +-- some validation. +type Digest = Text + +-- | Container and Image Labels. +data Label = Label Name Value deriving (Eq, Show) + + +-- If there are multiple lables with the same Name in the list +-- then the last one wins. +instance ToJSON [Label] where + toJSON [] = emptyJsonObject + toJSON (l:ls) = toJsonKeyVal (l:ls) key val + where key (Label k _) = T.unpack k + val (Label _ v) = v + +instance FromJSON [Label] where + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + where f accM k v = do + acc <- accM + value <- parseJSON v + return $ (Label k value):acc + parseJSON JSON.Null = return [] + parseJSON _ = fail "Failed to parse Labels. Not an object." + +-- | Alias for Tags. +type Tag = Text + +-- | Data type used for parsing information from a list of images. +data Image = DockerImage { + imageId :: ImageID + , imageCreated :: Integer + , imageParentId :: Maybe ImageID + , imageRepoTags :: [Tag] + , imageRepoDigests :: [Digest] + , imageSize :: Integer + , imageVirtualSize :: Integer + , imageLabels :: [Label] + } deriving (Show, Eq, Generic) + +-- | Helper function used for dropping the "image" prefix when serializing +-- the Image data type to and from json. +dropImagePrefix :: [a] -> [a] +dropImagePrefix = drop 5 + + +instance FromJSON Image where + parseJSON (JSON.Object o) = do + imageId <- o .: "Id" + imageCreated <- o .: "Created" + imageParentId <- o .:? "ParentId" + imageRepoTags <- o .:? "RepoTags" .!= [] + imageRepoDigests <- o .:? "RepoDigests" .!= [] + imageSize <- o .: "Size" + imageVirtualSize <- o .: "VirtualSize" + imageLabels <- o .:? "Labels" .!= [] + return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels + parseJSON _ = fail "Failed to parse DockerImage." + + +-- | Options used for creating a Container. +data CreateOpts = CreateOpts { + containerConfig :: ContainerConfig + , hostConfig :: HostConfig + } deriving (Eq, Show) + +instance ToJSON CreateOpts where + toJSON (CreateOpts cc hc) = 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 + _ -> error "ContainerConfig is not an object." -- This should never happen. + +-- | Container configuration used for creating a container with sensible +-- defaults. +defaultContainerConfig :: Text -> ContainerConfig +defaultContainerConfig imageName = ContainerConfig { + hostname=Nothing + , domainname=Nothing + , user=Nothing + , attachStdin=False + , attachStdout=False + , image=imageName + , attachStderr=False + , exposedPorts=[] + , tty=False + , openStdin=False + , stdinOnce=False + , env=[] + , cmd=[] + , volumes=[] + , workingDir=Nothing + , entrypoint=Nothing + , networkDisabled=Nothing + , macAddress=Nothing + , labels=[] + , stopSignal=SIGTERM + } + +-- | Default host confiratuon used for creating a container. +defaultHostConfig :: HostConfig +defaultHostConfig = HostConfig { + binds=[] + , containerIDFile=Nothing + , logConfig=LogDriverConfig JsonFile [] + , networkMode=Bridge + , portBindings=[] + , restartPolicy=RestartOff + , volumeDriver=Nothing + , volumesFrom=[] + , capAdd=[] + , capDrop=[] + , dns=[] + , dnsOptions=[] + , dnsSearch=[] + , extraHosts=[] + , ipcMode=Nothing + , links=[] + , oomScoreAdj=Nothing + , privileged=False + , publishAllPorts=False + , readonlyRootfs=False + , securityOpt=[] + , shmSize=Nothing + , resources=defaultContainerResources + } + +-- Default container resource contstraints (None). +defaultContainerResources :: ContainerResources +defaultContainerResources = ContainerResources { + cpuShares=Nothing + , blkioWeight=Nothing + , blkioWeightDevice=Nothing + , blkioDeviceReadBps=Nothing + , blkioDeviceWriteBps=Nothing + , blkioDeviceReadIOps=Nothing + , blkioDeviceWriteIOps=Nothing + , cpuPeriod=Nothing + , cpusetCpus=Nothing + , cpusetMems=Nothing + , devices=[] + , kernelMemory=Nothing + , memory=Nothing + , memoryReservation=Nothing + , memorySwap=Nothing + , oomKillDisable=False + , ulimits=[] + } + +-- | 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 } + +-- | Override the key sequence for detaching a container. +-- Format is a single character [a-Z] or ctrl- where is one of: a-z, @, ^, [, , or _. +data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show) + +-- | Options for starting a container. +data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show) + +-- | Default options for staring a container. +defaultStartOpts :: StartOpts +defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey } + +-- | Options for deleting a container. +data DeleteOpts = DeleteOpts { + 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) + +-- | 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 } + +-- | Timestamp alias. +type Timestamp = Integer + +-- | Used for requesting N number of lines when tailing a containers log +-- output. +data TailLogOpt = Tail Integer | All deriving (Eq, Show) + + +-- | Log options used when requesting the log output from a container. +data LogOpts = LogOpts { + stdout :: Bool + , stderr :: Bool + , since :: Maybe Timestamp + , timestamps :: Bool + , tail :: TailLogOpt + } deriving (Eq, Show) + +-- | Sensible default for log options. +defaultLogOpts :: LogOpts +defaultLogOpts = LogOpts { stdout = True + , stderr = True + , since = Nothing + , timestamps = True + , tail = All + } + +-- 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) + +instance ToJSON VolumePermission where + toJSON ReadWrite = "rw" + toJSON ReadOnly = "ro" + +instance FromJSON VolumePermission where + parseJSON "rw" = return ReadWrite + parseJSON "ro" = return ReadOnly + parseJSON _ = fail "Failed to parse VolumePermission" + +-- | Used for marking a directory in the container as "exposed" hence +-- taking it outside of the COW filesystem and making it mountable +-- in other containers using "VolumesFrom". The volume usually get's +-- created somewhere in @/var/lib/docker/volumes@ (depending on the volume +-- driver used). +-- The CLI example is: +-- +-- @ +-- docker run --name app -v \/opt\/data -it myapp:latest +-- docker run --name app2 --volumes-from app \/bin\/bash -c "ls -l \/opt\/data" +-- @ +newtype Volume = Volume FilePath deriving (Eq, Show) + +instance ToJSON [Volume] where + toJSON [] = emptyJsonObject + toJSON (v:vs) = toJsonKey (v:vs) getKey + where getKey (Volume v) = v + +instance FromJSON [Volume] where + parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o + parseJSON (JSON.Null) = return [] + parseJSON _ = fail "Volume is not an object" + + +data Bind = Bind { hostSrc :: Text + , containerDest :: Text + , volumePermission :: Maybe VolumePermission + } deriving (Eq, Show) + +instance FromJSON Bind where + parseJSON (JSON.String t) = case T.split (== ':') t of + [src, dest] -> return $ Bind src dest Nothing + [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite + [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly + _ -> fail "Could not parse Bind" + parseJSON _ = fail "Bind is not a string" + +data Device = Device { + pathOnHost :: FilePath + , pathInContainer :: FilePath + , cgroupPermissions :: Text + } deriving (Eq, Show, Generic) + +instance ToJSON Device where + toJSON = genericToJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +instance FromJSON Device where + parseJSON = genericParseJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +type ContainerName = Text + +data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq, Show) + +instance FromJSON VolumeFrom where + parseJSON (JSON.String t) = case T.split (== ':') t of + [vol] -> return $ VolumeFrom vol Nothing + [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite + [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly + _ -> fail "Could not parse VolumeFrom" + parseJSON _ = fail "VolumeFrom is not a string" + +instance ToJSON VolumeFrom where + toJSON (VolumeFrom n p) = case p of + Nothing -> toJSON $ n <> ":" <> "rw" + Just per -> toJSON $ n <> ":" <> (T.pack $ show per) + +instance ToJSON Bind where + toJSON (Bind src dest mode) = toJSON $ case mode of + Nothing -> T.concat[src, ":", dest] + Just m -> T.concat[src, ":", dest, ":", (T.pack $ show m)] + +data Link = Link Text (Maybe Text) deriving (Eq, Show) + +instance FromJSON Link where + parseJSON (JSON.String t) = case T.split (== ':') t of + [f] -> return $ Link f Nothing + [f,s] -> return $ Link f $ Just s + _ -> fail "Could not parse Link" + parseJSON _ = fail "Link is not a string" + +instance ToJSON Link where + toJSON (Link n1 n2) = toJSON $ case n2 of + Nothing -> T.concat[n1, ":", n1] -- use same name in container + Just n -> T.concat[n1, ":", n] -- used specified name in container + +-- { "Type": "", "Config": {"key1": "val1"} } +data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show) + +instance FromJSON LogDriverType where + parseJSON (JSON.String "json-file") = return JsonFile + parseJSON (JSON.String "syslog") = return Syslog + parseJSON (JSON.String "journald") = return Journald + parseJSON (JSON.String "gelf") = return Gelf + parseJSON (JSON.String "fluentd") = return Fluentd + parseJSON (JSON.String "awslogs") = return AwsLogs + parseJSON (JSON.String "splunk") = return Splunk + parseJSON (JSON.String "etwlogs") = return Etwlogs + parseJSON (JSON.String "none") = return LoggingDisabled + parseJSON _ = fail "Unknown LogDriverType" + +instance ToJSON LogDriverType where + toJSON JsonFile = JSON.String "json-file" + toJSON Syslog = JSON.String "syslog" + toJSON Journald = JSON.String "journald" + toJSON Gelf = JSON.String "gelf" + toJSON Fluentd = JSON.String "fluentd" + toJSON AwsLogs = JSON.String "awslogs" + toJSON Splunk = JSON.String "splunk" + toJSON Etwlogs = JSON.String "etwlogs" + toJSON LoggingDisabled = JSON.String "none" + +data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show) + +instance ToJSON [LogDriverOption] where + toJSON [] = emptyJsonObject + toJSON (o:os) = toJsonKeyVal (o:os) key val + where key (LogDriverOption n _) = T.unpack n + val (LogDriverOption _ v) = v + +instance FromJSON [LogDriverOption] where + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + where f accM k v = do + acc <- accM + value <- parseJSON v + return $ (LogDriverOption k value):acc + parseJSON JSON.Null = return [] + parseJSON _ = fail "Failed to parse LogDriverOptions" + +data LogDriverConfig = LogDriverConfig LogDriverType [LogDriverOption] deriving (Eq, Show) + +instance ToJSON LogDriverConfig where + toJSON (LogDriverConfig driverType []) = object ["Type" .= driverType] + toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions] + +instance FromJSON LogDriverConfig where + parseJSON (JSON.Object o) = do + typ <- o .: "Type" + opts <- o .: "Config" + return $ LogDriverConfig typ opts + parseJSON _ = fail "LogDriverConfig is not an object" + +-- TODO: Add container: mode +data NetworkMode = Bridge | Host | NetworkDisabled + deriving (Eq, Show, Ord) + +instance FromJSON NetworkMode where + parseJSON (JSON.String "bridge") = return Bridge + parseJSON (JSON.String "host") = return Host -- Note: Guessing on these. + parseJSON (JSON.String "none") = return NetworkDisabled + parseJSON _ = fail "Unknown NetworkMode" + +instance ToJSON NetworkMode where + toJSON Bridge = JSON.String "bridge" + toJSON Host = JSON.String "host" + toJSON NetworkDisabled = JSON.String "none" + +data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord) + +instance Show PortType where + show TCP = "tcp" + show UDP = "udp" + +instance ToJSON PortType where + toJSON TCP = "tcp" + toJSON UDP = "udp" + +instance FromJSON PortType where + parseJSON val = case val of + "tcp" -> return TCP + "udp" -> return UDP + _ -> fail "PortType: Invalid port type." + +-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show) +-- +-- instance FromJSON NetworkInterface where +-- parseJSON (JSON.String v) = return $ NetworkInterface v +-- parseJSON _ = fail "Network interface is not a string." +-- +-- instance ToJSON NetworkInterface where +-- toJSON (NetworkInterface i) = JSON.String i + +-- | This datastructure models mapping a Port from the container onto the +-- host system s that the service running in the container can be accessed from +-- the outside world. We either map a port onto all interfaces (default) or onto a specific +-- interface like `127.0.0.1`. +-- __NOTE__: We should disallow duplicate port bindings as the ToJSON +-- instance will only send the last one. +-- { /: [{ "HostPort": "" }] } +data PortBinding = PortBinding { + containerPort :: Port + , portType :: PortType + , hostPorts :: [HostPort] + } deriving (Eq, Show) + +portAndType2Text :: Port -> PortType -> Text +portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t) + + +-- | A helper function to more easily add a bind mount to existing +-- "CreateOpts" records. +addBind :: Bind -> CreateOpts -> CreateOpts +addBind b c = c{hostConfig=hc{binds=obs <> [b]}} + where hc = hostConfig c + obs = binds $ hostConfig c + +-- | Helper function for adding a Command to and existing +-- CreateOpts record. +setCmd :: Text -> CreateOpts -> CreateOpts +setCmd ccmd c = c{containerConfig=cc{cmd=[ccmd]}} + where cc = containerConfig c + +-- | Helper function for adding a "Link" to and existing +-- CreateOpts record. +addLink :: Link -> CreateOpts -> CreateOpts +addLink l c = c{hostConfig=hc{links=ols <> [l]}} + where hc = hostConfig c + ols = links $ hostConfig c + +-- | Helper function for adding a "Volume" to and existing +-- CreateOpts record. +addVolume :: Volume -> CreateOpts -> CreateOpts +addVolume v c = c{containerConfig=cc{volumes=oldvs <> [v]}} + where cc = containerConfig c + oldvs = volumes cc + +-- | Helper function for adding a "VolumeFrom" to and existing +-- CreateOpts record. +addVolumeFrom :: VolumeFrom -> CreateOpts -> CreateOpts +addVolumeFrom vf c = c{hostConfig=hc{volumesFrom=oldvfs <> [vf]}} + where hc = hostConfig c + oldvfs = volumesFrom hc + +-- | A convenience function that adds PortBindings to and exiting +-- "CreateOpts" record. Useful with 'defaultCreateOpts' +-- Example: +-- +-- >>> let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000] +-- >>> addPortBinding pb $ defaultCreateOpts "nginx:latest" +addPortBinding :: PortBinding -> CreateOpts -> CreateOpts +addPortBinding pb c = c{hostConfig=hc{portBindings=pbs <> [pb]}} + where hc = hostConfig c + pbs = portBindings $ hostConfig c + +-- | Helper function for adding a "ExposedPort" to and existing +-- CreateOpts record. +addExposedPort :: ExposedPort -> CreateOpts -> CreateOpts +addExposedPort ep c = c{containerConfig=cc{exposedPorts=oldeps <> [ep]}} + where cc = containerConfig c + oldeps = exposedPorts cc + + +instance FromJSON [PortBinding] where + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + where + f accM k v = case T.split (== '/') k of + [port', portType'] -> do + port <- parseIntegerText port' + portType <- parseJSON $ JSON.String portType' + acc <- accM + hps <- parseJSON v + return $ (PortBinding port portType hps):acc + _ -> fail "Could not parse PortBindings" + parseJSON (JSON.Null) = return [] + parseJSON _ = fail "PortBindings is not an object" + +instance ToJSON [PortBinding] where + toJSON [] = emptyJsonObject + toJSON (p:ps) = toJsonKeyVal (p:ps) key val + where key p = T.unpack $ portAndType2Text (containerPort p) (portType p) + val p = hostPorts p + +data HostPort = HostPort { + hostIp :: Text + , hostPost :: Port + } + deriving (Eq, Show) + +instance ToJSON HostPort where + toJSON (HostPort i p) = object ["HostPort" .= show p, "HostIp" .= i] + +instance FromJSON HostPort where + parseJSON (JSON.Object o) = do + p <- o .: "HostPort" >>= parseIntegerText + i <- o .: "HostIp" + return $ HostPort i p + parseJSON _ = fail "HostPort is not an object." + +-- { "Name": "on-failure" , "MaximumRetryCount": 2} +type RetryCount = Integer +data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show) + +instance FromJSON RestartPolicy where + parseJSON (JSON.Object o) = do + (name :: Text) <- o .: "Name" + case name of + "always" -> return RestartAlways + "unless-stopped" -> return RestartUnlessStopped + "on-failure" -> do + retry <- o .: "MaximumRetryCount" + return $ RestartOnFailure retry + "off" -> return RestartOff + _ -> fail "Could not parse RestartPolicy" + parseJSON _ = fail "RestartPolicy is not an object" + +instance ToJSON RestartPolicy where + toJSON RestartAlways = object ["Name" .= JSON.String "always"] + toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"] + toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c] + toJSON RestartOff = object ["Name" .= JSON.String "off"] + +data Isolation = Default | Process | Hyperv deriving (Eq, Show) + +newtype UTSMode = UTSMode Text deriving (Eq, Show) + +-- TODO: Add Tmpfs : List of tmpfs (mounts) used for the container +-- TODO: Add UTSMode : UTS namespace to use for the container +-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container +data HostConfig = HostConfig + { binds :: [Bind] + , containerIDFile :: Maybe FilePath -- 1.24: Only in responses, not create + , logConfig :: LogDriverConfig + , networkMode :: NetworkMode + , portBindings :: [PortBinding] + , restartPolicy :: RestartPolicy + , volumeDriver :: Maybe Text + , volumesFrom :: [VolumeFrom] + , capAdd :: [Text] + , capDrop :: [Text] + , dns :: [Text] + , dnsOptions :: [Text] + , dnsSearch :: [Text] + , extraHosts :: [Text] + -- , groupAdd :: [Integer] -- 1.24: Missing from inspecting container details... Going to omit for now. + , ipcMode :: Maybe Text -- 1.24: Only in inspect, not create + , links :: [Link] + , oomScoreAdj :: Maybe Integer + -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit + , privileged :: Bool + , publishAllPorts :: Bool + , readonlyRootfs :: Bool + , securityOpt :: [Text] + -- , utsMode :: UTSMode -- 1.24: Don't see this + , shmSize :: Maybe Integer + -- , consoleSize :: Integer -- 1.24: Don't see this + -- , isolation :: Isolation -- 1.24: Don't see this + , resources :: ContainerResources + } deriving (Eq, Show, Generic) + +instance FromJSON HostConfig where + parseJSON v@(JSON.Object o) = HostConfig + <$> o .: "Binds" + <*> o .: "ContainerIDFile" + <*> o .: "LogConfig" + <*> o .: "NetworkMode" + <*> o .: "PortBindings" + <*> o .: "RestartPolicy" + <*> o .: "VolumeDriver" + <*> o .: "VolumesFrom" + <*> o .: "CapAdd" + <*> o .: "CapDrop" + <*> o .: "Dns" + <*> o .: "DnsOptions" + <*> o .: "DnsSearch" + <*> o .: "ExtraHosts" + <*> o .: "IpcMode" + <*> o .:? "Links" .!= [] + <*> o .: "OomScoreAdj" + <*> o .: "Privileged" + <*> o .: "PublishAllPorts" + <*> o .: "ReadonlyRootfs" + <*> o .: "SecurityOpt" + <*> o .: "ShmSize" + <*> parseJSON v + parseJSON _ = fail "HostConfig is not an object." + +instance ToJSON HostConfig where + toJSON HostConfig{..} = + let arr = [ + "Binds" .= binds + , "ContainerIDFile" .= containerIDFile + , "LogConfig" .= logConfig + , "NetworkMode" .= networkMode + , "PortBindings" .= portBindings + , "RestartPolicy" .= restartPolicy + , "VolumeDriver" .= volumeDriver + , "VolumesFrom" .= volumesFrom + , "CapAdd" .= capAdd + , "CapDrop" .= capDrop + , "Dns" .= dns + , "DnsOptions" .= dnsOptions + , "DnsSearch" .= dnsSearch + , "ExtraHosts" .= extraHosts + , "IpcMode" .= ipcMode + , "Links" .= links + , "OomScoreAdj" .= oomScoreAdj + , "Privileged" .= privileged + , "PublishAllPorts" .= publishAllPorts + , "ReadonlyRootfs" .= readonlyRootfs + , "SecurityOpt" .= securityOpt + , "ShmSize" .= shmSize + ] + in + object $ arr <> ( resourcesArr resources) + + where + -- JP: Not sure if this is better than a separate ToJSON instance with a bunch of `HM.insert`s. + resourcesArr ContainerResources{..} = [ + "CpuShares" .= cpuShares + , "BlkioWeight" .= blkioWeight + , "BlkioWeightDevice" .= blkioWeightDevice + , "BlkioDeviceReadBps" .= blkioDeviceReadBps + , "BlkioDeviceWriteBps" .= blkioDeviceWriteBps + , "BlkioDeviceReadIOps" .= blkioDeviceReadIOps + , "BlkioDeviceWriteIOps" .= blkioDeviceWriteIOps + , "CpuPeriod" .= cpuPeriod + , "CpusetCpus" .= cpusetCpus + , "CpusetMems" .= cpusetMems + , "Devices" .= devices + , "KernelMemory" .= kernelMemory + , "Memory" .= memory + , "MemoryReservation" .= memoryReservation + , "MemorySwap" .= memorySwap + , "OomKillDisable" .= oomKillDisable + , "Ulimits" .= ulimits + ] + + + + +-- { "Name": , "Soft": , "Hard": } +-- { "Name": "nofile", "Soft": 1024, "Hard": 2048 } +data Ulimit = Ulimit { + ulimitName :: Text + , ulimitSoft :: Integer + , ulimitHard :: Integer + } deriving (Eq, Show, Generic) + +instance FromJSON Ulimit where + parseJSON = genericParseJSON defaultOptions { + fieldLabelModifier = drop 5} + +instance ToJSON Ulimit where + toJSON = genericToJSON defaultOptions { + fieldLabelModifier = drop 5} + +data DeviceWeight = DeviceWeight { + deviceWeightPath :: FilePath + , deviceWeightWeight :: Text + } + deriving (Show, Eq) + +instance FromJSON DeviceWeight where + parseJSON (JSON.Object o) = DeviceWeight + <$> o .: "Path" + <*> o .: "Weight" + parseJSON _ = fail "DeviceWeight is not an object." + +instance ToJSON DeviceWeight where + toJSON (DeviceWeight p w) = object [ + "Path" .= p + , "Weight" .= w + ] + +data DeviceRate = DeviceRate { + deviceRatePath :: FilePath + , deviceRateRate :: Text + } + deriving (Show, Eq) + +instance FromJSON DeviceRate where + parseJSON (JSON.Object o) = DeviceRate + <$> o .: "Path" + <*> o .: "Rate" + parseJSON _ = fail "DeviceRate is not an object." + +instance ToJSON DeviceRate where + toJSON (DeviceRate p r) = object [ + "Path" .= p + , "Rate" .= r + ] + +data MemoryConstraintSize = B | MB | GB deriving (Eq, Show) + +data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show) + +instance ToJSON MemoryConstraint where + toJSON (MemoryConstraint x B) = toJSON x + toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024 + toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024 + +instance FromJSON MemoryConstraint where + parseJSON (JSON.Number x) = case (floatingOrInteger x) of + Left (_ :: Double) -> fail "Failed to parse MemoryConstraint" + Right i -> return $ MemoryConstraint i B + -- The docker daemon will always return the number as bytes (integer), regardless of how we set them (using MB or GB) + parseJSON _ = fail "Failed to parse MemoryConstraint" + +data ContainerResources = ContainerResources { + cpuShares :: Maybe Integer + -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now. + , blkioWeight :: Maybe Integer + , blkioWeightDevice :: Maybe [DeviceWeight] + , blkioDeviceReadBps :: Maybe [DeviceRate] -- TODO: Not Text + , blkioDeviceWriteBps :: Maybe [DeviceRate] -- TODO: Not Text + , blkioDeviceReadIOps :: Maybe [DeviceRate] -- TODO: Not Text + , blkioDeviceWriteIOps :: Maybe [DeviceRate] -- TODO: Not Text + , cpuPeriod :: Maybe Integer + -- , cpuQuota :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now. + , cpusetCpus :: Maybe Text + , cpusetMems :: Maybe Text + , devices :: [Device] + -- , diskQuota :: Integer -- Don't see this ins 1.24. + , kernelMemory :: Maybe MemoryConstraint + , memory :: Maybe MemoryConstraint + , memoryReservation :: Maybe MemoryConstraint + , memorySwap :: Maybe MemoryConstraint + -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now. + , oomKillDisable :: Bool + -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now. + , ulimits :: [Ulimit] + -- TODO: Missing from 1.24 + -- StorageOpt :: [(Text, Text)] + -- VolumeDriver :: ?? + -- EndpointsConfig :: ?? + -- TODO: Only in inspect container in 1.24 + -- CpuPercent :: Int + + -- MaximumIOps :: Int + + -- MaximumIOBps :: Int + + -- LxcConf :: [??] + + } deriving (Eq, Show, Generic) + +-- instance ToJSON ContainerResources where +-- toJSON = genericToJSON defaultOptions { +-- fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +instance FromJSON ContainerResources where + parseJSON = genericParseJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +type Port = Integer + +type Name = Text +type Value = Text + +data EnvVar = EnvVar Name Value + deriving (Eq, Show) + +instance FromJSON EnvVar where + parseJSON (JSON.String env) = + let (n, v') = T.break (== '=') env in + let v = T.drop 1 v' in + return $ EnvVar n v + parseJSON _ = fail "EnvVar is not a string" + +instance ToJSON EnvVar where + toJSON (EnvVar n v) = object [n .= v] + +-- | ExposedPort represents a port (and it's type) +-- that a container should expose to other containers or the host system. +-- `NOTE`: This does not automatically expose the port onto the host +-- system but rather it just tags it. It's best to be used with +-- the PublishAllPorts flag. It is also useful for +-- the daemon to know which Environment variables to +-- inject into a container linking to our container. +-- Example linking a Postgres container named db would inject the following +-- environment variables automatically if we set the corresponding +-- +-- ExposedPort: +-- +-- @ +-- DB_PORT_5432_TCP_PORT="5432" +-- DB_PORT_5432_TCP_PROTO="tcp" +-- DB_PORT_5432_TCP="tcp://172.17.0.1:5432" +-- @ +data ExposedPort = ExposedPort Port PortType deriving (Eq, Show) + +instance FromJSON [ExposedPort] where + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + where + f accM k _ = case T.split (== '/') k of + [port', portType'] -> do + port <- parseIntegerText port' + portType <- parseJSON $ JSON.String portType' + acc <- accM + return $ (ExposedPort port portType):acc + _ -> fail "Could not parse ExposedPorts" + parseJSON (JSON.Null) = return [] + parseJSON _ = fail "ExposedPorts is not an object" + +instance ToJSON [ExposedPort] where + toJSON [] = emptyJsonObject + toJSON (p:ps) = toJsonKey (p:ps) key + where key (ExposedPort p t) = show p <> slash <> show t + slash = T.unpack "/" + +data ContainerConfig = ContainerConfig { + hostname :: Maybe Text + , domainname :: Maybe Text + , user :: Maybe Text + , attachStdin :: Bool + , attachStdout :: Bool + , attachStderr :: Bool + , exposedPorts :: [ExposedPort] + -- , publishService :: Text -- Don't see this in 1.24 + , tty :: Bool + , openStdin :: Bool + , stdinOnce :: Bool + , env :: [EnvVar] + , cmd :: [Text] + -- , argsEscaped :: Bool -- Don't see this in 1.24 + , image :: Text + , volumes :: [Volume] + , workingDir :: Maybe FilePath + , entrypoint :: Maybe Text -- Can be null? + , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False? + , macAddress :: Maybe Text + -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response. + , labels :: [Label] + , stopSignal :: Signal + } deriving (Eq, Show, Generic) + +instance ToJSON ContainerConfig where + toJSON = genericToJSON defaultOptions { + fieldLabelModifier = (\(x:xs) -> toUpper x : xs)} + +instance FromJSON ContainerConfig where + parseJSON (JSON.Object o) = do + hostname <- o .:? "Hostname" + domainname <- o .:? "Domainname" + user <- o .:? "User" + attachStdin <- o .: "AttachStdin" + attachStdout <- o .: "AttachStdout" + attachStderr <- o .: "AttachStderr" + exposedPorts <- o .:? "ExposedPorts" .!= [] + tty <- o .: "Tty" + openStdin <- o .: "OpenStdin" + stdinOnce <- o .: "StdinOnce" + env <- o .: "Env" + cmd <- o .: "Cmd" + image <- o .: "Image" + volumes <- o .: "Volumes" + workingDir <- o .:? "WorkingDir" + entrypoint <- o .:? "Entrypoint" + networkDisabled <- o .:? "networkDisabled" + macAddress <- o .:? "MacAddress" + labels <- o .:? "Labels" .!= [] + stopSignal <- o .: "StopSignal" + return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled + macAddress labels stopSignal + parseJSON _ = fail "NetworkSettings is not an object." + +parseIntegerText :: (Monad m) => Text -> m Integer +parseIntegerText t = case readMaybe $ T.unpack t of + Nothing -> + fail "Could not parse Integer" + Just i -> + return i + +-- | Helper function for converting a data type [a] to a json dictionary +-- like so {"something": {}, "something2": {}} +toJsonKey :: Foldable t => t a -> (a -> String) -> JSON.Value +toJsonKey vs getKey = JSON.Object $ foldl f HM.empty vs + where f acc x = HM.insert (T.pack $ getKey x) (JSON.Object HM.empty) acc + +-- | Helper function for converting a data type [a] to a json dictionary +-- like so {"something": "val1", "something2": "val2"} +toJsonKeyVal :: (Foldable t, JSON.ToJSON r) => t a -> (a -> String) -> (a -> r) -> JSON.Value +toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs + where f acc x = HM.insert (T.pack $ getKey x) (toJSON $ getVal x) acc + +-- | Helper function that return an empty dictionary "{}" +emptyJsonObject :: JSON.Value +emptyJsonObject = JSON.Object HM.empty + diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,62 +1,138 @@ -module Main where +{-# LANGUAGE OverloadedStrings #-} -import Network.Docker -import Network.Docker.Types +module Main where import qualified Test.QuickCheck.Monadic as QCM import Test.Tasty import Test.Tasty.HUnit -import qualified Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck (testProperty) import Control.Concurrent (threadDelay) +import Control.Lens ((^.), (^?)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import qualified Data.Aeson as JSON +import Data.Aeson.Lens (key, _Object, _String, _Value) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import Data.Int (Int) +import qualified Data.Map as M import Data.Maybe (fromJust, isJust) -import Data.Text (unpack) +import Data.Monoid +import Data.Text (Text, unpack) +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS import Network.HTTP.Types.Status import System.Process (system) -opts = defaultClientOpts { baseUrl = "http://127.0.0.1:2375/" } +import Docker.Client -test_image_name = "docker-hs-test" +-- opts = defaultClientOpts +testImageName = "docker-hs-test" + toStrict1 = B.concat . BL.toChunks -checkDockerVersion :: IO () -checkDockerVersion = do v <- getDockerVersion opts - assert $ isJust v +runDocker f = do + -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"} + -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight + -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem" + -- let settings = mkManagerSettings (TLSSettings params) Nothing + -- mgr <- newManager settings + runDockerT (defaultClientOpts, defaultHttpHandler) f -findTestImage :: IO () -findTestImage = do images <- getDockerImages opts - let x = fmap (filter ((== [test_image_name++":latest"]) . _repoTags)) images - assert $ fmap length x == Just 1 +testDockerVersion :: IO () +testDockerVersion = runDocker $ do + v <- getDockerVersion + lift $ assert $ isRight v -runAndReadLog :: IO () -runAndReadLog = do containerId <- createContainer opts (defaultCreateOpts {_image = test_image_name++":latest"}) - assert $ isJust containerId - let c = unpack $ fromJust containerId - status1 <- startContainer opts c defaultStartOpts - threadDelay 300000 -- give 300ms for the application to finish - assert $ status1 == status204 - status2 <- killContainer opts c - logs <- getContainerLogs opts c - assert $ status2 == status204 - assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs) - status3 <- deleteContainer opts c - assert $ status3 == status204 +testFindImage :: IO () +testFindImage = runDocker $ do + images <- listImages defaultListOpts >>= fromRight + let xs = filter ((== [imageFullName]) . imageRepoTags) images + lift $ assert $ length xs == 1 + where imageFullName = testImageName <> ":latest" +testRunAndReadLog :: IO () +testRunAndReadLog = runDocker $ do + containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing + c <- fromRight containerId + status1 <- startContainer defaultStartOpts c + _ <- inspectContainer c >>= fromRight + lift $ threadDelay 300000 -- give 300ms for the application to finish + lift $ assert $ status1 == Right () + status2 <- killContainer SIGTERM c + logs <- getContainerLogs defaultLogOpts c >>= fromRight + lift $ assert $ status2 == Right () + lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs) + status3 <- deleteContainer (DeleteOpts True True) c + lift $ assert $ status3 == Right () -tests :: TestTree -tests = testGroup "Metrics tests" [ - testCase "Get docker version" checkDockerVersion, - testCase "Find image by name" findTestImage, - testCase "Run a dummy container and read its log" runAndReadLog] +testLogDriverOptionsJson :: TestTree +testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ] + where + test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1 + test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2 + test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override" + sample = [LogDriverOption key1 val1, LogDriverOption key2 val2] + sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"] + key1 = "some-key" + val1 = "some-val" + key2 = "some-key2" + val2 = "some-key2" -setup :: IO() -setup = system ("docker build -t "++test_image_name++" tests") >> return () +testExposedPortsJson :: TestTree +testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ] + where + testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty + testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty + sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP] -main :: IO() +testLabelsJson :: TestTree +testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ] + where + testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1 + testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2 + testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override" + sampleLS = [Label key1 val1, Label key2 val2] + key1 = "com.example.some-label" + val1 = "some-value" + key2 = "something" + val2 = "value" + +testVolumesJson :: TestTree +testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ] + where + testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty + testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty + sampleVolumes = [Volume "/tmp", Volume "/opt"] + +integrationTests :: TestTree +integrationTests = testGroup "Integration Tests" [ + testCase "Get docker version" testDockerVersion, + testCase "Find image by name" testFindImage, + testCase "Run a dummy container and read its log" testRunAndReadLog] + +jsonTests :: TestTree +jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson] + +setup :: IO () +setup = system ("docker build -t "++unpack testImageName++" tests") >> return () + +isRight (Left _) = False +isRight (Right _) = True + +fromRight :: (MonadIO m, Show l) => Either l r -> m r +fromRight (Left l) = do + liftIO $ assertFailure $ "Left: " ++ show l + undefined +fromRight (Right r) = return r + +main :: IO () main = do setup - defaultMain tests + defaultMain $ testGroup "Tests" [jsonTests, integrationTests] +