git.iko.soy/docker-hs
on master help sign in
Merge pull request #26 from jprider63/master
6797db9Deni Bertovic
.travis.yml+12−7
compare with master
unifiedsplit
@@ -16,7 +16,8 @@ services:
16 - docker
16 - docker
17
17
18env:
18env:
19+ - GHCVER=7.10 STACK_ARGS=""
19− - STACK_ARGS=""
20+ - GHCVER=8.0 STACK_ARGS=""
20
21
21addons:
22addons:
22 apt:
23 apt:
@@ -24,20 +25,24 @@ addons:
24 - libgmp-dev
25 - libgmp-dev
25
26
26before_install:
27before_install:
27− # Upgrade docker to 1.12
28+ # Upgrade docker to 1.12.3.0
28 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
29 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
29 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
30 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
30 - sudo apt-get update
31 - 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:
32 - mkdir -p "$HOME"/.local/bin
35 - mkdir -p "$HOME"/.local/bin
33 - export PATH=$HOME/.local/bin:$PATH
36 - export PATH=$HOME/.local/bin:$PATH
34−
37+ - export STACK_YAML=stack-$GHCVER.yaml
35 # install Stack
38 # install Stack
36 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C $HOME/.local/bin '*/stack'
39 - 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
40+ - export PATH=$(stack path --local-install-root):$PATH
38− - stack setup
41+ - stack --version
39−
40
42
41script:
43script:
44+ - stack setup
45+ - stack update
46+ - stack build
42 - stack test
47 - stack test
43
48
docker.cabal+17−1
@@ -17,7 +17,7 @@ stability: experimental
17library
17library
18 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances
18 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances
19 hs-source-dirs: src
19 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
21 -- other-modules: Docker.Internal
21 -- other-modules: Docker.Internal
22 build-depends: base >= 4.7 && < 5
22 build-depends: base >= 4.7 && < 5
23 , aeson >= 0.9.0 && < 1.1.0
23 , aeson >= 0.9.0 && < 1.1.0
@@ -27,6 +27,22 @@ library
27 , data-default-class >= 0.0.1 && < 0.2.0
27 , data-default-class >= 0.0.1 && < 0.2.0
28 , http-client >= 0.4.0 && < 0.5.0
28 , http-client >= 0.4.0 && < 0.5.0
29 , http-types >= 0.9 && < 0.10.0
29 , 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
30 , mtl >= 2.0.0 && < 3.0.0
46 , mtl >= 2.0.0 && < 3.0.0
31 , network >= 2.6.0
47 , network >= 2.6.0
32 , text >= 1.0.0 && < 2.0.0
48 , text >= 1.0.0 && < 2.0.0
src/Docker/Client/Api.hs+72−43
@@ -7,6 +7,7 @@ module Docker.Client.Api (
7 , createContainer
7 , createContainer
8 , startContainer
8 , startContainer
9 , stopContainer
9 , stopContainer
10+ , waitContainer
10 , killContainer
11 , killContainer
11 , restartContainer
12 , restartContainer
12 , pauseContainer
13 , pauseContainer
@@ -14,110 +15,131 @@ module Docker.Client.Api (
14 , deleteContainer
15 , deleteContainer
15 , inspectContainer
16 , inspectContainer
16 , getContainerLogs
17 , getContainerLogs
18+ , getContainerLogsStream
17 -- * Images
19 -- * Images
18 , listImages
20 , listImages
21+ , buildImageFromDockerfile
19 -- * Other
22 -- * Other
20 , getDockerVersion
23 , getDockerVersion
21 ) where
24 ) where
22
25
23−import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
26+import Control.Monad.Catch (MonadMask(..))
24−import Control.Monad.Reader (ask, lift)
27+import Control.Monad.IO.Class
28+import Control.Monad.Reader (ask, lift)
25−import Data.Aeson (FromJSON, eitherDecode')
29+import Data.Aeson (FromJSON, eitherDecode')
26−import qualified Data.ByteString.Lazy as BSL
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
27−import qualified Data.Text as Text
34+import qualified Data.Text as Text
28−import Network.HTTP.Client (responseBody, responseStatus)
35+import Network.HTTP.Client (responseStatus)
29import Network.HTTP.Types (StdMethod (..))
36import Network.HTTP.Types (StdMethod (..))
37+import System.Exit (ExitCode(..))
30
38
31import Docker.Client.Http
39import Docker.Client.Http
32import Docker.Client.Types
40import Docker.Client.Types
41+import Docker.Client.Utils
33
42
34−requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
43+requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
35requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
44requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
36
45
37−requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
46+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
38−requestHelper verb endpoint = runExceptT $ do
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
39− (opts, httpHandler) <- lift ask
51+ (opts, HttpHandler httpHandler) <- ask
40 case mkHttpRequest verb endpoint opts of
52 case mkHttpRequest verb endpoint opts of
41 Nothing ->
53 Nothing ->
42− throwError $ DockerInvalidRequest endpoint
54+ return $ Left $ DockerInvalidRequest endpoint
43 Just request -> do
55 Just request -> do
56+ -- JP: Do we need runResourceT?
57+ -- lift $ NHS.httpSink request $ \response ->
44− response <- ExceptT $ lift $ httpHandler request
58+ lift $ httpHandler request $ \response ->
45−
46− -- Check status code.
59+ -- Check status code.
47− let status = responseStatus response
60+ let status = responseStatus response in
48− maybe (return ()) throwError $
49− statusCodeToError endpoint status
61+ case statusCodeToError endpoint status of
50−
62+ Just err ->
51− return response
63+ return $ Left err
52−
64+ Nothing ->
65+ fmap Right sink
66+
53−parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
67+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
54parseResponse (Left err) =
68parseResponse (Left err) =
55 return $ Left err
69 return $ Left err
56parseResponse (Right response) =
70parseResponse (Right response) =
57 -- Parse request body.
71 -- Parse request body.
58− case eitherDecode' $ responseBody response of
72+ case eitherDecode' response of
59 Left err ->
73 Left err ->
60 return $ Left $ DockerClientDecodeError $ Text.pack err
74 return $ Left $ DockerClientDecodeError $ Text.pack err
61 Right r ->
75 Right r ->
62 return $ Right r
76 return $ Right r
63
77
64-- | Gets the version of the docker engine remote API.
78-- | 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)
66getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
80getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
67
81
68-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
82-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
69-- = True}@ to get a list of stopped containers as well.
83-- = 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])
71listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
85listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
72
86
73-- | Lists all docker images.
87-- | 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])
75listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
89listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
76
90
77-- | Creates a docker container but does __not__ start it. See
91-- | Creates a docker container but does __not__ start it. See
78-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
92-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
79-- for some sane defaults.
93-- 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)
81createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
95createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
82
96
83-- | Start a container from a given 'ContainerID' that we get from
97-- | Start a container from a given 'ContainerID' that we get from
84-- 'createContainer'. See 'StartOpts' for a list of configuration options
98-- 'createContainer'. See 'StartOpts' for a list of configuration options
85-- for starting a container. Use 'defaultStartOpts' for sane defaults.
99-- 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 ())
87startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
101startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
88
102
89-- | Attempts to stop a container with the given 'ContainerID' gracefully
103-- | Attempts to stop a container with the given 'ContainerID' gracefully
90-- (SIGTERM).
104-- (SIGTERM).
91-- The docker daemon will wait for the given 'Timeout' and then send
105-- The docker daemon will wait for the given 'Timeout' and then send
92-- a SIGKILL killing the container.
106-- 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 ())
94stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
108stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
95
109
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+
96-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
118-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
97-- as 'stopContainer' but you choose the signal directly.
119-- 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 ())
99killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
121killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
100
122
101-- | Restarts a container with the given 'ContainerID'.
123-- | 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 ())
103restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
125restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
104
126
105-- | Pauses a container with the given 'ContainerID'.
127-- | 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 ())
107pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
129pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
108
130
109-- | Unpauses a container with the given 'ContainerID'.
131-- | 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 ())
111unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
133unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
112
134
113-- | Deletes a container with the given 'ContainerID'.
135-- | Deletes a container with the given 'ContainerID'.
114-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
136-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
115-- defaults.
137-- 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 ())
117deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
139deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
118
140
119-- | Gets 'ContainerDetails' for a given 'ContainerID'.
141-- | 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)
121inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
143inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
122
144
123-- | Get's container's logs for a given 'ContainerID'.
145-- | Get's container's logs for a given 'ContainerID'.
@@ -135,12 +157,19 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars
135--
157--
136-- The recommended method is to use one of the other 'LogDriverType's available (like
158-- The recommended method is to use one of the other 'LogDriverType's available (like
137-- syslog) for creating your containers.
159-- syslog) for creating your containers.
138−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
160+getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
139−getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
161+getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
140−
162+
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)
163+getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
143−-- getContainerLogsStream sink logopts cid = runResourceT $ do
164+getContainerLogsStream logopts cid sink = requestHelper' GET (ContainerLogsEndpoint logopts True cid) sink
144−-- response <- http request manager
165+-- JP: Should the second (follow) argument be True? XXX
145−-- responseBody response C.$$+- sink
166+
146−
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 @@
3
3
4module Docker.Client.Http where
4module Docker.Client.Http where
5
5
6+-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7+import Control.Monad.Catch (MonadMask(..))
6−import Control.Monad.Reader (ReaderT, runReaderT)
8+import Control.Monad.Reader (ReaderT(..), runReaderT)
7import qualified Data.ByteString.Char8 as BSC
9import qualified Data.ByteString.Char8 as BSC
8import qualified Data.ByteString.Lazy as BL
10import qualified Data.ByteString.Lazy as BL
11+import Data.Conduit (Sink)
9import Data.Default.Class (def)
12import Data.Default.Class (def)
10import Data.Monoid ((<>))
13import Data.Monoid ((<>))
11import Data.Text.Encoding (encodeUtf8)
14import Data.Text.Encoding (encodeUtf8)
12import Data.X509 (CertificateChain (..))
15import Data.X509 (CertificateChain (..))
13import Data.X509.CertificateStore (makeCertificateStore)
16import Data.X509.CertificateStore (makeCertificateStore)
14import Data.X509.File (readKeyFile, readSignedObject)
17import Data.X509.File (readKeyFile, readSignedObject)
15−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
18+import Network.HTTP.Client (defaultManagerSettings,
16 managerRawConnection, method,
19 managerRawConnection, method,
17 newManager, parseUrl,
20 newManager, parseUrl,
18 requestBody, requestHeaders)
21 requestBody, requestHeaders)
@@ -20,6 +23,7 @@ import qualified Network.HTTP.Client as HTTP
20import Network.HTTP.Client.Internal (makeConnection)
23import Network.HTTP.Client.Internal (makeConnection)
21import Network.HTTP.Types (StdMethod, status101, status200,
24import Network.HTTP.Types (StdMethod, status101, status200,
22 status201, status204)
25 status201, status204)
26+import qualified Network.HTTP.Simple as NHS
23import Network.TLS (ClientHooks (..),
27import Network.TLS (ClientHooks (..),
24 ClientParams (..), Shared (..),
28 ClientParams (..), Shared (..),
25 Supported (..),
29 Supported (..),
@@ -27,7 +31,7 @@ import Network.TLS (ClientHooks (..),
27import Network.TLS.Extra (ciphersuite_strong)
31import Network.TLS.Extra (ciphersuite_strong)
28import System.X509 (getSystemCertificateStore)
32import System.X509 (getSystemCertificateStore)
29
33
30−import Control.Exception (try)
34+import Control.Monad.Catch (try)
31import Control.Monad.Except
35import Control.Monad.Except
32import Control.Monad.Reader.Class
36import Control.Monad.Reader.Class
33import Data.Text as T
37import Data.Text as T
@@ -38,6 +42,7 @@ import qualified Network.Socket.ByteString as SBS
38
42
39
43
40import Docker.Client.Internal (getEndpoint,
44import Docker.Client.Internal (getEndpoint,
45+ getEndpointContentType,
41 getEndpointRequestBody)
46 getEndpointRequestBody)
42import Docker.Client.Types (DockerClientOpts, Endpoint (..),
47import Docker.Client.Types (DockerClientOpts, Endpoint (..),
43 baseUrl)
48 baseUrl)
@@ -45,13 +50,14 @@ import Docker.Client.Types (DockerClientOpts, Endpoint (..),
45type Request = HTTP.Request
50type Request = HTTP.Request
46type Response = HTTP.Response BL.ByteString
51type Response = HTTP.Response BL.ByteString
47type HttpVerb = StdMethod
52type 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))
49
54
50−data DockerError = DockerConnectionError
55+data DockerError = DockerConnectionError NHS.HttpException
51 | DockerInvalidRequest Endpoint
56 | DockerInvalidRequest Endpoint
57+ | DockerClientError Text
52 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
58 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
53 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
59 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
54− | GenericDockerError Text deriving (Eq, Show, Typeable)
60+ | GenericDockerError Text deriving (Show, Typeable)
55
61
56newtype DockerT m a = DockerT {
62newtype DockerT m a = DockerT {
57 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
63 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
@@ -75,6 +81,9 @@ instance MonadTrans DockerT where
75instance MonadIO m => MonadIO (DockerT m) where
81instance MonadIO m => MonadIO (DockerT m) where
76 liftIO = lift . liftIO
82 liftIO = lift . liftIO
77
83
84+-- instance MonadBase IO m => MonadBase IO (DockerT m) where
85+-- liftBase = liftBaseDefault
86+
78runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
87runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
79runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
88runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
80
89
@@ -89,23 +98,24 @@ mkHttpRequest verb e opts = request
89 request' = case initialR of
98 request' = case initialR of
90 Just ir ->
99 Just ir ->
91 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
100 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
92− requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
101+ requestHeaders = [("Content-Type", (getEndpointContentType e))]}
93 Nothing -> Nothing
102 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
95 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
96 -- Note: Do we need to set length header?
105 -- Note: Do we need to set length header?
97
106
98−defaultHttpHandler :: MonadIO m => HttpHandler m
107+defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
99−defaultHttpHandler request = do
108+defaultHttpHandler = do
100 manager <- liftIO $ newManager defaultManagerSettings
109 manager <- liftIO $ newManager defaultManagerSettings
101− httpHandler manager request
110+ return $ httpHandler manager
102−
111+
103−httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
112+httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
104−httpHandler manager request = liftIO $ do
113+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114+ let request = NHS.setRequestManager manager request'
105− try (httpLbs request manager) >>= \res -> case res of
115+ try (NHS.httpSink request sink) >>= \res -> case res of
106− Right res -> return $ Right res
116+ Right res -> return res
107− Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
117+ Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
108− Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
118+ Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
109 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
110
120
111-- | Connect to a unix domain socket (the default docker socket is
121-- | Connect to a unix domain socket (the default docker socket is
@@ -113,13 +123,13 @@ httpHandler manager request = liftIO $ do
113--
123--
114-- Docker seems to ignore the hostname in requests sent over unix domain
124-- Docker seems to ignore the hostname in requests sent over unix domain
115-- sockets (and the port obviously doesn't matter either)
125-- sockets (and the port obviously doesn't matter either)
116−unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
126+unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
117− -> HttpHandler m
127+ -> m (HttpHandler m)
118−unixHttpHandler fp request = do
128+unixHttpHandler fp = do
119 let mSettings = defaultManagerSettings
129 let mSettings = defaultManagerSettings
120 { managerRawConnection = return $ openUnixSocket fp}
130 { managerRawConnection = return $ openUnixSocket fp}
121 manager <- liftIO $ newManager mSettings
131 manager <- liftIO $ newManager mSettings
122− httpHandler manager request
132+ return $ httpHandler manager
123
133
124 where
134 where
125 openUnixSocket filePath _ _ _ = do
135 openUnixSocket filePath _ _ _ = do
@@ -194,6 +204,11 @@ statusCodeToError (StopContainerEndpoint _ _) st =
194 Nothing
204 Nothing
195 else
205 else
196 Just $ DockerInvalidStatusCode st
206 Just $ DockerInvalidStatusCode st
207+statusCodeToError (WaitContainerEndpoint _) st =
208+ if st == status200 then
209+ Nothing
210+ else
211+ Just $ DockerInvalidStatusCode st
197statusCodeToError (KillContainerEndpoint _ _) st =
212statusCodeToError (KillContainerEndpoint _ _) st =
198 if st == status204 then
213 if st == status204 then
199 Nothing
214 Nothing
@@ -229,5 +244,9 @@ statusCodeToError (InspectContainerEndpoint _) st =
229 Nothing
244 Nothing
230 else
245 else
231 Just $ DockerInvalidStatusCode st
246 Just $ DockerInvalidStatusCode st
232−
247+statusCodeToError (BuildImageEndpoint _ _) st =
248+ if st == status200 then
249+ Nothing
250+ else
251+ Just $ DockerInvalidStatusCode st
233
252
src/Docker/Client/Internal.hs+23−4
@@ -1,12 +1,14 @@
1module Docker.Client.Internal where
1module Docker.Client.Internal where
2
2
3−
4import Blaze.ByteString.Builder (toByteString)
3import Blaze.ByteString.Builder (toByteString)
5import qualified Data.Aeson as JSON
4import qualified Data.Aeson as JSON
6import Data.ByteString (ByteString)
5import 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
8import Data.Text as T
8import Data.Text as T
9import Data.Text.Encoding (decodeUtf8, encodeUtf8)
9import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10+import qualified Network.HTTP.Client as HTTP
11+import Network.HTTP.Conduit (requestBodySourceChunked)
10import Network.HTTP.Types (Query, encodePath,
12import Network.HTTP.Types (Query, encodePath,
11 encodePathSegments)
13 encodePathSegments)
12
14
@@ -39,6 +41,7 @@ getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fr
39 where query = case t of
41 where query = case t of
40 Timeout x -> [("t", Just (encodeQ $ show x))]
42 Timeout x -> [("t", Just (encodeQ $ show x))]
41 DefaultTimeout -> []
43 DefaultTimeout -> []
44+getEndpoint (WaitContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "wait"]
42getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
45getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
43 where query = case s of
46 where query = case s of
44 SIG x -> [("signal", Just (encodeQ $ show x))]
47 SIG x -> [("signal", Just (encodeQ $ show x))]
@@ -58,14 +61,24 @@ getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
58 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
61 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
59getEndpoint (InspectContainerEndpoint cid) =
62getEndpoint (InspectContainerEndpoint cid) =
60 encodeURLWithQuery ["containers", fromContainerID cid, "json"] []
63 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
61
73
62−getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString
74+getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
63getEndpointRequestBody VersionEndpoint = Nothing
75getEndpointRequestBody VersionEndpoint = Nothing
64getEndpointRequestBody (ListContainersEndpoint _) = Nothing
76getEndpointRequestBody (ListContainersEndpoint _) = Nothing
65getEndpointRequestBody (ListImagesEndpoint _) = Nothing
77getEndpointRequestBody (ListImagesEndpoint _) = Nothing
66−getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts
78+getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
67getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
79getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
68getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
80getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
81+getEndpointRequestBody (WaitContainerEndpoint _) = Nothing
69getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
82getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
70getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
83getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
71getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
84getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
@@ -73,3 +86,9 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing
73getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
86getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
74getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
87getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
75getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
88getEndpointRequestBody (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 (
12 , fromImageID
12 , fromImageID
13 , toImageID
13 , toImageID
14 , Timeout(..)
14 , Timeout(..)
15+ , StatusCode(..)
15 , Signal(..)
16 , Signal(..)
16 , ContainerDetails(..)
17 , ContainerDetails(..)
17 , DockerClientOpts(..)
18 , DockerClientOpts(..)
@@ -29,6 +30,8 @@ module Docker.Client.Types (
29 , Image(..)
30 , Image(..)
30 , dropImagePrefix
31 , dropImagePrefix
31 , CreateOpts(..)
32 , CreateOpts(..)
33+ , BuildOpts(..)
34+ , defaultBuildOpts
32 , defaultCreateOpts
35 , defaultCreateOpts
33 , DetachKeys(..)
36 , DetachKeys(..)
34 , StartOpts(..)
37 , StartOpts(..)
@@ -83,6 +86,8 @@ module Docker.Client.Types (
83 , addLink
86 , addLink
84 , addVolume
87 , addVolume
85 , addVolumeFrom
88 , addVolumeFrom
89+ , MemoryConstraint(..)
90+ , MemoryConstraintSize(..)
86 ) where
91 ) where
87
92
88import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
93import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
@@ -109,6 +114,7 @@ data Endpoint =
109 | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
114 | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
110 | StartContainerEndpoint StartOpts ContainerID
115 | StartContainerEndpoint StartOpts ContainerID
111 | StopContainerEndpoint Timeout ContainerID
116 | StopContainerEndpoint Timeout ContainerID
117+ | WaitContainerEndpoint ContainerID
112 | KillContainerEndpoint Signal ContainerID
118 | KillContainerEndpoint Signal ContainerID
113 | RestartContainerEndpoint Timeout ContainerID
119 | RestartContainerEndpoint Timeout ContainerID
114 | PauseContainerEndpoint ContainerID
120 | PauseContainerEndpoint ContainerID
@@ -117,6 +123,7 @@ data Endpoint =
117 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
123 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
118 | DeleteContainerEndpoint DeleteOpts ContainerID
124 | DeleteContainerEndpoint DeleteOpts ContainerID
119 | InspectContainerEndpoint ContainerID
125 | InspectContainerEndpoint ContainerID
126+ | BuildImageEndpoint BuildOpts FilePath
120 deriving (Eq, Show)
127 deriving (Eq, Show)
121
128
122-- | We should newtype this
129-- | We should newtype this
@@ -163,6 +170,20 @@ toImageID t =
163-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
170-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
164data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
171data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
165
172
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+
166-- TODO: Add more Signals or use an existing lib
187-- TODO: Add more Signals or use an existing lib
167-- | Signal used for sending to the process running in the container.
188-- | Signal used for sending to the process running in the container.
168-- The default signal is SIGTERM.
189-- The default signal is SIGTERM.
@@ -700,6 +721,28 @@ data DeleteOpts = DeleteOpts {
700 , force :: Bool -- ^ If the container is still running force deletion anyway.
721 , force :: Bool -- ^ If the container is still running force deletion anyway.
701 } deriving (Eq, Show)
722 } deriving (Eq, Show)
702
723
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+
703-- | Default options for deleting a container. Most of the time we DON'T
746-- | Default options for deleting a container. Most of the time we DON'T
704-- want to delete the container's volumes or force delete it if it's
747-- want to delete the container's volumes or force delete it if it's
705-- running.
748-- 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:
8- '.'
8- '.'
9
9
10# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
10# 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]
12
12
13# Override default flag values for local packages and extra-deps
13# Override default flag values for local packages and extra-deps
14flags: {}
14flags: {}
tests/tests.hs+9−4
@@ -42,7 +42,8 @@ runDocker f = do
42 -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
42 -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
43 -- let settings = mkManagerSettings (TLSSettings params) Nothing
43 -- let settings = mkManagerSettings (TLSSettings params) Nothing
44 -- mgr <- newManager settings
44 -- mgr <- newManager settings
45+ h <- defaultHttpHandler
45− runDockerT (defaultClientOpts, defaultHttpHandler) f
46+ runDockerT (defaultClientOpts, h) f
46
47
47testDockerVersion :: IO ()
48testDockerVersion :: IO ()
48testDockerVersion = runDocker $ do
49testDockerVersion = runDocker $ do
@@ -63,13 +64,17 @@ testRunAndReadLog = runDocker $ do
63 status1 <- startContainer defaultStartOpts c
64 status1 <- startContainer defaultStartOpts c
64 _ <- inspectContainer c >>= fromRight
65 _ <- inspectContainer c >>= fromRight
65 lift $ threadDelay 300000 -- give 300ms for the application to finish
66 lift $ threadDelay 300000 -- give 300ms for the application to finish
66− lift $ assert $ status1 == Right ()
67+ lift $ assert $ isRightUnit status1
67 status2 <- killContainer SIGTERM c
68 status2 <- killContainer SIGTERM c
68 logs <- getContainerLogs defaultLogOpts c >>= fromRight
69 logs <- getContainerLogs defaultLogOpts c >>= fromRight
69− lift $ assert $ status2 == Right ()
70+ lift $ assert $ isRightUnit status2
70 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
71 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
71 status3 <- deleteContainer (DeleteOpts True True) c
72 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
73
78
74testLogDriverOptionsJson :: TestTree
79testLogDriverOptionsJson :: TestTree
75testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]
80testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]