git.iko.soy/docker-hs
on master help sign in
Merge pull request #26 from jprider63/master

Streaming API w/ dev merged

commit6797db9fee890bb693883c7e807d5c51ef3ee574 authorDeni Bertovic <deni@denibertovic.com> dateSat 18 Mar 2017, 20:49 (10 years ago) parentc817230d0489eb
11 files changed+386−83
compare with master
unifiedsplit
.travis.yml+12−7 docker.cabal+17−1 src/Docker/Client/Api.hs+72−43 src/Docker/Client/Http.hs+42−23 src/Docker/Client/Internal.hs+23−4 src/Docker/Client/Types.hs+43 src/Docker/Client/Utils.hs+131 stack-7.10.yaml+32 stack-8.0.yaml+4 stack.yaml+1−1 tests/tests.hs+9−4
.travis.yml+12−7
@@ -16,7 +16,8 @@ services:
1616 - docker
1717
1818env:
19− - STACK_ARGS=""
19+ - GHCVER=7.10 STACK_ARGS=""
20+ - GHCVER=8.0 STACK_ARGS=""
2021
2122addons:
2223 apt:
@@ -24,20 +25,24 @@ addons:
2425 - libgmp-dev
2526
2627before_install:
27− # Upgrade docker to 1.12
28+ # Upgrade docker to 1.12.3.0
2829 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
2930 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
3031 - sudo apt-get update
31− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.0-0~trusty
32+ - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.3-0~trusty
33+
34+install:
3235 - mkdir -p "$HOME"/.local/bin
3336 - export PATH=$HOME/.local/bin:$PATH
34−
37+ - export STACK_YAML=stack-$GHCVER.yaml
3538 # install Stack
3639 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C $HOME/.local/bin '*/stack'
37− - export PATH=$(stack --stack-yaml stack.yaml path --local-install-root):$PATH
38− - stack setup
39−
40+ - export PATH=$(stack path --local-install-root):$PATH
41+ - stack --version
4042
4143script:
44+ - stack setup
45+ - stack update
46+ - stack build
4247 - stack test
4348
docker.cabal+17−1
@@ -17,7 +17,7 @@ stability: experimental
1717library
1818 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances
1919 hs-source-dirs: src
20− exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http
20+ exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
2121 -- other-modules: Docker.Internal
2222 build-depends: base >= 4.7 && < 5
2323 , aeson >= 0.9.0 && < 1.1.0
@@ -27,6 +27,22 @@ library
2727 , data-default-class >= 0.0.1 && < 0.2.0
2828 , http-client >= 0.4.0 && < 0.5.0
2929 , http-types >= 0.9 && < 0.10.0
30+ , conduit
31+ , conduit-combinators
32+ , conduit-extra
33+ , exceptions
34+ , http-conduit
35+ , monad-control
36+ , resourcet
37+ , transformers
38+ , transformers-base
39+ , tar
40+ , zlib
41+ , uuid
42+ , temporary
43+ , directory >= 1.2.5.0
44+ , filemanip
45+ , filepath
3046 , mtl >= 2.0.0 && < 3.0.0
3147 , network >= 2.6.0
3248 , text >= 1.0.0 && < 2.0.0
src/Docker/Client/Api.hs+72−43
@@ -7,6 +7,7 @@ module Docker.Client.Api (
77 , createContainer
88 , startContainer
99 , stopContainer
10+ , waitContainer
1011 , killContainer
1112 , restartContainer
1213 , pauseContainer
@@ -14,110 +15,131 @@ module Docker.Client.Api (
1415 , deleteContainer
1516 , inspectContainer
1617 , getContainerLogs
18+ , getContainerLogsStream
1719 -- * Images
1820 , listImages
21+ , buildImageFromDockerfile
1922 -- * Other
2023 , getDockerVersion
2124 ) where
2225
23−import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
24−import Control.Monad.Reader (ask, lift)
25−import Data.Aeson (FromJSON, eitherDecode')
26−import qualified Data.ByteString.Lazy as BSL
27−import qualified Data.Text as Text
28−import Network.HTTP.Client (responseBody, responseStatus)
26+import Control.Monad.Catch (MonadMask(..))
27+import Control.Monad.IO.Class
28+import Control.Monad.Reader (ask, lift)
29+import Data.Aeson (FromJSON, eitherDecode')
30+import qualified Data.ByteString as BS
31+import qualified Data.ByteString.Lazy as BSL
32+import Data.Conduit (Sink)
33+import qualified Data.Conduit.Binary as Conduit
34+import qualified Data.Text as Text
35+import Network.HTTP.Client (responseStatus)
2936import Network.HTTP.Types (StdMethod (..))
37+import System.Exit (ExitCode(..))
3038
3139import Docker.Client.Http
3240import Docker.Client.Types
41+import Docker.Client.Utils
3342
34−requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
43+requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
3544requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
3645
37−requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
38−requestHelper verb endpoint = runExceptT $ do
39− (opts, httpHandler) <- lift ask
46+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
47+requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
48+
49+requestHelper' :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> Sink BS.ByteString m a -> DockerT m (Either DockerError a)
50+requestHelper' verb endpoint sink = do
51+ (opts, HttpHandler httpHandler) <- ask
4052 case mkHttpRequest verb endpoint opts of
4153 Nothing ->
42− throwError $ DockerInvalidRequest endpoint
54+ return $ Left $ DockerInvalidRequest endpoint
4355 Just request -> do
44− response <- ExceptT $ lift $ httpHandler request
45−
46− -- Check status code.
47− let status = responseStatus response
48− maybe (return ()) throwError $
49− statusCodeToError endpoint status
50−
51− return response
52−
53−parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
56+ -- JP: Do we need runResourceT?
57+ -- lift $ NHS.httpSink request $ \response ->
58+ lift $ httpHandler request $ \response ->
59+ -- Check status code.
60+ let status = responseStatus response in
61+ case statusCodeToError endpoint status of
62+ Just err ->
63+ return $ Left err
64+ Nothing ->
65+ fmap Right sink
66+
67+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
5468parseResponse (Left err) =
5569 return $ Left err
5670parseResponse (Right response) =
5771 -- Parse request body.
58− case eitherDecode' $ responseBody response of
72+ case eitherDecode' response of
5973 Left err ->
6074 return $ Left $ DockerClientDecodeError $ Text.pack err
6175 Right r ->
6276 return $ Right r
6377
6478-- | Gets the version of the docker engine remote API.
65−getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)
79+getDockerVersion :: forall m. (MonadIO m, MonadMask m) => DockerT m (Either DockerError DockerVersion)
6680getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
6781
6882-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
6983-- = True}@ to get a list of stopped containers as well.
70−listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])
84+listContainers :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Container])
7185listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
7286
7387-- | Lists all docker images.
74−listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])
88+listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])
7589listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
7690
7791-- | Creates a docker container but does __not__ start it. See
7892-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
7993-- for some sane defaults.
80−createContainer :: forall m. Monad m => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
94+createContainer :: forall m. (MonadIO m, MonadMask m) => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
8195createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
8296
8397-- | Start a container from a given 'ContainerID' that we get from
8498-- 'createContainer'. See 'StartOpts' for a list of configuration options
8599-- for starting a container. Use 'defaultStartOpts' for sane defaults.
86−startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
100+startContainer :: forall m. (MonadIO m, MonadMask m) => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
87101startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
88102
89103-- | Attempts to stop a container with the given 'ContainerID' gracefully
90104-- (SIGTERM).
91105-- The docker daemon will wait for the given 'Timeout' and then send
92106-- a SIGKILL killing the container.
93−stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
107+stopContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
94108stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
95109
110+-- | Blocks until a container with the given 'ContainerID' stops,
111+-- then returns the exit code
112+waitContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ExitCode)
113+waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse)
114+ where
115+ statusCodeToExitCode (StatusCode 0) = ExitSuccess
116+ statusCodeToExitCode (StatusCode x) = ExitFailure x
117+
96118-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
97119-- as 'stopContainer' but you choose the signal directly.
98−killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())
120+killContainer :: forall m. (MonadIO m, MonadMask m) => Signal -> ContainerID -> DockerT m (Either DockerError ())
99121killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
100122
101123-- | Restarts a container with the given 'ContainerID'.
102−restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
124+restartContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
103125restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
104126
105127-- | Pauses a container with the given 'ContainerID'.
106−pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
128+pauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
107129pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
108130
109131-- | Unpauses a container with the given 'ContainerID'.
110−unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
132+unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
111133unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
112134
113135-- | Deletes a container with the given 'ContainerID'.
114136-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
115137-- defaults.
116−deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
138+deleteContainer :: forall m. (MonadIO m, MonadMask m) => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
117139deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
118140
119141-- | Gets 'ContainerDetails' for a given 'ContainerID'.
120−inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)
142+inspectContainer :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails)
121143inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
122144
123145-- | Get's container's logs for a given 'ContainerID'.
@@ -135,12 +157,19 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars
135157--
136158-- The recommended method is to use one of the other 'LogDriverType's available (like
137159-- syslog) for creating your containers.
138−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
139−getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
140−
141−-- TODO: Use http-conduit to output to a sink.
142−-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
143−-- getContainerLogsStream sink logopts cid = runResourceT $ do
144−-- response <- http request manager
145−-- responseBody response C.$$+- sink
146−
160+getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
161+getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
162+
163+getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
164+getContainerLogsStream logopts cid sink = requestHelper' GET (ContainerLogsEndpoint logopts True cid) sink
165+-- JP: Should the second (follow) argument be True? XXX
166+
167+-- TODO: Add X-Registry-Config
168+-- TODO: Add support for remote URLs to a Dockerfile
169+-- TODO: Clean up temp tar.gz file after the image is built
170+buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())
171+buildImageFromDockerfile opts base = do
172+ ctx <- makeBuildContext $ BuildContextRootDir base
173+ case ctx of
174+ Left e -> return $ Left e
175+ Right c -> requestUnit POST (BuildImageEndpoint opts c)
src/Docker/Client/Http.hs+42−23
@@ -3,16 +3,19 @@
33
44module Docker.Client.Http where
55
6−import Control.Monad.Reader (ReaderT, runReaderT)
6+-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7+import Control.Monad.Catch (MonadMask(..))
8+import Control.Monad.Reader (ReaderT(..), runReaderT)
79import qualified Data.ByteString.Char8 as BSC
810import qualified Data.ByteString.Lazy as BL
11+import Data.Conduit (Sink)
912import Data.Default.Class (def)
1013import Data.Monoid ((<>))
1114import Data.Text.Encoding (encodeUtf8)
1215import Data.X509 (CertificateChain (..))
1316import Data.X509.CertificateStore (makeCertificateStore)
1417import Data.X509.File (readKeyFile, readSignedObject)
15−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
18+import Network.HTTP.Client (defaultManagerSettings,
1619 managerRawConnection, method,
1720 newManager, parseUrl,
1821 requestBody, requestHeaders)
@@ -20,6 +23,7 @@ import qualified Network.HTTP.Client as HTTP
2023import Network.HTTP.Client.Internal (makeConnection)
2124import Network.HTTP.Types (StdMethod, status101, status200,
2225 status201, status204)
26+import qualified Network.HTTP.Simple as NHS
2327import Network.TLS (ClientHooks (..),
2428 ClientParams (..), Shared (..),
2529 Supported (..),
@@ -27,7 +31,7 @@ import Network.TLS (ClientHooks (..),
2731import Network.TLS.Extra (ciphersuite_strong)
2832import System.X509 (getSystemCertificateStore)
2933
30−import Control.Exception (try)
34+import Control.Monad.Catch (try)
3135import Control.Monad.Except
3236import Control.Monad.Reader.Class
3337import Data.Text as T
@@ -38,6 +42,7 @@ import qualified Network.Socket.ByteString as SBS
3842
3943
4044import Docker.Client.Internal (getEndpoint,
45+ getEndpointContentType,
4146 getEndpointRequestBody)
4247import Docker.Client.Types (DockerClientOpts, Endpoint (..),
4348 baseUrl)
@@ -45,13 +50,14 @@ import Docker.Client.Types (DockerClientOpts, Endpoint (..),
4550type Request = HTTP.Request
4651type Response = HTTP.Response BL.ByteString
4752type HttpVerb = StdMethod
48−type HttpHandler m = Request -> m (Either DockerError Response)
53+newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))
4954
50−data DockerError = DockerConnectionError
55+data DockerError = DockerConnectionError NHS.HttpException
5156 | DockerInvalidRequest Endpoint
57+ | DockerClientError Text
5258 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
5359 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
54− | GenericDockerError Text deriving (Eq, Show, Typeable)
60+ | GenericDockerError Text deriving (Show, Typeable)
5561
5662newtype DockerT m a = DockerT {
5763 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
@@ -75,6 +81,9 @@ instance MonadTrans DockerT where
7581instance MonadIO m => MonadIO (DockerT m) where
7682 liftIO = lift . liftIO
7783
84+-- instance MonadBase IO m => MonadBase IO (DockerT m) where
85+-- liftBase = liftBaseDefault
86+
7887runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
7988runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
8089
@@ -89,23 +98,24 @@ mkHttpRequest verb e opts = request
8998 request' = case initialR of
9099 Just ir ->
91100 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
92− requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
101+ requestHeaders = [("Content-Type", (getEndpointContentType e))]}
93102 Nothing -> Nothing
94− request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,
103+ request = (\r -> maybe r (\body -> r {requestBody = body, -- This will either be a HTTP.RequestBodyLBS or HTTP.RequestBodySourceChunked for the build endpoint
95104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
96105 -- Note: Do we need to set length header?
97106
98−defaultHttpHandler :: MonadIO m => HttpHandler m
99−defaultHttpHandler request = do
107+defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
108+defaultHttpHandler = do
100109 manager <- liftIO $ newManager defaultManagerSettings
101− httpHandler manager request
102−
103−httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
104−httpHandler manager request = liftIO $ do
105− try (httpLbs request manager) >>= \res -> case res of
106− Right res -> return $ Right res
107− Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
108− Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
110+ return $ httpHandler manager
111+
112+httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
113+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114+ let request = NHS.setRequestManager manager request'
115+ try (NHS.httpSink request sink) >>= \res -> case res of
116+ Right res -> return res
117+ Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
118+ Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
109119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
110120
111121-- | Connect to a unix domain socket (the default docker socket is
@@ -113,13 +123,13 @@ httpHandler manager request = liftIO $ do
113123--
114124-- Docker seems to ignore the hostname in requests sent over unix domain
115125-- sockets (and the port obviously doesn't matter either)
116−unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
117− -> HttpHandler m
118−unixHttpHandler fp request = do
126+unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
127+ -> m (HttpHandler m)
128+unixHttpHandler fp = do
119129 let mSettings = defaultManagerSettings
120130 { managerRawConnection = return $ openUnixSocket fp}
121131 manager <- liftIO $ newManager mSettings
122− httpHandler manager request
132+ return $ httpHandler manager
123133
124134 where
125135 openUnixSocket filePath _ _ _ = do
@@ -194,6 +204,11 @@ statusCodeToError (StopContainerEndpoint _ _) st =
194204 Nothing
195205 else
196206 Just $ DockerInvalidStatusCode st
207+statusCodeToError (WaitContainerEndpoint _) st =
208+ if st == status200 then
209+ Nothing
210+ else
211+ Just $ DockerInvalidStatusCode st
197212statusCodeToError (KillContainerEndpoint _ _) st =
198213 if st == status204 then
199214 Nothing
@@ -229,5 +244,9 @@ statusCodeToError (InspectContainerEndpoint _) st =
229244 Nothing
230245 else
231246 Just $ DockerInvalidStatusCode st
232−
247+statusCodeToError (BuildImageEndpoint _ _) st =
248+ if st == status200 then
249+ Nothing
250+ else
251+ Just $ DockerInvalidStatusCode st
233252
src/Docker/Client/Internal.hs+23−4
@@ -1,12 +1,14 @@
11module Docker.Client.Internal where
22
3−
43import Blaze.ByteString.Builder (toByteString)
54import qualified Data.Aeson as JSON
65import Data.ByteString (ByteString)
7−import qualified Data.ByteString.Lazy as BSL
6+import qualified Data.ByteString.Char8 as BSC
7+import qualified Data.Conduit.Binary as CB
88import Data.Text as T
99import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10+import qualified Network.HTTP.Client as HTTP
11+import Network.HTTP.Conduit (requestBodySourceChunked)
1012import Network.HTTP.Types (Query, encodePath,
1113 encodePathSegments)
1214
@@ -39,6 +41,7 @@ getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fr
3941 where query = case t of
4042 Timeout x -> [("t", Just (encodeQ $ show x))]
4143 DefaultTimeout -> []
44+getEndpoint (WaitContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "wait"]
4245getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
4346 where query = case s of
4447 SIG x -> [("signal", Just (encodeQ $ show x))]
@@ -58,14 +61,24 @@ getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
5861 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
5962getEndpoint (InspectContainerEndpoint cid) =
6063 encodeURLWithQuery ["containers", fromContainerID cid, "json"] []
64+getEndpoint (BuildImageEndpoint o _) = encodeURLWithQuery ["build"] query
65+ where query = [("t", Just t), ("dockerfile", Just dockerfile), ("q", Just q), ("nocache", Just nocache), ("rm", Just rm), ("forcerm", Just forcerm), ("pull", Just pull)]
66+ t = encodeQ $ T.unpack $ buildImageName o
67+ dockerfile = encodeQ $ T.unpack $ buildDockerfileName o
68+ q = encodeQ $ show $ buildQuiet o
69+ nocache = encodeQ $ show $ buildNoCache o
70+ rm = encodeQ $ show $ buildRemoveItermediate o
71+ forcerm = encodeQ $ show $ buildForceRemoveIntermediate o
72+ pull = encodeQ $ show $ buildPullParent o
6173
62−getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString
74+getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
6375getEndpointRequestBody VersionEndpoint = Nothing
6476getEndpointRequestBody (ListContainersEndpoint _) = Nothing
6577getEndpointRequestBody (ListImagesEndpoint _) = Nothing
66−getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts
78+getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
6779getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
6880getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
81+getEndpointRequestBody (WaitContainerEndpoint _) = Nothing
6982getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
7083getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
7184getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
@@ -73,3 +86,9 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing
7386getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
7487getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
7588getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
89+getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
90+
91+getEndpointContentType :: Endpoint -> BSC.ByteString
92+getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
93+getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"
94+
src/Docker/Client/Types.hs+43
@@ -12,6 +12,7 @@ module Docker.Client.Types (
1212 , fromImageID
1313 , toImageID
1414 , Timeout(..)
15+ , StatusCode(..)
1516 , Signal(..)
1617 , ContainerDetails(..)
1718 , DockerClientOpts(..)
@@ -29,6 +30,8 @@ module Docker.Client.Types (
2930 , Image(..)
3031 , dropImagePrefix
3132 , CreateOpts(..)
33+ , BuildOpts(..)
34+ , defaultBuildOpts
3235 , defaultCreateOpts
3336 , DetachKeys(..)
3437 , StartOpts(..)
@@ -83,6 +86,8 @@ module Docker.Client.Types (
8386 , addLink
8487 , addVolume
8588 , addVolumeFrom
89+ , MemoryConstraint(..)
90+ , MemoryConstraintSize(..)
8691 ) where
8792
8893import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
@@ -109,6 +114,7 @@ data Endpoint =
109114 | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
110115 | StartContainerEndpoint StartOpts ContainerID
111116 | StopContainerEndpoint Timeout ContainerID
117+ | WaitContainerEndpoint ContainerID
112118 | KillContainerEndpoint Signal ContainerID
113119 | RestartContainerEndpoint Timeout ContainerID
114120 | PauseContainerEndpoint ContainerID
@@ -117,6 +123,7 @@ data Endpoint =
117123 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
118124 | DeleteContainerEndpoint DeleteOpts ContainerID
119125 | InspectContainerEndpoint ContainerID
126+ | BuildImageEndpoint BuildOpts FilePath
120127 deriving (Eq, Show)
121128
122129-- | We should newtype this
@@ -163,6 +170,20 @@ toImageID t =
163170-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
164171data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
165172
173+data StatusCode = StatusCode Int
174+
175+instance ToJSON StatusCode where
176+ toJSON (StatusCode c) = object ["StatusCode" .= c]
177+
178+instance FromJSON StatusCode where
179+ parseJSON (JSON.Object o) = do
180+ c <- o .: "StatusCode"
181+ if c >= 0 && c <= 255 then
182+ return (StatusCode c)
183+ else
184+ fail "Unknown exit code"
185+ parseJSON _ = fail "Unknown exit code"
186+
166187-- TODO: Add more Signals or use an existing lib
167188-- | Signal used for sending to the process running in the container.
168189-- The default signal is SIGTERM.
@@ -700,6 +721,28 @@ data DeleteOpts = DeleteOpts {
700721 , force :: Bool -- ^ If the container is still running force deletion anyway.
701722 } deriving (Eq, Show)
702723
724+-- TODO: Add support for container build constraints
725+-- | Options for when building images from a Dockerfile
726+data BuildOpts = BuildOpts {
727+ buildImageName :: Text -- ^ Image name in the form of name:tag; ie. myimage:latest.:w
728+ , buildDockerfileName :: Text -- ^ Name of dockerfile (default: Dockerfile)
729+ , buildQuiet :: Bool
730+ , buildNoCache :: Bool -- ^ Do not use cache when building the image.
731+ , buildRemoveItermediate :: Bool -- ^ Remove intermediate containers after a successful build (default true).
732+ , buildForceRemoveIntermediate :: Bool -- ^ Always remove intermediate containers.
733+ , buildPullParent :: Bool -- ^ Always attempt to pull a newer version of the *parent* image (ie. FROM debian:jessie).
734+ } deriving (Eq, Show)
735+
736+defaultBuildOpts :: Text -> BuildOpts
737+defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
738+ , buildDockerfileName = "Dockerfile"
739+ , buildQuiet = False
740+ , buildNoCache = False
741+ , buildRemoveItermediate = True
742+ , buildForceRemoveIntermediate = False
743+ , buildPullParent = False
744+ }
745+
703746-- | Default options for deleting a container. Most of the time we DON'T
704747-- want to delete the container's volumes or force delete it if it's
705748-- running.
src/Docker/Client/Utils.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+
6+module Docker.Client.Utils where
7+
8+import qualified Codec.Archive.Tar as Tar
9+import qualified Codec.Compression.GZip as GZip
10+import Control.Monad (filterM, liftM, unless)
11+import Control.Monad.IO.Class
12+import qualified Data.ByteString.Lazy as BS
13+import Data.Monoid ((<>))
14+import qualified Data.Text as T
15+import qualified Data.Text.IO as TIO
16+import qualified Data.UUID as UUID
17+import qualified Data.UUID.V4 as UUID
18+import System.Directory (doesDirectoryExist, doesFileExist,
19+ getTemporaryDirectory)
20+import System.FilePath (isAbsolute, makeRelative, (</>))
21+import System.FilePath.Find (FilterPredicate,
22+ RecursionPredicate, always,
23+ fileName, find, (==?))
24+import System.FilePath.GlobPattern ((~~))
25+import System.IO.Error (tryIOError)
26+-- import System.IO.Temp (withSystemTempDirectory)
27+--
28+import Docker.Client.Http
29+
30+type File = FilePath
31+data DirTree = DirTree [File] [DirTree]
32+
33+
34+newtype ExclusionPattern = ExclusionPattern T.Text deriving (Eq, Show)
35+newtype InclusionPattern = InclusionPattern T.Text deriving (Eq, Show)
36+
37+data DockerIgnore = DockerIgnore { exclusionPatterns :: [ExclusionPattern]
38+ , inclusionPatterns :: [InclusionPattern]
39+ } deriving (Eq, Show)
40+
41+newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (Eq, Show)
42+
43+makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)
44+makeBuildContext base = liftIO $ tryIOError (makeBuildContext' base) >>= \res -> case res of
45+ Left e -> return $ Left $ DockerClientError (T.pack $ show e)
46+ Right c -> return $ Right c
47+
48+makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath
49+makeBuildContext' (BuildContextRootDir base) = do
50+ uuid <- liftIO UUID.nextRandom
51+ fs <- liftIO $ getBuildContext $ BuildContextRootDir base
52+ let relFs = map (makeRelative base) fs
53+ tmpDir <- liftIO getTemporaryDirectory
54+ let tmpF = tmpDir </> "docker.context-" <> UUID.toString uuid <> ".tar.gz"
55+ liftIO $ BS.writeFile tmpF . GZip.compress . Tar.write =<< Tar.pack base relFs
56+ return tmpF
57+
58+parseDockerIgnoreFile :: T.Text -> DockerIgnore
59+parseDockerIgnoreFile c = DockerIgnore{ exclusionPatterns=parseExclusions
60+ , inclusionPatterns=parseInclusions}
61+ where lines = filter (not . T.isPrefixOf "#") (T.lines c) -- Ignore comments
62+ parseExclusions = map ExclusionPattern $ filter (\l -> not (T.isPrefixOf "!" l) && (l /= "")) lines
63+ parseInclusions = map (InclusionPattern . T.drop 1) $ filter (\l -> T.isPrefixOf "!" l && (l /= "")) lines
64+
65+getBuildContext :: BuildContextRootDir -> IO [FilePath]
66+getBuildContext (BuildContextRootDir base) = do
67+ -- The base dir needs to be a path to a directory and not a path to
68+ -- a file
69+ exists <- doesDirectoryExist base
70+ let abs = isAbsolute base
71+ unless (exists && abs) $ fail "Path to context needs to be a directory that: exists, is readable, and is an absolute path."
72+ di <- find always (fileName ==? ".dockerignore") base
73+ dockerignore <- case di of
74+ [] -> return $ DockerIgnore [] []
75+ -- This should not return more than one result though
76+ (x:_) -> do
77+ c <- TIO.readFile x
78+ return $ parseDockerIgnoreFile c
79+ -- This will traverse the directory recursively
80+ fs <- find (shouldRecurse dockerignore) (shouldInclude dockerignore) base
81+ -- fs is a list of directories *and* files in those directories. So
82+ -- an example result would look like ["/tmp/project/files",
83+ -- "/tmp/project/files/file1.txt"] and we want just the individual
84+ -- files otherwise tar duplicates them when making the archive.
85+ fs' <- filterM doesFileExist fs
86+ -- For some reason base is in there as well and we don't need that
87+ return $ filter (not . (==) base) fs'
88+
89+shouldInclude :: DockerIgnore -> FilterPredicate
90+shouldInclude d = check `liftM` fileName
91+ where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
92+
93+shouldRecurse :: DockerIgnore -> RecursionPredicate
94+shouldRecurse d = check `liftM` fileName
95+ where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
96+
97+-- TODO: We don't handle precedence rules. For instance a dockerignore file
98+-- like this:
99+--
100+-- *.md
101+-- !README*.md
102+-- README-secret.md
103+--
104+-- Should result in no markdown files being included in the context except README files other
105+-- than README-secret.md. FIXME: OUR implementation would in fact include
106+-- README-secret.md as well!!!
107+--
108+-- Whereas this:
109+--
110+-- *.md
111+-- README-secret.md
112+-- !README*.md
113+--
114+-- Should result in all of the README files being included. The middle line has no effect
115+-- because !README*.md matches README-secret.md and comes last. Our
116+-- implementation will result in the same thing.
117+dockerIgnoreDecision :: (Bool, Bool) -> Bool
118+dockerIgnoreDecision p = case p of
119+ -- If it's in any of the exclusion patterns but also
120+ -- in any of the inclusion patterns then laeave it
121+ (True, True) -> True
122+ (True, False) -> False
123+ (False, True) -> True
124+ (False, False) -> True
125+
126+exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool
127+exclusionCheck f ps = any id (map (\(ExclusionPattern p) -> f ~~ T.unpack p) ps)
128+
129+inclusionCheck :: FilePath -> [InclusionPattern] -> Bool
130+inclusionCheck f ps = any id (map (\(InclusionPattern p) -> f ~~ T.unpack p) ps)
131+
stack-7.10.yamlnew file+32
@@ -0,0 +1,32 @@
1+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
2+
3+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
4+resolver: lts-5.18
5+
6+# Local packages, usually specified by relative directory name
7+packages:
8+- '.'
9+
10+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11+extra-deps: []
12+
13+# Override default flag values for local packages and extra-deps
14+flags: {}
15+
16+# Extra package databases containing global packages
17+extra-package-dbs: []
18+
19+# Control whether we use the GHC we find on the path
20+# system-ghc: true
21+
22+# Require a specific version of stack, using version ranges
23+# require-stack-version: -any # Default
24+# require-stack-version: >= 0.1.4.0
25+
26+# Override the architecture used by stack, especially useful on Windows
27+# arch: i386
28+# arch: x86_64
29+
30+# Extra directories used by stack for building
31+# extra-include-dirs: [/path/to/dir]
32+# extra-lib-dirs: [/path/to/dir]
stack-8.0.yamlnew file+4
@@ -0,0 +1,4 @@
1+resolver: lts-7.12
2+packages:
3+- '.'
4+extra-deps: []
stack.yaml+1−1
@@ -8,7 +8,7 @@ packages:
88- '.'
99
1010# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11−extra-deps: []
11+extra-deps: [directory-1.2.7.0]
1212
1313# Override default flag values for local packages and extra-deps
1414flags: {}
tests/tests.hs+9−4
@@ -42,7 +42,8 @@ runDocker f = do
4242 -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
4343 -- let settings = mkManagerSettings (TLSSettings params) Nothing
4444 -- mgr <- newManager settings
45− runDockerT (defaultClientOpts, defaultHttpHandler) f
45+ h <- defaultHttpHandler
46+ runDockerT (defaultClientOpts, h) f
4647
4748testDockerVersion :: IO ()
4849testDockerVersion = runDocker $ do
@@ -63,13 +64,17 @@ testRunAndReadLog = runDocker $ do
6364 status1 <- startContainer defaultStartOpts c
6465 _ <- inspectContainer c >>= fromRight
6566 lift $ threadDelay 300000 -- give 300ms for the application to finish
66− lift $ assert $ status1 == Right ()
67+ lift $ assert $ isRightUnit status1
6768 status2 <- killContainer SIGTERM c
6869 logs <- getContainerLogs defaultLogOpts c >>= fromRight
69− lift $ assert $ status2 == Right ()
70+ lift $ assert $ isRightUnit status2
7071 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
7172 status3 <- deleteContainer (DeleteOpts True True) c
72− lift $ assert $ status3 == Right ()
73+ lift $ assert $ isRightUnit status3
74+
75+ where
76+ isRightUnit (Right ()) = True
77+ isRightUnit _ = False
7378
7479testLogDriverOptionsJson :: TestTree
7580testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]