docker 0.3.0.1 → 0.4.0.0

raw patch · 9 files changed

+485/−160 lines, 9 filesdep +conduitdep +conduit-combinatorsdep +conduit-extraPVP ok

version bump matches the API change (PVP)

Dependencies added: conduit, conduit-combinators, conduit-extra, directory, exceptions, filemanip, filepath, http-conduit, monad-control, resourcet, tar, temporary, transformers-base, uuid, zlib

API changes (from Hackage documentation)

Files

• README.md +16/−6
• docker.cabal +18/−2
• src/Docker/Client.hs +11/−4
• src/Docker/Client/Api.hs +107/−44
• src/Docker/Client/Http.hs +48/−24
• src/Docker/Client/Internal.hs +51/−26
• src/Docker/Client/Types.hs +94/−50
• src/Docker/Client/Utils.hs +131/−0
• tests/tests.hs +9/−4

@@ -1,21 +1,31 @@ # An API client for docker written in Haskell -| 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) |+| Master |+| -------|+| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) |   ## Current state -**API is still no stable.**-We're looking to stabilize the API after the next release (0.4.0.0)+**API is still not stable.** +Supported Docker Engine Api version: `v1.24`++Anything upward of that should work since Docker versions their API.+Older docker version and engine api versions are not supported at the moment.+ ## Contributing  If you wish to contribute please see any issue tagged with "help wanted".-Make sure to submit your PR's against the `dev` branch.+Make sure to submit your PR's against the `master` 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.+++## IRC++If you have any questions or suggestions you can find the maintainers in `#docker-haskell`+on freenode. 

@@ -1,5 +1,5 @@ name:                docker-version:             0.3.0.1+version:             0.4.0.0 synopsis:            An API client for docker written in Haskell description:         See API documentation below. homepage:            https://github.com/denibertovic/docker-hs@@ -17,7 +17,7 @@ library   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+  exposed-modules:     Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils   -- other-modules:       Docker.Internal   build-depends:       base >= 4.7 && < 5                      , aeson >= 0.9.0 && < 1.1.0@@ -27,6 +27,22 @@                      , data-default-class >= 0.0.1 && < 0.2.0                      , http-client >= 0.4.0 && < 0.5.0                      , http-types >= 0.9 && < 0.10.0+                     , conduit+                     , conduit-combinators+                     , conduit-extra+                     , exceptions+                     , http-conduit+                     , monad-control+                     , resourcet+                     , transformers+                     , transformers-base+                     , tar+                     , zlib+                     , uuid+                     , temporary+                     , directory >= 1.2.5.0+                     , filemanip+                     , filepath                      , mtl >= 2.0.0 && < 3.0.0                      , network >= 2.6.0                      , text >= 1.0.0 && < 2.0.0

@@ -20,7 +20,9 @@ import           Docker.Client  runNginxContainer :: IO ContainerID-runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do+runNginxContainer = do+    h <- defaultHttpHandler+    runDockerT (defaultClientOpts, h) $ do     let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]     let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"     cid <- createContainer myCreateOpts@@ -42,7 +44,9 @@  @ stopNginxContainer :: ContainerID -> IO ()-stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do+stopNginxContainer cid = do+    h <- defaultHttpHandler+    runDockerT (defaultClientOpts, h) $ do     r <- stopContainer DefaultTimeout cid     case r of         Left err -> error "I failed to stop the container"@@ -57,7 +61,9 @@  @ runPostgresContainer :: IO ContainerID-runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do+runPostgresContainer = do+    h <- defaultHttpHandler+    runDockerT (defaultClientOpts, h) $ 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@@ -70,7 +76,8 @@  = Get Docker API Version ->>> runDockerT (defaultClientOpts, defaultHttpHandler) $ getDockerVersion+>>> h <- defaultHttpHandler+>>> runDockerT (defaultClientOpts, h) $ 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

