diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -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 diff --git a/src/Docker/Client.hs b/src/Docker/Client.hs --- a/src/Docker/Client.hs +++ b/src/Docker/Client.hs @@ -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 diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -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) diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -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 diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -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" + diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -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": "", "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 diff --git a/src/Docker/Client/Utils.hs b/src/Docker/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Client/Utils.hs @@ -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) + diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -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 ]