docker 0.2.0.4 → 0.3.0.0

raw patch · 13 files changed

+2177/−513 lines, 13 filesdep +blaze-builderdep +connectiondep +data-default-classdep −HsOpenSSLdep −data-defaultdep −http-client-openssldep ~QuickCheckdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder, connection, data-default-class, http-client, http-client-tls, mtl, network, scientific, time, tls, transformers, unordered-containers, x509, x509-store, x509-system

Dependencies removed: HsOpenSSL, data-default, http-client-openssl, network-uri, pipes, pipes-bytestring, pipes-http, pipes-text, wreq

Dependency ranges changed: QuickCheck, aeson, base, bytestring, containers, http-types, lens, tasty, tasty-hunit, tasty-quickcheck, text

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Network/Docker.hs +0/−144
• Network/Docker/Options.hs +0/−12
• Network/Docker/Types.hs +0/−263
• Network/Docker/Utils.hs +0/−6
• README.md +25/−2
• docker.cabal +50/−49
• src/Docker/Client.hs +112/−0
• src/Docker/Client/Api.hs +146/−0
• src/Docker/Client/Http.hs +233/−0
• src/Docker/Client/Internal.hs +75/−0
• src/Docker/Client/Types.hs +1423/−0
• tests/tests.hs +112/−36

@@ -1,4 +1,4 @@-Copyright (c) 2014, Deni Bertovic+Copyright (c) 2016, Deni Bertovic  All rights reserved. 

@@ -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)-

@@ -1,12 +0,0 @@-module Network.Docker.Options where--import           Data.Aeson.TH-import           Network.Docker.Utils--dopts :: Options-dopts = defaultOptions {-      fieldLabelModifier = strip_underscore-    }---

@@ -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)-

@@ -1,6 +0,0 @@-module Network.Docker.Utils where--import           Data.Char--strip_underscore :: String -> String-strip_underscore (_:xs) = xs

@@ -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.+

@@ -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 <deni@denibertovic.com>, James Parker <jp@jamesparker.me>+maintainer:          Deni Bertovic <deni@denibertovic.com>+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

@@ -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

@@ -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+

@@ -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++

@@ -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

@@ -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-<value> where <value> 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": "<driver_name>", "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:<name|id> 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.+-- { <port>/<protocol>: [{ "HostPort": "<port>"  }] }+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": <name>, "Soft": <soft limit>, "Hard": <hard limit>  }+-- { "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+

@@ -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]+