@@ -7,6 +7,7 @@     , createContainer     , startContainer     , stopContainer+    , waitContainer     , killContainer     , restartContainer     , pauseContainer@@ -14,110 +15,133 @@     , deleteContainer     , inspectContainer     , getContainerLogs+    , getContainerLogsStream     -- * Images     , listImages+    , buildImageFromDockerfile+    , pullImage     -- * 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           Control.Monad.Catch    (MonadMask (..))+import           Control.Monad.IO.Class+import           Control.Monad.Reader   (ask, lift)+import           Data.Aeson             (FromJSON, eitherDecode')+import qualified Data.ByteString        as BS+import qualified Data.ByteString.Lazy   as BSL+import           Data.Conduit           (Sink)+import qualified Data.Conduit.Binary    as Conduit+import qualified Data.Text              as T+import qualified Data.Text              as Text+import           Network.HTTP.Client    (responseStatus)+import           Network.HTTP.Types     (StdMethod (..))+import           System.Exit            (ExitCode (..))  import           Docker.Client.Http import           Docker.Client.Types+import           Docker.Client.Utils -requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())+requestUnit :: (MonadIO m, MonadMask 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+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)+requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs++requestHelper' :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> Sink BS.ByteString m a -> DockerT m (Either DockerError a)+requestHelper' verb endpoint sink = do+    (opts, HttpHandler httpHandler) <- ask     case mkHttpRequest verb endpoint opts of         Nothing ->-            throwError $ DockerInvalidRequest endpoint+            return $ Left $ 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+            -- JP: Do we need runResourceT?+            -- lift $ NHS.httpSink request $ \response ->+            lift $ httpHandler request $ \response ->+                -- Check status code.+                let status = responseStatus response in+                case statusCodeToError endpoint status of+                    Just err ->+                        return $ Left err+                    Nothing ->+                        fmap Right sink -parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a) parseResponse (Left err) =     return $ Left err parseResponse (Right response) =     -- Parse request body.-    case eitherDecode' $ responseBody response of+    case eitherDecode' 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ()) stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid +-- | Blocks until a container with the given 'ContainerID' stops,+-- then returns the exit code+waitContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ExitCode)+waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse)+  where+    statusCodeToExitCode (StatusCode 0) = ExitSuccess+    statusCodeToExitCode (StatusCode x) = ExitFailure x+ -- | 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m. (MonadIO m, MonadMask 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 :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails) inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse  -- | Get's container's logs for a given 'ContainerID'.@@ -127,20 +151,59 @@ -- 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+-- __NOTE__: his 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+-- If you want to stream the logs from the container continuosly then use+-- 'getContainerLogsStream'+--+-- __NOTE__: It's recommended 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)+getContainerLogs ::  forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)+getContainerLogs logopts cid = 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+{-| Continuously gets the container's logs as a stream. Uses conduit.++__Example__:++@+>>> import Docker.Client+>>> import Data.Maybe+>>> import Conduit+>>> h <- defaultHttpHanlder+>>> let cid = fromJust $ toContainerID "fee86e1d522b"+>>> runDockerT (defaultClientOpts, h) $ getContainerLogsStream defaultLogOpts cid stdoutC+@++-}+getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)+getContainerLogsStream logopts cid = requestHelper' GET (ContainerLogsEndpoint logopts True cid)+-- JP: Should the second (follow) argument be True? XXX++-- | Build an Image from a Dockerfile+--+-- TODO: Add X-Registry-Config+--+-- TODO: Add support for remote URLs to a Dockerfile+--+-- TODO: Clean up temp tar.gz file after the image is built+buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())+buildImageFromDockerfile opts base = do+    ctx <- makeBuildContext $ BuildContextRootDir base+    case ctx of+        Left e  -> return $ Left e+        Right c -> requestUnit POST (BuildImageEndpoint opts c)++-- | Pulls an image from Docker Hub (by default).+--+-- TODO: Add support for X-Registry-Auth and pulling from private docker+-- registries.+--+-- TODO: Implement importImage function that uses he same+-- CreateImageEndpoint but rather than pulling from docker hub it imports+-- the image from a tarball or a URL.+pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)+pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing) 

@@ -3,21 +3,25 @@  module Docker.Client.Http where -import           Control.Monad.Reader         (ReaderT, runReaderT)+-- import           Control.Monad.Base           (MonadBase(..), liftBaseDefault)+import           Control.Monad.Catch          (MonadMask (..))+import           Control.Monad.Reader         (ReaderT (..), runReaderT) import qualified Data.ByteString.Char8        as BSC import qualified Data.ByteString.Lazy         as BL+import           Data.Conduit                 (Sink) 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,+import           Network.HTTP.Client          (defaultManagerSettings,                                                managerRawConnection, method,                                                newManager, parseUrl,                                                requestBody, requestHeaders) import qualified Network.HTTP.Client          as HTTP import           Network.HTTP.Client.Internal (makeConnection)+import qualified Network.HTTP.Simple          as NHS import           Network.HTTP.Types           (StdMethod, status101, status200,                                                status201, status204) import           Network.TLS                  (ClientHooks (..),@@ -27,7 +31,7 @@ import           Network.TLS.Extra            (ciphersuite_strong) import           System.X509                  (getSystemCertificateStore) -import           Control.Exception            (try)+import           Control.Monad.Catch          (try) import           Control.Monad.Except import           Control.Monad.Reader.Class import           Data.Text                    as T@@ -38,20 +42,22 @@   import           Docker.Client.Internal       (getEndpoint,+                                               getEndpointContentType,                                                getEndpointRequestBody) import           Docker.Client.Types          (DockerClientOpts, Endpoint (..),-                                               baseUrl)+                                               apiVer, baseUrl)  type Request = HTTP.Request type Response = HTTP.Response BL.ByteString type HttpVerb = StdMethod-type HttpHandler m = Request -> m (Either DockerError Response)+newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a)) -data DockerError = DockerConnectionError+data DockerError = DockerConnectionError NHS.HttpException                  | DockerInvalidRequest Endpoint+                 | DockerClientError Text                  | 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)+                 | GenericDockerError Text deriving (Show, Typeable)  newtype DockerT m a = DockerT {         unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a@@ -75,6 +81,9 @@ instance MonadIO m => MonadIO (DockerT m) where     liftIO = lift . liftIO +-- instance MonadBase IO m => MonadBase IO (DockerT m) where+--     liftBase = liftBaseDefault+ runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h) @@ -84,28 +93,29 @@ -- 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)+        where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) 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")]}+                                              requestHeaders = [("Content-Type", (getEndpointContentType e))]}                             Nothing -> Nothing-              request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,+              request = (\r -> maybe r (\body -> r {requestBody = body,  -- This will either be a HTTP.RequestBodyLBS  or HTTP.RequestBodySourceChunked for the build endpoint                                                     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+defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)+defaultHttpHandler = do     manager <- liftIO $ newManager defaultManagerSettings-    httpHandler manager request+    return $ httpHandler manager -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+httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..+    let request = NHS.setRequestManager manager request'+    try (NHS.httpSink request sink) >>= \res -> case res of+        Right res                              -> return res+        Left e@HTTP.FailedConnectionException{}  -> return $ Left $ DockerConnectionError e+        Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e         Left e                                 -> return $ Left $ GenericDockerError (T.pack $ show e)  -- | Connect to a unix domain socket (the default docker socket is@@ -113,13 +123,13 @@ -- --   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+unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to+                -> m (HttpHandler m)+unixHttpHandler fp = do   let mSettings = defaultManagerSettings                     { managerRawConnection = return $ openUnixSocket fp}   manager <- liftIO $ newManager mSettings-  httpHandler manager request+  return $ httpHandler manager    where     openUnixSocket filePath _ _ _ = do@@ -194,6 +204,11 @@         Nothing     else         Just $ DockerInvalidStatusCode st+statusCodeToError (WaitContainerEndpoint _) st =+    if st == status200 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st statusCodeToError (KillContainerEndpoint _ _) st =     if st == status204 then         Nothing@@ -229,5 +244,14 @@         Nothing     else         Just $ DockerInvalidStatusCode st-+statusCodeToError (BuildImageEndpoint _ _) st =+    if st == status200 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st+statusCodeToError (CreateImageEndpoint _ _ _) st =+    if st == status200 then+        Nothing+    else+        Just $ DockerInvalidStatusCode st 

@@ -1,12 +1,14 @@ 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 qualified Data.ByteString.Char8    as BSC+import qualified Data.Conduit.Binary      as CB import           Data.Text                as T import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)+import qualified Network.HTTP.Client      as HTTP+import           Network.HTTP.Conduit     (requestBodySourceChunked) import           Network.HTTP.Types       (Query, encodePath,                                            encodePathSegments) @@ -22,50 +24,65 @@ 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+getEndpoint :: ApiVersion -> Endpoint -> T.Text+getEndpoint v VersionEndpoint = encodeURL [v, "version"]+getEndpoint v (ListContainersEndpoint _) = encodeURL [v, "containers", "json"] -- Make use of lsOpts here+getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here+getEndpoint v (CreateContainerEndpoint _ cn) = case cn of+        Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]+        Nothing -> encodeURL [v, "containers", "create"]+getEndpoint v (StartContainerEndpoint startOpts cid) = encodeURLWithQuery [v, "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+getEndpoint v (StopContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "stop"] query         where query = case t of-                Timeout x -> [("t", Just (encodeQ $ show x))]+                Timeout x      -> [("t", Just (encodeQ $ show x))]                 DefaultTimeout -> []-getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query+getEndpoint v (WaitContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "wait"]+getEndpoint v (KillContainerEndpoint s cid) = encodeURLWithQuery [v, "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+                _     -> [("signal", Just (encodeQ $ show s))]+getEndpoint v (RestartContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "restart"] query         where query = case t of-                Timeout x -> [("t", Just (encodeQ $ show x))]+                Timeout x      -> [("t", Just (encodeQ $ show x))]                 DefaultTimeout -> []-getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"]-getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"]+getEndpoint v (PauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "pause"]+getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "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+getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =+            encodeURLWithQuery    [v, "containers", fromContainerID cid, "logs"] query         where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]-getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =-            encodeURLWithQuery ["containers", fromContainerID cid] query+getEndpoint v (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =+            encodeURLWithQuery [v, "containers", fromContainerID cid] query         where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]-getEndpoint (InspectContainerEndpoint cid) =-            encodeURLWithQuery ["containers", fromContainerID cid, "json"] []+getEndpoint v (InspectContainerEndpoint cid) =+            encodeURLWithQuery [v, "containers", fromContainerID cid, "json"] []+getEndpoint v (BuildImageEndpoint o _) = encodeURLWithQuery [v, "build"] query+        where query = [("t", Just t), ("dockerfile", Just dockerfile), ("q", Just q), ("nocache", Just nocache), ("rm", Just rm), ("forcerm", Just forcerm), ("pull", Just pull)]+              t = encodeQ $ T.unpack $ buildImageName o+              dockerfile = encodeQ $ T.unpack $ buildDockerfileName o+              q = encodeQ $ show $ buildQuiet o+              nocache = encodeQ $ show $ buildNoCache o+              rm = encodeQ $ show $ buildRemoveItermediate o+              forcerm = encodeQ $ show $ buildForceRemoveIntermediate o+              pull = encodeQ $ show $ buildPullParent o+getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images", "create"] query+        where query = [("fromImage", Just n), ("tag", Just t)]+              n = encodeQ $ T.unpack name+              t = encodeQ $ T.unpack tag -getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString+getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing getEndpointRequestBody (ListContainersEndpoint _) = Nothing getEndpointRequestBody (ListImagesEndpoint _) = Nothing-getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts+getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts) getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing+getEndpointRequestBody (WaitContainerEndpoint _) = Nothing getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing getEndpointRequestBody (PauseContainerEndpoint _) = Nothing@@ -73,3 +90,11 @@ getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing getEndpointRequestBody (InspectContainerEndpoint _) = Nothing++getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp+getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing++getEndpointContentType :: Endpoint -> BSC.ByteString+getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"+getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"+

@@ -12,6 +12,7 @@     , fromImageID     , toImageID     , Timeout(..)+    , StatusCode(..)     , Signal(..)     , ContainerDetails(..)     , DockerClientOpts(..)@@ -29,6 +30,8 @@     , Image(..)     , dropImagePrefix     , CreateOpts(..)+    , BuildOpts(..)+    , defaultBuildOpts     , defaultCreateOpts     , DetachKeys(..)     , StartOpts(..)@@ -83,6 +86,8 @@     , addLink     , addVolume     , addVolumeFrom+    , MemoryConstraint(..)+    , MemoryConstraintSize(..)     ) where  import           Data.Aeson          (FromJSON, ToJSON, genericParseJSON,@@ -109,6 +114,7 @@       | CreateContainerEndpoint CreateOpts (Maybe ContainerName)       | StartContainerEndpoint StartOpts ContainerID       | StopContainerEndpoint Timeout ContainerID+      | WaitContainerEndpoint ContainerID       | KillContainerEndpoint Signal ContainerID       | RestartContainerEndpoint Timeout ContainerID       | PauseContainerEndpoint ContainerID@@ -117,6 +123,8 @@       -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.       | DeleteContainerEndpoint DeleteOpts ContainerID       | InspectContainerEndpoint ContainerID+      | BuildImageEndpoint BuildOpts FilePath+      | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)     deriving (Eq, Show)  -- | We should newtype this@@ -163,6 +171,20 @@ -- | Timeout used for stopping a container. DefaultTimeout is 10 seconds. data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show) +data StatusCode = StatusCode Int++instance ToJSON StatusCode where+    toJSON (StatusCode c) = object ["StatusCode" .= c]++instance FromJSON StatusCode where+    parseJSON (JSON.Object o) = do+        c <- o .: "StatusCode"+        if c >= 0 && c <= 255 then+          return (StatusCode c)+        else+          fail "Unknown exit code"+    parseJSON _ = fail "Unknown exit code"+ -- 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.@@ -177,16 +199,16 @@  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 "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"+    parseJSON _                       = fail "Unknown Signal"  instance ToJSON Signal where-    toJSON SIGHUP = "SIGHUP"-    toJSON SIGINT = "SIGINT"+    toJSON SIGHUP  = "SIGHUP"+    toJSON SIGINT  = "SIGINT"     toJSON SIGQUIT = "SIGQUIT"     toJSON SIGSTOP = "SIGSTOP"     toJSON SIGTERM = "SIGTERM"@@ -519,13 +541,13 @@     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 "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"+    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.@@ -700,6 +722,28 @@                 , force         :: Bool -- ^ If the container is still running force deletion anyway.                 } deriving (Eq, Show) +-- TODO: Add support for container build constraints+-- | Options for when building images from a Dockerfile+data BuildOpts = BuildOpts {+                 buildImageName               :: Text -- ^ Image name in the form of name:tag; ie. myimage:latest.:w+               , buildDockerfileName          :: Text -- ^ Name of dockerfile (default: Dockerfile)+               , buildQuiet                   :: Bool+               , buildNoCache                 :: Bool -- ^ Do not use cache when building the image.+               , buildRemoveItermediate       :: Bool -- ^ Remove intermediate containers after a successful build (default true).+               , buildForceRemoveIntermediate :: Bool -- ^ Always remove intermediate containers.+               , buildPullParent              :: Bool -- ^ Always attempt to pull a newer version of the *parent* image (ie. FROM debian:jessie).+               } deriving (Eq, Show)++defaultBuildOpts :: Text -> BuildOpts+defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag+                                     , buildDockerfileName = "Dockerfile"+                                     , buildQuiet = False+                                     , buildNoCache = False+                                     , buildRemoveItermediate = True+                                     , buildForceRemoveIntermediate = False+                                     , buildPullParent = False+                                     }+ -- | 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.@@ -738,12 +782,12 @@  instance ToJSON VolumePermission where     toJSON ReadWrite = "rw"-    toJSON ReadOnly = "ro"+    toJSON ReadOnly  = "ro"  instance FromJSON VolumePermission where     parseJSON "rw" = return ReadWrite     parseJSON "ro" = return ReadOnly-    parseJSON _ = fail "Failed to parse VolumePermission"+    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@@ -765,8 +809,8 @@  instance {-# OVERLAPPING #-} 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"+    parseJSON (JSON.Null)     = return []+    parseJSON _               = fail "Volume is not an object"   data Bind = Bind { hostSrc          :: Text@@ -776,10 +820,10 @@  instance FromJSON Bind where     parseJSON (JSON.String t) = case T.split (== ':') t of-        [src, dest] -> return $ Bind src dest Nothing+        [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"+        _                 -> fail "Could not parse Bind"     parseJSON _ = fail "Bind is not a string"  data Device = Device {@@ -802,15 +846,15 @@  instance FromJSON VolumeFrom where     parseJSON (JSON.String t) = case T.split (== ':') t of-        [vol] -> return $ VolumeFrom vol Nothing+        [vol]       -> return $ VolumeFrom vol Nothing         [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite         [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly-        _ -> fail "Could not parse VolumeFrom"+        _           -> 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"+        Nothing  -> toJSON $ n <> ":" <> "rw"         Just per -> toJSON $ n <> ":" <> (T.pack $ show per)  instance ToJSON Bind where@@ -822,40 +866,40 @@  instance FromJSON Link where     parseJSON (JSON.String t) = case T.split (== ':') t of-        [f] -> return $ Link f Nothing+        [f]   -> return $ Link f Nothing         [f,s] -> return $ Link f $ Just s-        _ -> fail "Could not parse Link"+        _     -> 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+                        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"+    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 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)@@ -894,14 +938,14 @@  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"+    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"+    toJSON Bridge          = JSON.String "bridge"+    toJSON Host            = JSON.String "host"+    toJSON NetworkDisabled = JSON.String "none"  data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord) @@ -917,7 +961,7 @@     parseJSON val = case val of                     "tcp" -> return TCP                     "udp" -> return UDP-                    _ -> fail "PortType: Invalid port type."+                    _     -> fail "PortType: Invalid port type."  -- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show) --@@ -1047,7 +1091,7 @@             "on-failure" -> do                 retry <- o .: "MaximumRetryCount"                 return $ RestartOnFailure retry-            "off" -> return RestartOff+            "no" -> return RestartOff             _ -> fail "Could not parse RestartPolicy"     parseJSON _ = fail "RestartPolicy is not an object" @@ -1055,7 +1099,7 @@     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"]+    toJSON RestartOff = object ["Name" .= JSON.String "no"]  data Isolation = Default | Process | Hyperv  deriving (Eq, Show) @@ -1233,7 +1277,7 @@ data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)  instance ToJSON MemoryConstraint where-    toJSON (MemoryConstraint x B) = toJSON x+    toJSON (MemoryConstraint x B)  = toJSON x     toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024     toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024 

@@ -0,0 +1,131 @@+{-# LANGUAGE ExplicitForAll      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Docker.Client.Utils where++import qualified Codec.Archive.Tar           as Tar+import qualified Codec.Compression.GZip      as GZip+import           Control.Monad               (filterM, liftM, unless)+import           Control.Monad.IO.Class+import qualified Data.ByteString.Lazy        as BS+import           Data.Monoid                 ((<>))+import qualified Data.Text                   as T+import qualified Data.Text.IO                as TIO+import qualified Data.UUID                   as UUID+import qualified Data.UUID.V4                as UUID+import           System.Directory            (doesDirectoryExist, doesFileExist,+                                              getTemporaryDirectory)+import           System.FilePath             (isAbsolute, makeRelative, (</>))+import           System.FilePath.Find        (FilterPredicate,+                                              RecursionPredicate, always,+                                              fileName, find, (==?))+import           System.FilePath.GlobPattern ((~~))+import           System.IO.Error             (tryIOError)+-- import           System.IO.Temp              (withSystemTempDirectory)+--+import           Docker.Client.Http++type File = FilePath+data DirTree = DirTree [File] [DirTree]+++newtype ExclusionPattern = ExclusionPattern T.Text deriving (Eq, Show)+newtype InclusionPattern = InclusionPattern T.Text deriving (Eq, Show)++data DockerIgnore = DockerIgnore { exclusionPatterns :: [ExclusionPattern]+                                 , inclusionPatterns :: [InclusionPattern]+                                 } deriving (Eq, Show)++newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (Eq, Show)++makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)+makeBuildContext base = liftIO $ tryIOError (makeBuildContext' base) >>= \res -> case res of+    Left e -> return $ Left $ DockerClientError (T.pack $ show e)+    Right c -> return $ Right c++makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath+makeBuildContext' (BuildContextRootDir base) = do+    uuid <- liftIO UUID.nextRandom+    fs <- liftIO $ getBuildContext $ BuildContextRootDir base+    let relFs = map (makeRelative base) fs+    tmpDir <- liftIO getTemporaryDirectory+    let tmpF = tmpDir </> "docker.context-" <> UUID.toString uuid  <> ".tar.gz"+    liftIO $ BS.writeFile tmpF . GZip.compress . Tar.write =<< Tar.pack base relFs+    return tmpF++parseDockerIgnoreFile :: T.Text -> DockerIgnore+parseDockerIgnoreFile c = DockerIgnore{ exclusionPatterns=parseExclusions+                                      , inclusionPatterns=parseInclusions}+    where lines = filter (not . T.isPrefixOf "#") (T.lines c) -- Ignore comments+          parseExclusions = map ExclusionPattern $ filter (\l -> not (T.isPrefixOf "!" l) && (l /= "")) lines+          parseInclusions = map (InclusionPattern . T.drop 1) $ filter (\l -> T.isPrefixOf "!" l && (l /= "")) lines++getBuildContext :: BuildContextRootDir -> IO [FilePath]+getBuildContext (BuildContextRootDir base) = do+    -- The base dir needs to be a path to a directory and not a path to+    -- a file+    exists <- doesDirectoryExist base+    let abs = isAbsolute base+    unless (exists && abs) $ fail "Path to context needs to be a directory that: exists, is readable, and is an absolute path."+    di <- find always (fileName ==? ".dockerignore") base+    dockerignore <- case di of+        [] -> return $ DockerIgnore [] []+        -- This should not return more than one result though+        (x:_) -> do+            c <- TIO.readFile x+            return $ parseDockerIgnoreFile c+    -- This will traverse the directory recursively+    fs <- find (shouldRecurse dockerignore) (shouldInclude dockerignore) base+    -- fs is a list of directories *and* files in those directories. So+    -- an example result would look like ["/tmp/project/files",+    -- "/tmp/project/files/file1.txt"] and we want just the individual+    -- files otherwise tar duplicates them when making the archive.+    fs' <- filterM doesFileExist fs+    -- For some reason base is in there as well and we don't need that+    return $ filter (not . (==) base) fs'++shouldInclude :: DockerIgnore -> FilterPredicate+shouldInclude d = check `liftM` fileName+    where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))++shouldRecurse :: DockerIgnore -> RecursionPredicate+shouldRecurse d = check `liftM` fileName+    where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))++-- TODO: We don't handle precedence rules. For instance a dockerignore file+-- like this:+--+-- *.md+-- !README*.md+-- README-secret.md+--+-- Should result in no markdown files being included in the context except README files other+-- than README-secret.md. FIXME: OUR implementation would in fact include+-- README-secret.md as well!!!+--+-- Whereas this:+--+-- *.md+-- README-secret.md+-- !README*.md+--+-- Should result in all of the README files being included. The middle line has no effect+-- because !README*.md matches README-secret.md and comes last. Our+-- implementation will result in the same thing.+dockerIgnoreDecision :: (Bool, Bool) -> Bool+dockerIgnoreDecision p = case p of+         -- If it's in any of the exclusion patterns but also+         -- in any of the inclusion patterns then laeave it+         (True, True)   -> True+         (True, False)  -> False+         (False, True)  -> True+         (False, False) -> True++exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool+exclusionCheck f ps = any id (map (\(ExclusionPattern p) -> f ~~ T.unpack p) ps)++inclusionCheck :: FilePath -> [InclusionPattern] -> Bool+inclusionCheck f ps = any id (map (\(InclusionPattern p) -> f ~~ T.unpack p) ps)+

@@ -42,7 +42,8 @@     -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"     -- let settings = mkManagerSettings (TLSSettings params) Nothing     -- mgr <- newManager settings-    runDockerT (defaultClientOpts, defaultHttpHandler) f+    h <- defaultHttpHandler+    runDockerT (defaultClientOpts, h) f  testDockerVersion :: IO () testDockerVersion = runDocker $ do@@ -63,13 +64,17 @@     status1 <- startContainer defaultStartOpts c     _ <- inspectContainer c >>= fromRight     lift $ threadDelay 300000 -- give 300ms for the application to finish-    lift $ assert $ status1 == Right ()+    lift $ assert $ isRightUnit status1     status2 <- killContainer SIGTERM c     logs <- getContainerLogs defaultLogOpts c >>= fromRight-    lift $ assert $ status2 == Right ()+    lift $ assert $ isRightUnit status2     lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)     status3 <- deleteContainer (DeleteOpts True True) c-    lift $ assert $ status3 == Right ()+    lift $ assert $ isRightUnit status3++    where+        isRightUnit (Right ()) = True+        isRightUnit _ = False  testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]