git.iko.soy/docker-hs
on master help sign in
Squash commits into one.
79d00d9James Parker
docker.cabal+25−9
compare with master
unifiedsplit
@@ -15,35 +15,51 @@ cabal-version: >=1.10
15stability: experimental
15stability: experimental
16
16
17library
17library
18− default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor
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, Docker.Types, Docker.Internal, Docker.Http
20 exposed-modules: Docker, Docker.Types, Docker.Internal, Docker.Http
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− , lifted-base
24− , lens
25 , aeson
23 , aeson
26− , lens-aeson
24+ , blaze-builder
27 , bytestring
25 , bytestring
26+ , containers
27+ , connection
28+ , data-default-class
28 , exceptions
29 , exceptions
29− , text
30 , http-client
30 , http-client
31 , http-types
31 , http-types
32− , blaze-builder
32+ , lens
33− , containers
33+ , lens-aeson
34+ , lifted-base
35+ , mtl
34 , network >= 2.6
36 , network >= 2.6
35 , network-uri
37 , network-uri
36− , mtl
38+ , text
39+ , time
40+ , tls >= 1.3.7
37 , transformers
41 , transformers
42+ , unordered-containers
43+ , x509
44+ , x509-store
45+ , x509-system
38 default-language: Haskell2010
46 default-language: Haskell2010
47+ ghc-options: -Wall -fno-warn-name-shadowing
39
48
40test-suite docker-hs-tests
49test-suite docker-hs-tests
41 build-depends: base >= 4.7 && < 5
50 build-depends: base >= 4.7 && < 5
51+ , bytestring
52+ , connection
42 , docker
53 , docker
54+ , http-client
55+ , http-client-tls
56+ , http-types
43 , tasty
57 , tasty
58+ , tasty-hunit
44 , tasty-quickcheck
59 , tasty-quickcheck
60+ , text
61+ , transformers
45 , QuickCheck
62 , QuickCheck
46− , tasty-hunit
47 , process
63 , process
48 type: exitcode-stdio-1.0
64 type: exitcode-stdio-1.0
49 main-is: tests.hs
65 main-is: tests.hs
src/Docker.hs+108−88
@@ -1,98 +1,118 @@
1{-# LANGUAGE ExplicitForAll #-}
1{-# LANGUAGE ExplicitForAll #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3
3
4−module Docker where
4+module Docker (
5+ runDockerT
6+ , DockerT
7+ , DockerError(..)
8+ , DockerClientOpts(..)
9+ , defaultClientOpts
10+ , HttpHandler
11+ , defaultHttpHandler
12+ , httpHandler
13+ , unixHttpHandler
14+ , clientParamsWithClientAuthentication
15+ , clientParamsSetCA
16+ , getDockerVersion
17+ , listContainers
18+ , listImages
19+ , createContainer
20+ , startContainer
21+ , stopContainer
22+ , killContainer
23+ , restartContainer
24+ , pauseContainer
25+ , unpauseContainer
26+ , deleteContainer
27+ , inspectContainer
28+ , getContainerLogs
29+ ) where
5
30
31+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
6import Control.Monad.Reader (ask, lift)
32import Control.Monad.Reader (ask, lift)
7−import Data.Aeson (decode)
33+import Data.Aeson (FromJSON, eitherDecode')
8−import Data.Maybe (fromJust)
34+import qualified Data.ByteString.Lazy as BSL
35+import qualified Data.Text as Text
9−import Network.HTTP.Client (responseBody)
36+import Network.HTTP.Client (responseBody, responseStatus)
10import Network.HTTP.Types (StdMethod (..))
37import Network.HTTP.Types (StdMethod (..))
11
38
12import Docker.Http
39import Docker.Http
13−import Docker.Internal
14import Docker.Types
40import Docker.Types
15
41
42+requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
43+requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
44+
45+requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
46+requestHelper verb endpoint = runExceptT $ do
47+ (opts, httpHandler) <- lift ask
48+ case mkHttpRequest verb endpoint opts of
49+ Nothing ->
50+ throwError $ DockerInvalidRequest endpoint
51+ Just request -> do
52+ response <- ExceptT $ lift $ httpHandler request
53+
54+ -- Check status code.
55+ let status = responseStatus response
56+ maybe (return ()) throwError $
57+ statusCodeToError endpoint status
58+
59+ return response
60+
61+parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
62+parseResponse (Left err) =
63+ return $ Left err
64+parseResponse (Right response) =
65+ -- Parse request body.
66+ case eitherDecode' $ responseBody response of
67+ Left err ->
68+ return $ Left $ DockerClientDecodeError $ Text.pack err
69+ Right r ->
70+ return $ Right r
71+
16−getDockerVersion :: forall m. Monad m => DockerT m DockerVersion
72+getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)
17−getDockerVersion = do
73+getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
18− (opts, httpHandler) <- ask
74+
19− let request = fromJust $ mkHttpRequest GET VersionEndpoint opts
20− response <- lift $ httpHandler request
21− -- let res = decode $ responseBody response
22− -- return $ fromJust res
23− case response of
24− Right r -> do
25− let res = decode $ responseBody r
26− fromJust res
27− Left err -> err
28−
29−listContainers :: forall m. Monad m => ListOpts -> DockerT m [Container]
75+listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])
30−listContainers lopts = do
31− (opts, httpHandler) <- ask
32− let request = fromJust $ mkHttpRequest GET (ListContainersEndpoint lopts) opts
76+listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
33− response <- lift . lift $ (httpHandler request :: m Response)
77+
34− let res = decode $ responseBody response
35− return $ fromJust res
36−
37−listImages :: forall m. Monad m => ListOpts -> DockerT m [Image]
78+listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])
38−listImages lopts = do
79+listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
39− (opts, httpHandler) <- ask
80+
40− let request = fromJust $ mkHttpRequest GET (ListImagesEndpoint lopts) opts
41− response <- lift . lift $ (httpHandler request :: m Response)
42− let res = decode $ responseBody response
43− return $ fromJust res
44−
45−createContainer :: forall m. Monad m => CreateOpts -> DockerT m ContainerID
81+createContainer :: forall m. Monad m => CreateOpts -> DockerT m (Either DockerError ContainerID)
46−createContainer = undefined
82+createContainer opts = requestHelper POST (CreateContainerEndpoint opts) >>= parseResponse
47−
83+
84+-- TODO: Is this the correct return type? XXX
85+-- convert status code to unit or error
48−startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m ContainerID
86+startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
49−startContainer sopts cid = do
87+startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
50− (opts, httpHandler) <- ask
88+
51− let request = fromJust $ mkHttpRequest POST (StartContainerEndpoint sopts cid) opts
52− _ <- lift . lift $ (httpHandler request :: m Response)
53− return cid
54−
55−stopContainer :: forall m. Monad m => Timeout -> ContainerID ->DockerT m ContainerID
89+stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
56−stopContainer t cid = do
90+stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
57− (opts, httpHandler) <- ask
91+
58− let request = fromJust $ mkHttpRequest POST (StopContainerEndpoint t cid) opts
59− _ <- lift . lift $ (httpHandler request :: m Response)
60− return cid
61−
62−killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m ContainerID
92+killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())
63−killContainer s cid = do
93+killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
64− (opts, httpHandler) <- ask
94+
65− let request = fromJust $ mkHttpRequest POST (KillContainerEndpoint s cid) opts
66− _ <- lift . lift $ (httpHandler request :: m Response)
67− return cid
68−
69−restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m ContainerID
95+restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
70−restartContainer t cid = do
96+restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
71− (opts, httpHandler) <- ask
97+
72− let request = fromJust $ mkHttpRequest POST (RestartContainerEndpoint t cid) opts
73− _ <- lift . lift $ (httpHandler request :: m Response)
74− return cid
75−
76−pauseContainer :: forall m. Monad m => ContainerID -> DockerT m ContainerID
98+pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
77−pauseContainer cid = do
78− (opts, httpHandler) <- ask
79− let request = fromJust $ mkHttpRequest POST (PauseContainerEndpoint cid) opts
99+pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
80− _ <- lift . lift $ (httpHandler request :: m Response)
100+
81− return cid
82−
83−unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m ContainerID
101+unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
84−unpauseContainer cid = do
102+unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
85− (opts, httpHandler) <- ask
103+
86− let request = fromJust $ mkHttpRequest GET (UnpauseContainerEndpoint cid) opts
87− _ <- lift . lift $ (httpHandler request :: m Response)
88− return cid
89−
90−deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m ContainerID
104+deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
91−deleteContainer dopts cid = do
92− (opts, httpHandler) <- ask
93− let request = fromJust $ mkHttpRequest DELETE (DeleteContainerEndpoint dopts cid) opts
105+deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
94− _ <- lift . lift $ (httpHandler request :: m Response)
106+
95− return cid
107+inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)
96−
108+inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
109+
97−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m ()
110+getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
98−getContainerLogs logopts cid = undefined
111+getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
112+
113+-- TODO: Use http-conduit to output to a sink.
114+-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
115+-- getContainerLogsStream sink logopts cid = runResourceT $ do
116+-- response <- http request manager
117+-- responseBody response C.$$+- sink
118+
src/Docker/Http.hs+163−41
@@ -3,29 +3,42 @@
3
3
4module Docker.Http where
4module Docker.Http where
5
5
6−import Control.Applicative
6+import Control.Monad.Reader (ReaderT, runReaderT)
7−import Control.Exception (catch, try)
7+import qualified Data.ByteString.Char8 as BSC
8−import Control.Monad.Except
9−import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader
11−import Control.Monad.Reader.Class
12−import Control.Monad.Trans.Except
13import qualified Data.ByteString.Lazy as BL
8import qualified Data.ByteString.Lazy as BL
14−import Data.Text as T
9+import Data.Default.Class (def)
10+import Data.Monoid ((<>))
15import Data.Text.Encoding (encodeUtf8)
11import Data.Text.Encoding (encodeUtf8)
16−import Data.Typeable (Typeable)
12+import Data.X509 (CertificateChain (..))
13+import Data.X509.CertificateStore (makeCertificateStore)
14+import Data.X509.File (readKeyFile, readSignedObject)
17import Network.HTTP.Client (defaultManagerSettings, httpLbs,
15import Network.HTTP.Client (defaultManagerSettings, httpLbs,
18 managerRawConnection, method,
16 managerRawConnection, method,
19− newManager, parseUrl)
17+ newManager, parseUrl,
18+ requestBody, requestHeaders)
20import qualified Network.HTTP.Client as HTTP
19import qualified Network.HTTP.Client as HTTP
21import Network.HTTP.Client.Internal (makeConnection)
20import Network.HTTP.Client.Internal (makeConnection)
22−import Network.HTTP.Types (StdMethod)
21+import Network.HTTP.Types (StdMethod, status101, status200,
22+ status201, status204)
23+import Network.TLS (ClientHooks (..),
24+ ClientParams (..), Shared (..),
25+ Supported (..),
26+ defaultParamsClient)
27+import Network.TLS.Extra (ciphersuite_strong)
28+import System.X509 (getSystemCertificateStore)
29+
30+import Control.Exception (try)
31+import Control.Monad.Except
32+import Control.Monad.Reader.Class
33+import Data.Text as T
34+import Data.Typeable (Typeable)
35+import qualified Network.HTTP.Types as HTTP
23import qualified Network.Socket as S
36import qualified Network.Socket as S
24import qualified Network.Socket.ByteString as SBS
37import qualified Network.Socket.ByteString as SBS
25−import System.IO.Error (catchIOError, ioError)
26
38
27−import Docker.Internal (getEndpoint)
39+import Docker.Internal (getEndpoint,
40+ getEndpointRequestBody)
28−import Docker.Types (DockerClientOpts, Endpoint,
41+import Docker.Types (DockerClientOpts, Endpoint (..),
29 baseUrl)
42 baseUrl)
30
43
31type Request = HTTP.Request
44type Request = HTTP.Request
@@ -34,21 +47,33 @@ type HttpVerb = StdMethod
34type HttpHandler m = Request -> m (Either DockerError Response)
47type HttpHandler m = Request -> m (Either DockerError Response)
35
48
36data DockerError = DockerConnectionError
49data DockerError = DockerConnectionError
50+ | DockerInvalidRequest Endpoint
51+ | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
52+ | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
37 | GenericDockerError Text deriving (Eq, Show, Typeable)
53 | GenericDockerError Text deriving (Eq, Show, Typeable)
38
54
39newtype DockerT m a = DockerT {
55newtype DockerT m a = DockerT {
40 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
56 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
41 } deriving (Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans
57 } deriving (Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans
42
58
59+instance Applicative m => Applicative (DockerT m) where
60+ pure a = DockerT $ pure a
61+ (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v
43
62
44−-- instance Applicative m => Applicative (DockerT m) where
63+instance Monad m => Monad (DockerT m) where
45−-- pure a = DockerT $ pure a
64+ (DockerT m) >>= f = DockerT $ m >>= unDockerT . f
46−-- (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v
65+ return = pure
47
66
67+instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where
68+ ask = DockerT ask
69+ local f (DockerT m) = DockerT $ local f m
48
70
49−-- type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT DockerError m) a
71+instance MonadTrans DockerT where
72+ lift m = DockerT $ lift m
73+
74+instance MonadIO m => MonadIO (DockerT m) where
75+ liftIO = lift . liftIO
50
76
51−-- runDockerT :: forall m a. Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either DockerError a)
52runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
77runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
53runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
78runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
54
79
@@ -60,22 +85,22 @@ mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
60mkHttpRequest verb e opts = request
85mkHttpRequest verb e opts = request
61 where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
86 where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
62 initialR = parseUrl fullE
87 initialR = parseUrl fullE
63− request = case initialR of
88+ request' = case initialR of
89+ Just ir ->
64− Just ir -> return $ ir { method = (encodeUtf8 . T.pack $ show verb) } -- , requestBody = RequestBodyLBS $ encode requestObject }
90+ return $ ir {method = (encodeUtf8 . T.pack $ show verb),
91+ requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
65 Nothing -> Nothing
92 Nothing -> Nothing
66− -- TODO: manager = newManager defaultManagerSettings -- We likely need
93+ request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,
67− -- this for TLS.
94+ requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
68−
95+ -- Note: Do we need to set length header?
69−-- mapHttpToDocker :: HTTP.HttpException -> DockerError
70−-- mapHttpToDocker e = case e of
71−-- HTTP.FailedConnectionException{} -> DockerConnectionError
72−-- HTTP.FailedConnectionException2{} -> DockerConnectionError
73−-- otherwise -> GenericDockerError "dinamo"
74
96
75−defaultHttpHandler :: HttpHandler IO
97+defaultHttpHandler :: MonadIO m => HttpHandler m
76defaultHttpHandler request = do
98defaultHttpHandler request = do
77− manager <- newManager defaultManagerSettings
99+ manager <- liftIO $ newManager defaultManagerSettings
78− -- either mapHttpToDocker id <$> try httpLbs request manager
100+ httpHandler manager request
101+
102+httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
103+httpHandler manager request = liftIO $ do
79 try (httpLbs request manager) >>= \res -> case res of
104 try (httpLbs request manager) >>= \res -> case res of
80 Right res -> return $ Right res
105 Right res -> return $ Right res
81 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
106 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
@@ -87,17 +112,13 @@ defaultHttpHandler request = do
87--
112--
88-- Docker seems to ignore the hostname in requests sent over unix domain
113-- Docker seems to ignore the hostname in requests sent over unix domain
89-- sockets (and the port obviously doesn't matter either)
114-- sockets (and the port obviously doesn't matter either)
90−unixHttpHandler :: FilePath -- ^ The socket to connect to
115+unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
91− -> HttpHandler IO
116+ -> HttpHandler m
92−unixHttpHandler fp request= do
117+unixHttpHandler fp request = do
93 let mSettings = defaultManagerSettings
118 let mSettings = defaultManagerSettings
94 { managerRawConnection = return $ openUnixSocket fp}
119 { managerRawConnection = return $ openUnixSocket fp}
95− manager <- newManager mSettings
120+ manager <- liftIO $ newManager mSettings
96− try (httpLbs request manager) >>= \res -> case res of
121+ httpHandler manager request
97− Right res -> return $ Right res
98− Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
99− Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
100− Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
101
122
102 where
123 where
103 openUnixSocket filePath _ _ _ = do
124 openUnixSocket filePath _ _ _ = do
@@ -107,4 +128,105 @@ unixHttpHandler fp request= do
107 (SBS.sendAll s)
128 (SBS.sendAll s)
108 (S.sClose s)
129 (S.sClose s)
109
130
131+-- TODO:
132+-- Move this to http-client-tls or network?
133+-- Add CA.
134+-- Maybe change this to: HostName -> PortNumber -> ClientParams -> IO (Either String TLSSettings)
135+clientParamsWithClientAuthentication :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO (Either String ClientParams)
136+clientParamsWithClientAuthentication host port keyFile certificateFile = do
137+ keys <- readKeyFile keyFile
138+ cert <- readSignedObject certificateFile
139+ case keys of
140+ [key] ->
141+ -- TODO: load keys/path from file
142+ let params = (defaultParamsClient host $ BSC.pack $ show port) {
143+ clientHooks = def
144+ { onCertificateRequest = \_ -> return (Just (CertificateChain cert, key))}
145+ , clientSupported = def
146+ { supportedCiphers = ciphersuite_strong}
147+ }
148+ in
149+ return $ Right params
150+ _ ->
151+ return $ Left $ "Could not read key file: " ++ keyFile
152+
153+clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams
154+clientParamsSetCA params path = do
155+ userStore <- makeCertificateStore <$> readSignedObject path
156+ systemStore <- getSystemCertificateStore
157+ let store = userStore <> systemStore
158+ let oldShared = clientShared params
159+ return $ params { clientShared = oldShared
160+ { sharedCAStore = store }
161+ }
162+
163+
164+-- If the status is an error, returns a Just DockerError. Otherwise, returns Nothing.
165+statusCodeToError :: Endpoint -> HTTP.Status -> Maybe DockerError
166+statusCodeToError VersionEndpoint st =
167+ if st == status200 then
168+ Nothing
169+ else
170+ Just $ DockerInvalidStatusCode st
171+statusCodeToError (ListContainersEndpoint _) st =
172+ if st == status200 then
173+ Nothing
174+ else
175+ Just $ DockerInvalidStatusCode st
176+statusCodeToError (ListImagesEndpoint _) st =
177+ if st == status200 then
178+ Nothing
179+ else
180+ Just $ DockerInvalidStatusCode st
181+statusCodeToError (CreateContainerEndpoint _) st =
182+ if st == status201 then
183+ Nothing
184+ else
185+ Just $ DockerInvalidStatusCode st
186+statusCodeToError (StartContainerEndpoint _ _) st =
187+ if st == status204 then
188+ Nothing
189+ else
190+ Just $ DockerInvalidStatusCode st
191+statusCodeToError (StopContainerEndpoint _ _) st =
192+ if st == status204 then
193+ Nothing
194+ else
195+ Just $ DockerInvalidStatusCode st
196+statusCodeToError (KillContainerEndpoint _ _) st =
197+ if st == status204 then
198+ Nothing
199+ else
200+ Just $ DockerInvalidStatusCode st
201+statusCodeToError (RestartContainerEndpoint _ _) st =
202+ if st == status204 then
203+ Nothing
204+ else
205+ Just $ DockerInvalidStatusCode st
206+statusCodeToError (PauseContainerEndpoint _) st =
207+ if st == status204 then
208+ Nothing
209+ else
210+ Just $ DockerInvalidStatusCode st
211+statusCodeToError (UnpauseContainerEndpoint _) st =
212+ if st == status204 then
213+ Nothing
214+ else
215+ Just $ DockerInvalidStatusCode st
216+statusCodeToError (ContainerLogsEndpoint _ _ _) st =
217+ if st == status200 || st == status101 then
218+ Nothing
219+ else
220+ Just $ DockerInvalidStatusCode st
221+statusCodeToError (DeleteContainerEndpoint _ _) st =
222+ if st == status204 then
223+ Nothing
224+ else
225+ Just $ DockerInvalidStatusCode st
226+statusCodeToError (InspectContainerEndpoint _) st =
227+ if st == status200 then
228+ Nothing
229+ else
230+ Just $ DockerInvalidStatusCode st
231+
110
232
src/Docker/Internal.hs+42−27
@@ -1,56 +1,71 @@
1module Docker.Internal where
1module Docker.Internal where
2
2
3
3
4−import Blaze.ByteString.Builder (toByteString)
4+import Blaze.ByteString.Builder (toByteString)
5+import qualified Data.Aeson as JSON
5−import Data.ByteString (ByteString)
6+import Data.ByteString (ByteString)
6−import Data.Maybe
7+import qualified Data.ByteString.Lazy as BSL
7−import Data.Text as T
8+import Data.Text as T
8−import Data.Text (Text)
9−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
9+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10import Docker.Types
10import Docker.Types
11−import Network.HTTP.Client.Internal (makeConnection)
12−import Network.HTTP.Types (Query, encodePath,
11+import Network.HTTP.Types (Query, encodePath,
13− encodePathSegments)
12+ encodePathSegments)
14−import qualified Network.Socket as S
15−import qualified Network.Socket.ByteString as SBS
16
13
17−encodeURL :: [Text] -> Text
14+encodeURL :: [T.Text] -> T.Text
18encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
15encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
19
16
20−encodeURLWithQuery :: [Text] -> Query -> Text
17+encodeURLWithQuery :: [T.Text] -> Query -> T.Text
21encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
18encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
22
19
23encodeQ :: String -> ByteString
20encodeQ :: String -> ByteString
24encodeQ = encodeUtf8 . T.pack
21encodeQ = encodeUtf8 . T.pack
25
22
26−getEndpoint :: Endpoint -> Text
23+getEndpoint :: Endpoint -> T.Text
27getEndpoint VersionEndpoint = encodeURL ["version"]
24getEndpoint VersionEndpoint = encodeURL ["version"]
28−getEndpoint (ListContainersEndpoint lsOpts) = encodeURL ["containers", "json"]
25+getEndpoint (ListContainersEndpoint _) = encodeURL ["containers", "json"] -- Make use of lsOpts here
29−getEndpoint (ListImagesEndpoint lsOpts) = encodeURL ["images", "json"]
26+getEndpoint (ListImagesEndpoint _) = encodeURL ["images", "json"] -- Make use of lsOpts here
30−getEndpoint CreateContainerEndpoint = encodeURL ["containers", "create"]
27+getEndpoint (CreateContainerEndpoint _) = encodeURL ["containers", "create"]
31−getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", cid, "start"] query
28+getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", fromContainerID cid, "start"] query
32 where query = case (detachKeys startOpts) of
29 where query = case (detachKeys startOpts) of
33 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
30 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
34 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
31 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
35 DefaultDetachKey -> []
32 DefaultDetachKey -> []
36 ctrl = ['c', 't', 'r', 'l', '-']
33 ctrl = ['c', 't', 'r', 'l', '-']
37−getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", cid, "stop"] query
34+getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "stop"] query
38 where query = case t of
35 where query = case t of
39 Timeout x -> [("t", Just (encodeQ $ show x))]
36 Timeout x -> [("t", Just (encodeQ $ show x))]
40 DefaultTimeout -> []
37 DefaultTimeout -> []
41−getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", cid, "kill"] query
38+getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
42 where query = case s of
39 where query = case s of
43 SIG x -> [("signal", Just (encodeQ $ show x))]
40 SIG x -> [("signal", Just (encodeQ $ show x))]
44− otherwise -> [("signal", Just (encodeQ $ show s))]
41+ _ -> [("signal", Just (encodeQ $ show s))]
45−getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", cid, "restart"] query
42+getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "restart"] query
46 where query = case t of
43 where query = case t of
47 Timeout x -> [("t", Just (encodeQ $ show x))]
44 Timeout x -> [("t", Just (encodeQ $ show x))]
48 DefaultTimeout -> []
45 DefaultTimeout -> []
49−getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", cid, "pause"]
46+getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"]
50−getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", cid, "unpause"]
47+getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"]
48+-- Make use of since/timestamps/tail logopts here instead of ignoreing them
51−getEndpoint (ContainerLogsEndpoint (LogOpts follow stdout stderr since timestamps tail) cid) =
49+getEndpoint (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
52− encodeURLWithQuery ["containers", cid, "logs"] query
50+ encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query
53 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
51 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
54getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
52getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
55− encodeURLWithQuery ["containers", cid] query
53+ encodeURLWithQuery ["containers", fromContainerID cid] query
56 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
54 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
55+getEndpoint (InspectContainerEndpoint cid) =
56+ encodeURLWithQuery ["containers", fromContainerID cid, "json"] []
57+
58+getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString
59+getEndpointRequestBody VersionEndpoint = Nothing
60+getEndpointRequestBody (ListContainersEndpoint _) = Nothing
61+getEndpointRequestBody (ListImagesEndpoint _) = Nothing
62+getEndpointRequestBody (CreateContainerEndpoint opts) = Just $ JSON.encode opts
63+getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
64+getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
65+getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
66+getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
67+getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
68+getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing
69+getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
70+getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
71+getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
src/Docker/Types.hs+835−152
@@ -1,35 +1,137 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
1−module Docker.Types where
4+module Docker.Types (
2−
5+ Endpoint(..)
6+ , URL
7+ , ApiVersion
8+ , ContainerID
9+ , fromContainerID
10+ , toContainerID
11+ , ImageID
12+ , fromImageID
13+ , toImageID
14+ , Timeout(..)
15+ , Signal(..)
16+ , ContainerDetails(..)
17+ , DockerClientOpts(..)
18+ , defaultClientOpts
19+ , ListOpts(..)
20+ , defaultListOpts
21+ , DockerVersion(..)
22+ , ContainerPortInfo(..)
23+ , Container(..)
24+ , ContainerState(..)
25+ , Status(..)
26+ , Digest
27+ , Labels(..)
28+ , Tag
29+ , Image(..)
30+ , dropImagePrefix
31+ , CreateOpts(..)
32+ , cResources
33+ , hConfig
34+ , defaultCreateOpts
35+ , DetachKeys(..)
36+ , StartOpts(..)
37+ , defaultStartOpts
38+ , DeleteOpts(..)
39+ , Timestamp
40+ , TailLogOpt(..)
41+ , LogOpts(..)
42+ , defaultLogOpts
43+ , VolumePermission(..)
44+ , Volume(..)
45+ , Device(..)
46+ , ContainerName
47+ , VolumeFrom(..)
48+ , Link(..)
49+ , LogDriverType(..)
50+ , LogDriverOptions(..)
51+ , LogDriverConfig(..)
52+ , NetworkMode(..)
53+ , PortType(..)
54+ , NetworkInterface(..)
55+ , Networks(..)
56+ , NetworkSettings(..)
57+ , NetworkOptions(..)
58+ , Mount(..)
59+ , PortBinding(..)
60+ , PortBindings(..)
61+ , HostPort(..)
62+ , RetryCount
63+ , RestartPolicy(..)
64+ , Isolation(..)
65+ , UTSMode(..)
66+ , HostConfig(..)
67+ , Ulimit(..)
68+ , ContainerResources(..)
69+ , Port
70+ , Name
71+ , Value
72+ , EnvVar(..)
73+ , ContainerConfig(..)
74+ ) where
75+
3−import Data.Aeson (FromJSON, ToJSON, decode, encode,
76+import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
4− genericParseJSON, genericToJSON, object,
5− parseJSON, toJSON, (.:), (.:?), (.=))
77+ genericToJSON, object, parseJSON, toJSON,
78+ (.!=), (.:), (.:?), (.=))
6−import qualified Data.Aeson as JSON
79+import qualified Data.Aeson as JSON
7−import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
80+import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
8−import Data.Char (toUpper)
81+import Data.Char (isAlphaNum, toUpper)
9−import qualified Data.Map as M
82+import qualified Data.HashMap.Strict as HM
83+import qualified Data.Map as M
10−import Data.Text (Text)
84+import Data.Monoid ((<>))
85+import Data.Text (Text)
11−import qualified Data.Text as T
86+import qualified Data.Text as T
87+import Data.Time.Clock (UTCTime)
12−import GHC.Generics (Generic)
88+import GHC.Generics (Generic)
13−import Prelude hiding (all, tail)
89+import Prelude hiding (all, tail)
90+import Text.Read (readMaybe)
14
91
15data Endpoint =
92data Endpoint =
16 VersionEndpoint
93 VersionEndpoint
17 | ListContainersEndpoint ListOpts
94 | ListContainersEndpoint ListOpts
18 | ListImagesEndpoint ListOpts
95 | ListImagesEndpoint ListOpts
19− | CreateContainerEndpoint
96+ | CreateContainerEndpoint CreateOpts
20 | StartContainerEndpoint StartOpts ContainerID
97 | StartContainerEndpoint StartOpts ContainerID
21 | StopContainerEndpoint Timeout ContainerID
98 | StopContainerEndpoint Timeout ContainerID
22 | KillContainerEndpoint Signal ContainerID
99 | KillContainerEndpoint Signal ContainerID
23 | RestartContainerEndpoint Timeout ContainerID
100 | RestartContainerEndpoint Timeout ContainerID
24 | PauseContainerEndpoint ContainerID
101 | PauseContainerEndpoint ContainerID
25 | UnpauseContainerEndpoint ContainerID
102 | UnpauseContainerEndpoint ContainerID
26− | ContainerLogsEndpoint LogOpts ContainerID
103+ | ContainerLogsEndpoint LogOpts Bool ContainerID -- Second argument (Bool) is whether to follow.
27 | DeleteContainerEndpoint DeleteOpts ContainerID
104 | DeleteContainerEndpoint DeleteOpts ContainerID
105+ | InspectContainerEndpoint ContainerID
106+ deriving (Eq, Show)
28
107
29type URL = Text
108type URL = Text
30type ApiVersion = Text
109type ApiVersion = Text
110+newtype ContainerID = ContainerID Text
111+ deriving (Eq, Show)
112+
113+fromContainerID :: ContainerID -> Text
31−type ContainerID = Text
114+fromContainerID (ContainerID t) = t
115+
116+toContainerID :: Text -> Maybe ContainerID
117+toContainerID t =
118+ if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
119+ Just $ ContainerID t
120+ else
121+ Nothing
122+
123+newtype ImageID = ImageID Text
124+ deriving (Eq, Show)
125+
126+fromImageID :: ImageID -> Text
32−type ImageID = Text
127+fromImageID (ImageID t) = t
128+
129+toImageID :: Text -> Maybe ImageID
130+toImageID t =
131+ if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
132+ Just $ ImageID t
133+ else
134+ Nothing
33
135
34data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
136data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
35
137
@@ -43,21 +145,121 @@ data Signal = SIGHUP
43 | SIG Integer
145 | SIG Integer
44 | SIGKILL deriving (Eq, Show)
146 | SIGKILL deriving (Eq, Show)
45
147
148+instance FromJSON Signal where
149+ parseJSON (JSON.String "SIGTERM") = return SIGTERM
150+ parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
151+ parseJSON (JSON.String "SIGINT") = return SIGINT
152+ parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
153+ parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
154+ parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
155+ parseJSON _ = fail "Unknown Signal"
156+
157+instance ToJSON Signal where
158+ toJSON SIGHUP = "SIGHUP"
159+ toJSON SIGINT = "SIGINT"
160+ toJSON SIGQUIT = "SIGQUIT"
161+ toJSON SIGSTOP = "SIGSTOP"
162+ toJSON SIGTERM = "SIGTERM"
163+ toJSON SIGUSR1 = "SIGUSR1"
164+ toJSON (SIG i) = toJSON i
165+ toJSON SIGKILL = "SIGKILL"
166+
167+data ContainerDetails = ContainerDetails {
168+ appArmorProfile :: Text
169+ , args :: [Text]
170+ , containerDetailsConfig :: ContainerConfig
171+ , created :: UTCTime
172+ , driver :: Text
173+ -- , execIDs -- Not sure what this is in 1.24 spec.
174+ , containerDetailsHostConfig :: HostConfig
175+ , hostnamePath :: FilePath
176+ , hostsPath :: FilePath
177+ , logPath :: FilePath
178+ , containerDetailsId :: ContainerID
179+ , containerDetailsImage :: ImageID
180+ , mountLabel :: Text
181+ , name :: Text
182+ , networkSettings :: NetworkSettings
183+ , path :: FilePath
184+ , processLabel :: Text
185+ , resolveConfPath :: FilePath
186+ , restartCount :: Int
187+ , state :: ContainerState
188+ , mounts :: [Mount]
189+ }
190+ deriving (Eq, Show, Generic)
191+
192+data Mount = Mount {
193+ mountName :: Text
194+ , mountSource :: FilePath
195+ , mountDestination :: FilePath
196+ , mountDriver :: Text
197+ , mountMode :: Text -- Note: Improve this?
198+ , mountRW :: Bool
199+ , mountPropogation :: Text
200+ }
201+ deriving (Eq, Show, Generic)
202+
203+instance FromJSON Mount where
204+ parseJSON (JSON.Object o) = do
205+ name <- o .: "Name"
206+ src <- o .: "Source"
207+ dest <- o .: "Destination"
208+ driver <- o .: "Driver"
209+ mode <- o .: "Mode"
210+ rw <- o .: "RW"
211+ prop <- o .: "Propagation"
212+ return $ Mount name src dest driver mode rw prop
213+ parseJSON _ = fail "Mount is not an object"
214+
215+data ContainerState = ContainerState {
216+ containerError :: Text
217+ , exitCode :: Int
218+ , finishedAt :: Maybe UTCTime -- Note: Is this a maybe?
219+ , oomKilled :: Bool
220+ , dead :: Bool
221+ , paused :: Bool
222+ , pid :: Int
223+ , restarting :: Bool
224+ , running :: Bool
225+ , startedAt :: UTCTime
226+ , status :: Status
227+ }
228+ deriving (Eq, Show, Generic)
229+
230+instance FromJSON ContainerState where
231+ parseJSON (JSON.Object o) = do
232+ err <- o .: "Error"
233+ exit <- o .: "ExitCode"
234+ finished <- o .:? "FinishedAt"
235+ oomKilled <- o .: "OOMKilled"
236+ dead <- o .: "Dead"
237+ paused <- o .: "Paused"
238+ pid <- o .: "Pid"
239+ restarting <- o .: "Restarting"
240+ running <- o .: "Running"
241+ started <- o .: "StartedAt"
242+ st <- o .: "Status"
243+ return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st
244+ parseJSON _ = fail "ContainerState is not an object"
245+
46data DockerClientOpts = DockerClientOpts {
246data DockerClientOpts = DockerClientOpts {
47 apiVer :: ApiVersion
247 apiVer :: ApiVersion
48 , baseUrl :: URL
248 , baseUrl :: URL
49 }
249 }
50−
51−data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
250+ deriving (Eq, Show)
52−
53−defaultListOpts = ListOpts { all=False }
54
251
55defaultClientOpts :: DockerClientOpts
252defaultClientOpts :: DockerClientOpts
56defaultClientOpts = DockerClientOpts {
253defaultClientOpts = DockerClientOpts {
57− apiVer = "v1.22"
254+ apiVer = "v1.23"
58 , baseUrl = "http://127.0.0.1:2375"
255 , baseUrl = "http://127.0.0.1:2375"
59 }
256 }
60
257
258+data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
259+
260+defaultListOpts :: ListOpts
261+defaultListOpts = ListOpts { all=False }
262+
61data DockerVersion = DockerVersion {
263data DockerVersion = DockerVersion {
62 version :: Text
264 version :: Text
63 , apiVersion :: ApiVersion
265 , apiVersion :: ApiVersion
@@ -78,6 +280,57 @@ instance FromJSON DockerVersion where
78 parseJSON = genericParseJSON defaultOptions {
280 parseJSON = genericParseJSON defaultOptions {
79 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
281 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
80
282
283+-- instance ToJSON ContainerDetails where
284+-- toJSON = error "TODO"
285+
286+instance FromJSON ContainerDetails where
287+ parseJSON (JSON.Object o) = do
288+ appArmor <- o .: "AppArmorProfile"
289+ args <- o .: "Args"
290+ config <- o .: "Config"
291+ created <- o .: "Created"
292+ driver <- o .: "Driver"
293+ hostConfig <- o .: "HostConfig"
294+ hostnamePath <- o .: "HostnamePath"
295+ hostsPath <- o .: "HostsPath"
296+ logPath <- o .: "LogPath"
297+ id <- o .: "Id"
298+ image <- o .: "Image"
299+ mountLabel <- o .: "MountLabel"
300+ name <- o .: "Name"
301+ networkSettings <- o .: "NetworkSettings"
302+ path <- o .: "Path"
303+ processLabel <- o .: "ProcessLabel"
304+ resolveConfPath <- o .: "ResolvConfPath"
305+ restartCount <- o .: "RestartCount"
306+ state <- o .: "State"
307+ mounts <- o .: "Mounts"
308+ return $ ContainerDetails appArmor args config created driver hostConfig hostnamePath hostsPath logPath id image mountLabel name networkSettings path processLabel resolveConfPath restartCount state mounts
309+ parseJSON _ = fail "ContainerDetails is not an object"
310+
311+instance ToJSON ContainerID where
312+ toJSON (ContainerID cid) = object ["Id" .= cid]
313+
314+instance FromJSON ContainerID where
315+ parseJSON (JSON.Object o) = do
316+ cid <- o .: "Id"
317+ case toContainerID cid of
318+ Nothing ->
319+ fail "Invalid ContainerID"
320+ Just cid ->
321+ return cid
322+ parseJSON _ = fail "ContainerID is not an object."
323+
324+instance ToJSON ImageID where
325+ toJSON (ImageID iid) = JSON.String iid
326+
327+instance FromJSON ImageID where
328+ parseJSON (JSON.String t) = case toImageID t of
329+ Nothing ->
330+ fail "Invalid ImageID"
331+ Just iid ->
332+ return iid
333+ parseJSON _ = fail "ImageID is not an object."
81
334
82data ContainerPortInfo = ContainerPortInfo {
335data ContainerPortInfo = ContainerPortInfo {
83 ipAddressInfo :: Maybe Text
336 ipAddressInfo :: Maybe Text
@@ -92,50 +345,100 @@ instance FromJSON ContainerPortInfo where
92 <*> (v .: "PrivatePort")
345 <*> (v .: "PrivatePort")
93 <*> (v .:? "PublicPort")
346 <*> (v .:? "PublicPort")
94 <*> (v .:? "Type")
347 <*> (v .:? "Type")
95−
348+ parseJSON _ = fail "ContainerPortInfo: Not a JSON object."
349+
350+-- For inspecting container details.
96−-- data NetworkOptions = NetworkOptions {
351+data NetworkOptions = NetworkOptions {
97−-- ipamConfig :: Maybe Text
352+-- ipamConfig :: Maybe Text -- Don't see in 1.24
98−-- , links :: Maybe Text
353+-- , links :: Maybe Text -- Don't see in 1.24
99−-- , aliases :: Maybe Text
354+-- , aliases :: Maybe Text -- Don't see in 1.24
100−-- , networkId :: Text
355+ networkOptionsId :: Text
101−-- , endpointId :: Text
356+ , networkOptionsEndpointId :: Text
102−-- , gateway :: Text
357+ , networkOptionsGateway :: Text
103−-- , ipAddress :: Text
358+ , networkOptionsIpAddress :: Text -- Note: Parse this?
104−-- , ipPrefixLen :: Text
359+ , networkOptionsIpPrefixLen :: Int
105−-- , ipV6Gateway :: Maybe Text
360+ , networkOptionsIpV6Gateway :: Maybe Text
106−-- , globalIPv6Address :: Maybe Text
361+ , networkOptionsGlobalIPv6Address :: Maybe Text
107−-- , globalIPv6PrefixLen :: Maybe Text
362+ , networkOptionsGlobalIPv6PrefixLen :: Maybe Int
108−-- , macAddress :: Text
363+ , networkOptionsMacAddress :: Text
109−-- } deriving (Eq, Show)
364+ } deriving (Eq, Show)
110−
365+
111−-- data Network = Network (M.Map NetworkMode NetworkOptions) deriving (Eq, Show)
366+instance FromJSON NetworkOptions where
112−
367+ parseJSON (JSON.Object o) = do
113−-- data NetworkSettings = NetworkSettings {
368+ networkId <- o .: "NetworkID"
114−-- bridge
369+ endpointId <- o .: "EndpointID"
115−-- , sandboxId
370+ gateway <- o .: "Gateway"
116−-- , hairpinMode
371+ ip <- o .: "IPAddress"
117−-- , linkLocalIPv6Address
372+ ipLen <- o .: "IPPrefixLen"
118−-- , linkLocalIPv6PrefixLen
373+ ip6Gateway <- o .:? "IPv6Gateway"
119−-- , ports
374+ globalIP6 <- o .:? "GlobalIPv6Address"
120−-- , sandboxKey
375+ globalIP6Len <- o .:? "GlobalIPv6PrefixLen"
121−-- , secondaryIPAddresses
376+ mac <- o .: "MacAddress"
122−-- , secondaryIPv6Addresses
377+ return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac
123−-- , endpointID
378+ parseJSON _ = fail "NetworkOptions is not an object"
124−-- , gateway
379+
125−-- , globalIPv6Address
380+newtype Networks = Networks (M.Map NetworkMode NetworkOptions) -- Note: Is it ever possible that there will be duplicates of network modes?
126−-- , globalIPv6PrefixLen
381+ deriving (Eq, Show)
127−-- , ipAddress
382+
128−-- , ipPrefixLen
383+instance FromJSON Networks where
129−-- , ipv6Gateway
384+ parseJSON (JSON.Object o) = do
130−-- , macAddress
385+ Networks <$> HM.foldlWithKey' f (return M.empty) o
131−-- , networks :: [Network]
386+
132−-- }
387+ where
133−
388+ f accM k' v' = do
389+ acc <- accM
390+ k <- parseJSON $ JSON.String k'
391+ v <- parseJSON v'
392+ return $ M.insert k v acc
393+
394+ parseJSON _ = fail "Networks is not an object"
395+
134−-- data NetworkSettings = NetworkSettings (M.Map Text Text) deriving (Eq, Show, Generic)
396+data NetworkSettings = NetworkSettings {
135−
397+ networkSettingsBridge :: Text
398+ , networkSettingsSandboxId :: Text
399+ , networkSettingsHairpinMode :: Bool
400+ , networkSettingsLinkLocalIPv6Address :: Text
401+ , networkSettingsLinkLocalIPv6PrefixLen :: Int
402+ , networkSettingsPorts :: [Int] -- TODO: 1.24 spec is unclear
403+ , networkSettingsSandboxKey :: Text
404+ , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
405+ , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
406+ , networkSettingsEndpointID :: Text
407+ , networkSettingsGateway :: Text
408+ , networkSettingsGlobalIPv6Address :: Text
409+ , networkSettingsGlobalIPv6PrefixLen :: Int
410+ , networkSettingsIpAddress :: Text
411+ , networkSettingsIpPrefixLen :: Int
412+ , networkSettingsIpv6Gateway
413+ , networkSettingsMacAddress
414+ , networkSettingsNetworks :: Networks
415+ }
416+ deriving (Eq, Show)
417+
136−-- instance FromJSON NetworkSettings
418+instance FromJSON NetworkSettings where
137−
419+ parseJSON (JSON.Object o) = do
420+ bridge <- o .: "Bridge"
421+ sandbox <- o .: "SandboxID"
422+ hairpin <- o .: "HairpinMode"
423+ localIP6 <- o .: "LinkLocalIPv6Address"
424+ localIP6Len <- o .: "LinkLocalIPv6PrefixLen"
425+ ports <- o .:? "Ports" .!= []
426+ sandboxKey <- o .: "SandboxKey"
427+ secondaryIP <- o .: "SecondaryIPAddresses"
428+ secondayIP6 <- o .: "SecondaryIPv6Addresses"
429+ endpointID <- o .: "EndpointID"
430+ gateway <- o .: "Gateway"
431+ globalIP6 <- o .: "GlobalIPv6Address"
432+ globalIP6Len <- o .: "GlobalIPv6PrefixLen"
433+ ip <- o .: "IPAddress"
434+ ipLen <- o .: "IPPrefixLen"
435+ ip6Gateway <- o .: "IPv6Gateway"
436+ mac <- o .: "MacAddress"
437+ networks <- o .: "Networks"
438+ return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
439+ parseJSON _ = fail "NetworkSettings is not an Object"
440+
138−-- TODO: Add NetworkSettings
441+-- TODO: Add NetworkSettings, Mounts
139data Container = Container
442data Container = Container
140 { containerId :: ContainerID
443 { containerId :: ContainerID
141 , containerNames :: [Text]
444 , containerNames :: [Text]
@@ -143,10 +446,11 @@ data Container = Container
143 , containerImageId :: ImageID
446 , containerImageId :: ImageID
144 , containerCommand :: Text
447 , containerCommand :: Text
145 , containerCreatedAt :: Int
448 , containerCreatedAt :: Int
146− , containerStatus :: Text
449+ , containerStatus :: Status
147 , containerPorts :: [ContainerPortInfo]
450 , containerPorts :: [ContainerPortInfo]
148 , containerLabels :: Labels
451 , containerLabels :: Labels
149− -- , containerNetworkSettings :: NetworkSettings
452+ , containerNetworks :: Networks
453+ , containerMounts :: [Mount]
150 } deriving (Show, Eq)
454 } deriving (Show, Eq)
151
455
152instance FromJSON Container where
456instance FromJSON Container where
@@ -160,14 +464,29 @@ instance FromJSON Container where
160 <*> (v .: "Status")
464 <*> (v .: "Status")
161 <*> (v .: "Ports")
465 <*> (v .: "Ports")
162 <*> (v .: "Labels")
466 <*> (v .: "Labels")
163− -- <*> (v .: "NetworkSettings")
467+ <*> (v .: "NetworkSettings" >>= parseNetworks)
164−
468+ <*> (v .: "Mounts")
469+ where
470+ parseNetworks (JSON.Object v) =
471+ (v .: "Networks") >>= parseJSON
472+ parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
473+
474+ parseJSON _ = fail "Container: Not a JSON object."
475+
165−data Status = Created | Restarting | Running | Paused | Exited | Dead deriving (Eq, Show, Generic)
476+data Status = Created | Restarting | Running | Paused | Exited | Dead
166−
477+ deriving (Eq, Show, Generic)
478+
167−instance FromJSON Status
479+instance FromJSON Status where
168−instance ToJSON Status
480+ parseJSON (JSON.String "running") = return Running
481+ parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
482+ parseJSON (JSON.String "restarting") = return Restarting
483+ parseJSON (JSON.String "paused") = return Paused
484+ parseJSON (JSON.String "exited") = return Exited
485+ parseJSON (JSON.String "dead") = return Dead
486+ parseJSON _ = fail "Unknown Status"
169
487
170type Digest = Text
488type Digest = Text
489+
171newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)
490newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)
172
491
173instance FromJSON Labels where
492instance FromJSON Labels where
@@ -183,12 +502,13 @@ data Image = DockerImage {
183 , imageCreated :: Integer
502 , imageCreated :: Integer
184 , imageParentId :: Maybe ImageID
503 , imageParentId :: Maybe ImageID
185 , imageRepoTags :: [Tag]
504 , imageRepoTags :: [Tag]
186− , imageRepoDigests :: [Digest]
505+ , imageRepoDigests :: Maybe [Digest]
187 , imageSize :: Integer
506 , imageSize :: Integer
188 , imageVirtualSize :: Integer
507 , imageVirtualSize :: Integer
189− , imageLabels :: Labels
508+ , imageLabels :: Maybe Labels
190 } deriving (Show, Eq, Generic)
509 } deriving (Show, Eq, Generic)
191
510
511+dropImagePrefix :: [a] -> [a]
192dropImagePrefix = drop 5
512dropImagePrefix = drop 5
193
513
194instance FromJSON Image where
514instance FromJSON Image where
@@ -196,17 +516,102 @@ instance FromJSON Image where
196 fieldLabelModifier = dropImagePrefix}
516 fieldLabelModifier = dropImagePrefix}
197
517
198data CreateOpts = CreateOpts {
518data CreateOpts = CreateOpts {
199− containerConfig :: ContainerConfig
519+ containerConfig :: ContainerConfig
200− , hostConfig :: HostConfig
520+ , hostConfig :: HostConfig
201− , containerResources :: ContainerResources
202 } deriving (Eq, Show)
521 } deriving (Eq, Show)
203
522
523+instance ToJSON CreateOpts where
524+ toJSON (CreateOpts cc hc) = do
525+ let ccJSON = toJSON cc
526+ let hcJSON = toJSON hc
527+ case ccJSON of
528+ JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
529+ JSON.Object $ HM.insert "HostConfig" hcJSON o
530+ _ -> error "ContainerConfig is not an object." -- This should never happen.
531+
532+cConfig :: Text -> ContainerConfig
533+cConfig imageName = ContainerConfig {
534+ hostname=Nothing
535+ , domainname=Nothing
536+ , user=Nothing
537+ , attachStdin=False
538+ , attachStdout=False
539+ , image=imageName
540+ , attachStderr=False
541+ , exposedPorts=ExposedPorts M.empty
542+ , tty=False
543+ , openStdin=False
544+ , stdinOnce=False
545+ , env=[]
546+ , cmd=[]
547+ , volumes=Nothing
548+ , workingDir=Nothing
549+ , entrypoint=Nothing
550+ , networkDisabled=False
551+ , macAddress=Nothing
552+ , labels=Nothing
553+ , stopSignal=SIGTERM
554+ }
555+
556+hConfig :: HostConfig
557+hConfig = HostConfig {
558+ binds=[]
559+ , containerIDFile=Nothing
560+ , logConfig=LogDriverConfig JsonFile Nothing
561+ , networkMode=Bridge
562+ , portBindings=PortBindings []
563+ , restartPolicy=RestartOff
564+ , volumeDriver=Nothing
565+ , volumesFrom=[]
566+ , capAdd=[]
567+ , capDrop=[]
568+ , dns=[]
569+ , dnsOptions=[]
570+ , dnsSearch=[]
571+ , extraHosts=[]
572+ , ipcMode=Nothing
573+ , links=[]
574+ , oomScoreAdj=Nothing
575+ , privileged=False
576+ , publishAllPorts=False
577+ , readOnlyRootfs=False
578+ , securityOpt=[]
579+ , shmSize=Nothing
580+ , resources=cResources
581+ }
582+
583+cResources :: ContainerResources
584+cResources = ContainerResources {
585+ cpuShares=Nothing
586+ , blkioWeight=Nothing
587+ , blkioWeightDevice=Nothing
588+ , blkioDeviceReadBps=Nothing
589+ , blkioDeviceWriteBps=Nothing
590+ , blkioDeviceReadIOps=Nothing
591+ , blkioDeviceWriteIOps=Nothing
592+ , cpuPeriod=Nothing
593+ , cpusetCpus=Nothing
594+ , cpusetMems=Nothing
595+ , devices=[]
596+ , kernelMemory=Nothing
597+ , memory=Nothing
598+ , memoryReservation=Nothing
599+ , memorySwap=Nothing
600+ , oomKillDisable=False
601+ , ulimits=[]
602+ }
603+
604+
605+defaultCreateOpts :: T.Text -> CreateOpts
606+defaultCreateOpts imageName = CreateOpts { containerConfig = cConfig imageName, hostConfig = hConfig }
607+
204-- detachKeys – Override the key sequence for detaching a container.
608-- detachKeys – Override the key sequence for detaching a container.
205-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
609-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
206data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
610data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
207
611
208data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
612data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
209
613
614+defaultStartOpts :: StartOpts
210defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
615defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
211
616
212data DeleteOpts = DeleteOpts {
617data DeleteOpts = DeleteOpts {
@@ -218,16 +623,15 @@ type Timestamp = Integer
218data TailLogOpt = Tail Integer | All deriving (Eq, Show)
623data TailLogOpt = Tail Integer | All deriving (Eq, Show)
219
624
220data LogOpts = LogOpts {
625data LogOpts = LogOpts {
221− follow :: Bool
222− , stdout :: Bool
626+ stdout :: Bool
223 , stderr :: Bool
627 , stderr :: Bool
224 , since :: Maybe Timestamp
628 , since :: Maybe Timestamp
225 , timestamps :: Bool
629 , timestamps :: Bool
226 , tail :: TailLogOpt
630 , tail :: TailLogOpt
227 } deriving (Eq, Show)
631 } deriving (Eq, Show)
228
632
229−defaultLogOpts = LogOpts { follow = False
633+defaultLogOpts :: LogOpts
230− , stdout = True
634+defaultLogOpts = LogOpts { stdout = True
231 , stderr = True
635 , stderr = True
232 , since = Nothing
636 , since = Nothing
233 , timestamps = True
637 , timestamps = True
@@ -236,14 +640,36 @@ defaultLogOpts = LogOpts { follow = False
236
640
237data VolumePermission = Rw | Ro deriving (Eq, Show, Generic)
641data VolumePermission = Rw | Ro deriving (Eq, Show, Generic)
238
642
239−instance ToJSON VolumePermission
643+-- instance ToJSON VolumePermission where
644+-- toJSON = error "TODO"
240−instance FromJSON VolumePermission
645+-- instance FromJSON VolumePermission where
646+-- parseJSON = error "TODO"
647+
648+-- Note: Note really sure what this should be (1.24).
649+-- This is not the same as [Volume] in HostConfig.
650+newtype Volumes = Volumes [Text] -- [Volume]
651+ deriving (Eq, Show)
652+
653+instance FromJSON Volumes where
654+ parseJSON (JSON.Object o) = return $ Volumes $ HM.keys o
655+ parseJSON _ = fail "Volumes is not an object"
656+
657+instance ToJSON Volumes where
658+ toJSON (Volumes vs) = toJSON vs
241
659
242data Volume = Volume { hostSrc :: Text
660data Volume = Volume { hostSrc :: Text
243 , containerDest :: Text
661 , containerDest :: Text
244 , volumePermission :: Maybe VolumePermission
662 , volumePermission :: Maybe VolumePermission
245 } deriving (Eq, Show)
663 } deriving (Eq, Show)
246
664
665+instance FromJSON Volume where
666+ parseJSON (JSON.String t) = case T.split (== ':') t of
667+ [src, dest] -> return $ Volume src dest Nothing
668+ [src, dest, "rw"] -> return $ Volume src dest $ Just Rw
669+ [src, dest, "ro"] -> return $ Volume src dest $ Just Ro
670+ _ -> fail "Could not parse Volume"
671+ parseJSON _ = fail "Volume is not a string"
672+
247data Device = Device {
673data Device = Device {
248 pathOnHost :: FilePath
674 pathOnHost :: FilePath
249 , pathInContainer :: FilePath
675 , pathInContainer :: FilePath
@@ -260,7 +686,20 @@ instance FromJSON Device where
260
686
261type ContainerName = Text
687type ContainerName = Text
262
688
263−data VolumeFrom = VolumeFrom ContainerName VolumePermission deriving (Eq, Show)
689+data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq, Show)
690+
691+instance FromJSON VolumeFrom where
692+ parseJSON (JSON.String t) = case T.split (== ':') t of
693+ [vol] -> return $ VolumeFrom vol Nothing
694+ [vol, "rw"] -> return $ VolumeFrom vol $ Just Rw
695+ [vol, "ro"] -> return $ VolumeFrom vol $ Just Ro
696+ _ -> fail "Could not parse VolumeFrom"
697+ parseJSON _ = fail "VolumeFrom is not a string"
698+
699+instance ToJSON VolumeFrom where
700+ toJSON (VolumeFrom n p) = case p of
701+ Nothing -> toJSON $ n <> ":" <> "rw"
702+ Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
264
703
265instance ToJSON Volume where
704instance ToJSON Volume where
266 toJSON (Volume src dest mode) = toJSON $ case mode of
705 toJSON (Volume src dest mode) = toJSON $ case mode of
@@ -269,47 +708,206 @@ instance ToJSON Volume where
269
708
270data Link = Link Text (Maybe Text) deriving (Eq, Show)
709data Link = Link Text (Maybe Text) deriving (Eq, Show)
271
710
711+instance FromJSON Link where
712+ parseJSON (JSON.String t) = case T.split (== ':') t of
713+ [f] -> return $ Link f Nothing
714+ [f,s] -> return $ Link f $ Just s
715+ _ -> fail "Could not parse Link"
716+ parseJSON _ = fail "Link is not a string"
717+
272instance ToJSON Link where
718instance ToJSON Link where
273 toJSON (Link n1 n2) = toJSON $ case n2 of
719 toJSON (Link n1 n2) = toJSON $ case n2 of
274 Nothing -> T.concat[n1, ":", n1] -- use same name in container
720 Nothing -> T.concat[n1, ":", n1] -- use same name in container
275 Just n -> T.concat[n1, ":", n] -- used specified name in container
721 Just n -> T.concat[n1, ":", n] -- used specified name in container
276
722
277-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
723-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
278−data LogDriverType = JsonFile | Syslog | Journald | Gelf | AwsLogs | Splunk | LoggingDisabled deriving (Eq, Show)
724+data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
279−
725+
726+instance FromJSON LogDriverType where
727+ parseJSON (JSON.String "json-file") = return JsonFile
728+ parseJSON (JSON.String "syslog") = return Syslog
729+ parseJSON (JSON.String "journald") = return Journald
730+ parseJSON (JSON.String "gelf") = return Gelf
731+ parseJSON (JSON.String "fluentd") = return Fluentd
732+ parseJSON (JSON.String "awslogs") = return AwsLogs
733+ parseJSON (JSON.String "splunk") = return Splunk
734+ parseJSON (JSON.String "etwlogs") = return Etwlogs
735+ parseJSON (JSON.String "none") = return LoggingDisabled
736+ parseJSON _ = fail "Unknown LogDriverType"
737+
738+instance ToJSON LogDriverType where
739+ toJSON JsonFile = JSON.String "json-file"
740+ toJSON Syslog = JSON.String "syslog"
741+ toJSON Journald = JSON.String "journald"
742+ toJSON Gelf = JSON.String "gelf"
743+ toJSON Fluentd = JSON.String "fluentd"
744+ toJSON AwsLogs = JSON.String "awslogs"
745+ toJSON Splunk = JSON.String "splunk"
746+ toJSON Etwlogs = JSON.String "etwlogs"
747+ toJSON LoggingDisabled = JSON.String "none"
748+
280−data LogDriverOptions = Map Text Text deriving (Eq, Show)
749+newtype LogDriverOptions = LogDriverOptions (M.Map Text Text) deriving (Eq, Show)
750+
751+instance FromJSON LogDriverOptions where
752+ parseJSON (JSON.Object o) = do
753+ LogDriverOptions <$> HM.foldlWithKey' f (return M.empty) o
754+
755+ where
756+ f accM k (JSON.String v) = do
757+ acc <- accM
758+ return $ M.insert k v acc
759+ f _ _ _ = fail "Value of LogDriverOptions is not a string"
760+
761+ parseJSON JSON.Null = return $ LogDriverOptions M.empty
762+ parseJSON _ = fail "LogDriverOptions is not an object"
763+
764+instance ToJSON LogDriverOptions where
765+ toJSON (LogDriverOptions mp) = toJSON mp
281
766
282data LogDriverConfig = LogDriverConfig LogDriverType (Maybe LogDriverOptions) deriving (Eq, Show)
767data LogDriverConfig = LogDriverConfig LogDriverType (Maybe LogDriverOptions) deriving (Eq, Show)
283
768
769+instance ToJSON LogDriverConfig where
770+ toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions]
771+
772+instance FromJSON LogDriverConfig where
773+ parseJSON (JSON.Object o) = do
774+ typ <- o .: "Type"
775+ opts <- o .: "Config"
776+ return $ LogDriverConfig typ opts
777+ parseJSON _ = fail "LogDriverConfig is not an object"
778+
284-- TODO: Add container:<name|id> mode
779-- TODO: Add container:<name|id> mode
285−data NetworkMode = Bridge | Host | NetworkDisabled deriving (Eq, Show)
780+data NetworkMode = Bridge | Host | NetworkDisabled
781+ deriving (Eq, Show, Ord)
782+
783+instance FromJSON NetworkMode where
784+ parseJSON (JSON.String "bridge") = return Bridge
785+ parseJSON (JSON.String "host") = return Host -- Note: Guessing on these.
786+ parseJSON (JSON.String "none") = return NetworkDisabled
787+ parseJSON _ = fail "Unknown NetworkMode"
788+
789+instance ToJSON NetworkMode where
790+ toJSON Bridge = JSON.String "bridge"
791+ toJSON Host = JSON.String "host"
792+ toJSON NetworkDisabled = JSON.String "none"
286
793
287−data PortType = TCP | UDP deriving (Eq, Show, Generic)
794+data PortType = TCP | UDP deriving (Eq, Show, Generic, Read, Ord)
288
795
289instance ToJSON PortType where
796instance ToJSON PortType where
290 toJSON TCP = "tcp"
797 toJSON TCP = "tcp"
291 toJSON UDP = "udp"
798 toJSON UDP = "udp"
292
799
293instance FromJSON PortType where
800instance FromJSON PortType where
294− parseJSON val = return $ case val of
801+ parseJSON val = case val of
295− "tcp" -> TCP
802+ "tcp" -> return TCP
296− "udp" -> UDP
803+ "udp" -> return UDP
804+ _ -> fail "PortType: Invalid port type."
297
805
298newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
806newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
299
807
808+instance FromJSON NetworkInterface where
809+ parseJSON (JSON.String v) = return $ NetworkInterface v
810+ parseJSON _ = fail "Network interface is not a string."
811+
812+instance ToJSON NetworkInterface where
813+ toJSON (NetworkInterface i) = JSON.String i
814+
815+-- | This datastructure models mapping a Port from the container onto the
816+-- host system s that the service running in the container can be accessed from
817+-- the outside world. We either map a port onto all interfaces (default) or onto a specific
818+-- interface like `127.0.0.1`.
819+newtype PortBindings = PortBindings [PortBinding]
820+ deriving (Eq, Show)
821+
300-- { <port>/<protocol>: [{ "HostPort": "<port>" }] }
822-- { <port>/<protocol>: [{ "HostPort": "<port>" }] }
301data PortBinding = PortBinding {
823data PortBinding = PortBinding {
302 containerPort :: Port
824 containerPort :: Port
303 , portType :: PortType
825 , portType :: PortType
304− , hostPort :: [HostPort]
826+ , hostPorts :: HostPorts
305 } deriving (Eq, Show)
827 } deriving (Eq, Show)
306
828
829+
830+portAndType2Text :: Port -> PortType -> Text
831+portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t)
832+
833+instance ToJSON PortBinding where
834+ toJSON (PortBinding {..}) = object [portAndType2Text containerPort portType .= hostPorts]
835+
836+instance FromJSON PortBindings where
837+ parseJSON (JSON.Object o) = do
838+ PortBindings <$> HM.foldlWithKey' f (return []) o
839+
840+ where
841+ f accM k v = case T.split (== '/') k of
842+ [port', portType'] -> do
843+ port <- parseIntegerText port'
844+ portType <- parseJSON $ JSON.String portType'
845+ acc <- accM
846+ hps <- parseJSON v
847+ return $ (PortBinding port portType hps):acc
848+ _ ->
849+ fail "Could not parse PortBindings"
850+ parseJSON _ = fail "PortBindings is not an object"
851+
852+instance ToJSON PortBindings where
853+ toJSON (PortBindings []) = JSON.Object HM.empty
854+ toJSON (PortBindings (p:ps)) = toJSON (p:ps)
855+
307−data HostPort = HostPort NetworkInterface Port deriving (Eq, Show)
856+data HostPort = HostPort NetworkInterface Port
857+ deriving (Eq, Show)
858+
859+instance ToJSON HostPort where
860+ toJSON (HostPort i p) = object ["HostPort" .= p, "HostIP" .= i]
861+
862+instance FromJSON HostPort where
863+ parseJSON (JSON.Object o) = do
864+ p <- o .: "HostPort"
865+ i <- o .: "HostIP"
866+ return $ HostPort i p
867+ parseJSON _ = fail "HostPort is not an object."
868+
869+newtype HostPorts = HostPorts [HostPort]
870+ deriving (Eq, Show)
871+
872+
873+instance ToJSON HostPorts where
874+ toJSON (HostPorts hps) = toJSON hps
875+
876+instance FromJSON HostPorts where
877+ parseJSON (JSON.Object o) = do
878+ HostPorts <$> HM.foldlWithKey' f (return []) o
879+
880+ where
881+ f accM k v = do
882+ acc <- accM
883+ p' <- parseJSON v
884+ p <- parseIntegerText p'
885+ return $ (HostPort (NetworkInterface k) p):acc
886+ parseJSON _ = fail "HostPorts is not an object"
308
887
309-- { "Name": "on-failure" , "MaximumRetryCount": 2}
888-- { "Name": "on-failure" , "MaximumRetryCount": 2}
310type RetryCount = Integer
889type RetryCount = Integer
311data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
890data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
312
891
892+instance FromJSON RestartPolicy where
893+ parseJSON (JSON.Object o) = do
894+ (name :: Text) <- o .: "Name"
895+ case name of
896+ "always" -> return RestartAlways
897+ "unless-stopped" -> return RestartUnlessStopped
898+ "on-failure" -> do
899+ retry <- o .: "MaximumRetryCount"
900+ return $ RestartOnFailure retry
901+ "" -> return RestartOff -- Note: Is this correct? 1.24 spec is unclear.
902+ _ -> fail "Could not parse RestartPolicy"
903+ parseJSON _ = fail "RestartPolicy is not an object"
904+
905+instance ToJSON RestartPolicy where
906+ toJSON RestartAlways = object ["Name" .= JSON.String "always"]
907+ toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
908+ toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
909+ toJSON RestartOff = object ["Name" .= JSON.String "off"]
910+
313data Isolation = Default | Process | Hyperv deriving (Eq, Show)
911data Isolation = Default | Process | Hyperv deriving (Eq, Show)
314
912
315newtype UTSMode = UTSMode Text deriving (Eq, Show)
913newtype UTSMode = UTSMode Text deriving (Eq, Show)
@@ -319,12 +917,12 @@ newtype UTSMode = UTSMode Text deriving (Eq, Show)
319-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container
917-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container
320data HostConfig = HostConfig
918data HostConfig = HostConfig
321 { binds :: [Volume]
919 { binds :: [Volume]
322− , containerIDFile :: FilePath
920+ , containerIDFile :: Maybe FilePath -- 1.24: Only in responses, not create
323 , logConfig :: LogDriverConfig
921 , logConfig :: LogDriverConfig
324 , networkMode :: NetworkMode
922 , networkMode :: NetworkMode
325− , portBindings :: [PortBinding]
923+ , portBindings :: PortBindings
326 , restartPolicy :: RestartPolicy
924 , restartPolicy :: RestartPolicy
327− , volumeDriver :: Text
925+ , volumeDriver :: Maybe Text
328 , volumesFrom :: [VolumeFrom]
926 , volumesFrom :: [VolumeFrom]
329 , capAdd :: [Text]
927 , capAdd :: [Text]
330 , capDrop :: [Text]
928 , capDrop :: [Text]
@@ -332,93 +930,178 @@ data HostConfig = HostConfig
332 , dnsOptions :: [Text]
930 , dnsOptions :: [Text]
333 , dnsSearch :: [Text]
931 , dnsSearch :: [Text]
334 , extraHosts :: [Text]
932 , extraHosts :: [Text]
335− , groupAdd :: [Integer]
933+ -- , groupAdd :: [Integer] -- 1.24: Missing from inspecting container details... Going to omit for now.
336− , ipcMode :: Text
934+ , ipcMode :: Maybe Text -- 1.24: Only in inspect, not create
337 , links :: [Link]
935 , links :: [Link]
338− , oomScoreAdj :: Integer
936+ , oomScoreAdj :: Maybe Integer
339− , pidMode :: Text
937+ -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit
340 , privileged :: Bool
938 , privileged :: Bool
341 , publishAllPorts :: Bool
939 , publishAllPorts :: Bool
342 , readOnlyRootfs :: Bool
940 , readOnlyRootfs :: Bool
343 , securityOpt :: [Text]
941 , securityOpt :: [Text]
344− , storageOpt :: [Text]
345− , utsMode :: UTSMode
942+ -- , utsMode :: UTSMode -- 1.24: Don't see this
346− , shmSize :: Integer
943+ , shmSize :: Maybe Integer
347− , consoleSize :: Integer
944+ -- , consoleSize :: Integer -- 1.24: Don't see this
348− , isolation :: Isolation
945+ -- , isolation :: Isolation -- 1.24: Don't see this
349 , resources :: ContainerResources
946 , resources :: ContainerResources
350 } deriving (Eq, Show, Generic)
947 } deriving (Eq, Show, Generic)
351
948
949+instance FromJSON HostConfig where
950+ parseJSON = genericParseJSON defaultOptions {
951+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
952+
953+instance ToJSON HostConfig where
954+ toJSON = genericToJSON defaultOptions {
955+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
956+
957+
352-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }
958-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }
353-- { "Name": "nofile", "Soft": 1024, "Hard": 2048 }
959-- { "Name": "nofile", "Soft": 1024, "Hard": 2048 }
354data Ulimit = Ulimit {
960data Ulimit = Ulimit {
355 ulimitName :: Text
961 ulimitName :: Text
356 , ulimitSoft :: Integer
962 , ulimitSoft :: Integer
357 , ulimitHard :: Integer
963 , ulimitHard :: Integer
358− } deriving (Eq, Show)
964+ } deriving (Eq, Show, Generic)
965+
966+instance FromJSON Ulimit where
967+ parseJSON = genericParseJSON defaultOptions {
968+ fieldLabelModifier = drop 5}
969+
970+instance ToJSON Ulimit where
971+ toJSON = genericToJSON defaultOptions {
972+ fieldLabelModifier = drop 5}
359
973
360data ContainerResources = ContainerResources {
974data ContainerResources = ContainerResources {
361− cpuShares :: Integer
975+ cpuShares :: Maybe Integer
362− , cgroupParent :: Text
976+ -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
363− , blkioWeight :: Text
977+ , blkioWeight :: Maybe Text
364− , blkioWeightDevice :: Text
978+ , blkioWeightDevice :: Maybe Text
365− , blkioDeviceReadBps :: Text
979+ , blkioDeviceReadBps :: Maybe Text
366− , blkioDeviceWriteBps :: Text
980+ , blkioDeviceWriteBps :: Maybe Text
367− , blkioDeviceReadIOps :: Text
981+ , blkioDeviceReadIOps :: Maybe Text
368− , blkioDeviceWriteIOps :: Text
982+ , blkioDeviceWriteIOps :: Maybe Text
369− , cpuPeriod :: Integer
983+ , cpuPeriod :: Maybe Integer
370− , cpuQuota :: Integer
984+ -- , cpuQuota :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
371− , cpusetCpus :: Integer
985+ , cpusetCpus :: Maybe Integer
372− , cpusetMems :: Text
986+ , cpusetMems :: Maybe Text
373 , devices :: [Device]
987 , devices :: [Device]
374− , diskQuota :: Integer
988+ -- , diskQuota :: Integer -- Don't see this ins 1.24.
375− , kernelMemory :: Integer
989+ , kernelMemory :: Maybe Integer
376− , memory :: Integer
990+ , memory :: Maybe Integer
377− , memoryReservation :: Integer
991+ , memoryReservation :: Maybe Integer
378− , memorySwap :: Integer
992+ , memorySwap :: Maybe Integer
379− , memorySwappiness :: Integer
993+ -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
380 , oomKillDisable :: Bool
994 , oomKillDisable :: Bool
381− , pidsLimit :: Integer
995+ -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
382 , ulimits :: [Ulimit]
996 , ulimits :: [Ulimit]
997+ -- TODO: Missing from 1.24
998+ -- StorageOpt :: [(Text, Text)]
999+ -- VolumeDriver :: ??
1000+ -- EndpointsConfig :: ??
1001+ -- TODO: Only in inspect container in 1.24
1002+ -- CpuPercent :: Int +
1003+ -- MaximumIOps :: Int +
1004+ -- MaximumIOBps :: Int +
1005+ -- LxcConf :: [??] +
383− } deriving (Eq, Show)
1006+ } deriving (Eq, Show, Generic)
1007+
1008+instance ToJSON ContainerResources where
1009+ toJSON = genericToJSON defaultOptions {
1010+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1011+
1012+instance FromJSON ContainerResources where
1013+ parseJSON = genericParseJSON defaultOptions {
1014+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
384
1015
385type Port = Integer
1016type Port = Integer
386
1017
387type Name = Text
1018type Name = Text
388type Value = Text
1019type Value = Text
389
1020
390−data EnvVar = EnvVar Name Value deriving (Eq, Show)
1021+data EnvVar = EnvVar Name Value
1022+ deriving (Eq, Show)
1023+
1024+instance FromJSON EnvVar where
1025+ parseJSON (JSON.String env) =
1026+ let (n, v') = T.break (== '=') env in
1027+ let v = T.drop 1 v' in
1028+ return $ EnvVar n v
1029+ parseJSON _ = fail "EnvVar is not a string"
1030+
1031+instance ToJSON EnvVar where
1032+ toJSON (EnvVar n v) = object [n .= v]
1033+
1034+-- | ExposedPorts represent a enumeraton of all the ports (and their type)
1035+-- that a container should expose to other containers or the host system.
1036+-- `NOTE`: This does not automatically expose the ports onto the host
1037+-- system but rathet it just tags them. It's best to be used with with
1038+-- the PublishAllPorts flag. It is also useful for
1039+-- the deamon to know wich Environment variables to
1040+-- inject into a container linking to our container.
1041+-- Example linking a Postgres container named db would inject the following
1042+-- environment variables automatically if we set the corresponding
1043+-- ExposedPorts:
1044+-- DB_PORT_5432_TCP_PORT="5432"
1045+-- DB_PORT_5432_TCP_PROTO="tcp"
1046+-- DB_PORT_5432_TCP="tcp://172.17.0.1:5432"
1047+newtype ExposedPorts = ExposedPorts (M.Map PortType Port) deriving (Eq, Show)
1048+
1049+instance FromJSON ExposedPorts where
1050+ parseJSON (JSON.Object o) = do
1051+ ExposedPorts <$> HM.foldlWithKey' f (return M.empty) o
1052+
1053+ where
1054+ f accM k _ = case T.split (== '/') k of
1055+ [port', portType'] -> do
1056+ port <- parseIntegerText port'
1057+ portType <- parseJSON $ JSON.String portType'
1058+ acc <- accM
1059+ return $ M.insert portType port acc
1060+ _ ->
1061+ fail "Could not parse ExposedPorts"
1062+ parseJSON _ = fail "ExposedPorts is not an object."
1063+
1064+instance ToJSON ExposedPorts where
1065+ toJSON (ExposedPorts kvs) = object [((T.pack $ show p) <> "/" <> (T.pack $ show t)) .= JSON.Object HM.empty | (t,p) <- (M.toList kvs)]
1066+
391
1067
392data ContainerConfig = ContainerConfig {
1068data ContainerConfig = ContainerConfig {
393− hostname :: Text
1069+ hostname :: Maybe Text
394− , domainname :: Text
1070+ , domainname :: Maybe Text
395− , user :: Text
1071+ , user :: Maybe Text
396 , attachStdin :: Bool
1072 , attachStdin :: Bool
397 , attachStdout :: Bool
1073 , attachStdout :: Bool
398 , attachStderr :: Bool
1074 , attachStderr :: Bool
399− -- ExposedPorts are used for the PublishAllPorts flag
400− -- to know which ports to publish. Also it's used for
401− -- the deamon to know wich Environment variables to
402− -- inject into a container linking to our container.
403− -- Example linking a Postgres container named db:
404− -- DB_PORT_5432_TCP_PORT="5432"
405− -- DB_PORT_5432_TCP_PROTO="tcp"
406− -- DB_PORT_5432_TCP="tcp://172.17.0.1:5432"
407− , exposedPorts :: [Port]
1075+ , exposedPorts :: ExposedPorts
408− , publishService :: Text
1076+ -- , publishService :: Text -- Don't see this in 1.24
409 , tty :: Bool
1077 , tty :: Bool
410 , openStdin :: Bool
1078 , openStdin :: Bool
411 , stdinOnce :: Bool
1079 , stdinOnce :: Bool
412 , env :: [EnvVar]
1080 , env :: [EnvVar]
413− , cmd :: Text
1081+ , cmd :: [Text]
414− , argsEscaped :: Bool
1082+ -- , argsEscaped :: Bool -- Don't see this in 1.24
415 , image :: Text
1083 , image :: Text
416− , volumes :: [Volume]
1084+ , volumes :: Maybe Volumes
417− , workingDir :: FilePath
1085+ , workingDir :: Maybe FilePath
418− , entrypoint :: Text
1086+ , entrypoint :: Maybe Text -- Can be null?
419 , networkDisabled :: Bool
1087 , networkDisabled :: Bool
420− , macAddress :: Text
1088+ , macAddress :: Maybe Text
421− , onBuild :: Text
1089+ -- , onBuild :: Text -- For 1.24, only see this in the inspect response.
422− , labels :: Labels
1090+ , labels :: Maybe Labels
423 , stopSignal :: Signal
1091 , stopSignal :: Signal
424− } deriving (Eq, Show)
1092+ } deriving (Eq, Show, Generic)
1093+
1094+instance ToJSON ContainerConfig where
1095+ toJSON = genericToJSON defaultOptions {
1096+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1097+
1098+instance FromJSON ContainerConfig where
1099+ parseJSON = genericParseJSON defaultOptions {
1100+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1101+
1102+parseIntegerText :: (Monad m) =>Text -> m Integer
1103+parseIntegerText t = case readMaybe $ T.unpack t of
1104+ Nothing ->
1105+ fail "Could not parse Integer"
1106+ Just i ->
1107+ return i
stack.yaml+1−1
@@ -1,7 +1,7 @@
1# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
1# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
2
2
3# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.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-4.1
4+resolver: lts-5.18
5
5
6# Local packages, usually specified by relative directory name
6# Local packages, usually specified by relative directory name
7packages:
7packages:
tests/tests.hs+51−24
@@ -1,3 +1,5 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
1module Main where
3module Main where
2
4
3import qualified Test.QuickCheck.Monadic as QCM
5import qualified Test.QuickCheck.Monadic as QCM
@@ -6,46 +8,62 @@ import Test.Tasty.HUnit
6import qualified Test.Tasty.QuickCheck as QC
8import qualified Test.Tasty.QuickCheck as QC
7
9
8import Control.Concurrent (threadDelay)
10import Control.Concurrent (threadDelay)
11+import Control.Monad.IO.Class
12+import Control.Monad.Trans.Class (MonadTrans, lift)
9import qualified Data.ByteString as B
13import qualified Data.ByteString as B
10import qualified Data.ByteString.Char8 as C
14import qualified Data.ByteString.Char8 as C
11import qualified Data.ByteString.Lazy as BL
15import qualified Data.ByteString.Lazy as BL
12import Data.Maybe (fromJust, isJust)
16import Data.Maybe (fromJust, isJust)
17+import Data.Monoid
13import Data.Text (unpack)
18import Data.Text (unpack)
19+import Network.Connection (TLSSettings (..))
20+import Network.HTTP.Client (newManager)
21+import Network.HTTP.Client.TLS
14import Network.HTTP.Types.Status
22import Network.HTTP.Types.Status
15import System.Process (system)
23import System.Process (system)
16
24
17−import Network.Docker
25+import Docker
18−import Network.Docker.Types
26+import Docker.Types
19
27
20
28
21−opts = defaultClientOpts
29+-- opts = defaultClientOpts
22
30
23−test_image_name = "docker-hs-test"
31+testImageName = "docker-hs-test"
24
32
25toStrict1 = B.concat . BL.toChunks
33toStrict1 = B.concat . BL.toChunks
26
34
35+runDocker f = do
36+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
37+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
38+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
39+ -- let settings = mkManagerSettings (TLSSettings params) Nothing
40+ -- mgr <- newManager settings
41+ runDockerT (defaultClientOpts, defaultHttpHandler) f
42+
27checkDockerVersion :: IO ()
43checkDockerVersion :: IO ()
44+checkDockerVersion = runDocker $ do
28−checkDockerVersion = do v <- getDockerVersion opts
45+ v <- getDockerVersion
29− assert $ isJust v
46+ lift $ assert $ isRight v
30
47
31findTestImage :: IO ()
48findTestImage :: IO ()
32−findTestImage = do images <- listImages opts
49+findTestImage = runDocker $ do
50+ images <- listImages defaultListOpts >>= fromRight
33− let x = fmap (filter ((== [test_image_name++":latest"]) . _repoTags)) images
51+ let x = filter ((== [testImageName<>":latest"]) . imageRepoTags) images
34− assert $ fmap length x == Just 1
52+ lift $ assert $ length x == 1
35
53
36runAndReadLog :: IO ()
54runAndReadLog :: IO ()
55+runAndReadLog = runDocker $ do
37−runAndReadLog = do containerId <- createContainer opts (defaultCreateOpts {_image = test_image_name++":latest"})
56+ containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest"))
38− assert $ isJust containerId
39− let c = unpack $ fromJust containerId
57+ c <- fromRight containerId
40− status1 <- startContainer opts c defaultStartOpts
58+ status1 <- startContainer defaultStartOpts c
41− threadDelay 300000 -- give 300ms for the application to finish
59+ lift $ threadDelay 300000 -- give 300ms for the application to finish
42− assert $ status1 == status204
60+ lift $ assert $ status1 == Right ()
43− status2 <- killContainer opts c
61+ status2 <- killContainer SIGTERM c
44− logs <- getContainerLogs opts c
62+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
45− assert $ status2 == status204
63+ lift $ assert $ status2 == Right ()
46− assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
64+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
47− status3 <- deleteContainer opts c
65+ status3 <- deleteContainer (DeleteOpts True True) c
48− assert $ status3 == status204
66+ lift $ assert $ status3 == Right ()
49
67
50
68
51tests :: TestTree
69tests :: TestTree
@@ -54,10 +72,19 @@ tests = testGroup "Metrics tests" [
54 testCase "Find image by name" findTestImage,
72 testCase "Find image by name" findTestImage,
55 testCase "Run a dummy container and read its log" runAndReadLog]
73 testCase "Run a dummy container and read its log" runAndReadLog]
56
74
57−setup :: IO()
75+setup :: IO ()
58−setup = system ("docker build -t "++test_image_name++" tests") >> return ()
76+setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
59
77
60−main :: IO()
78+main :: IO ()
61main = do
79main = do
62 setup
80 setup
63 defaultMain tests
81 defaultMain tests
82+
83+isRight (Left _) = False
84+isRight (Right _) = True
85+
86+fromRight :: (MonadIO m, Show l) => Either l r -> m r
87+fromRight (Left l) = do
88+ liftIO $ assertFailure $ "Left: " ++ show l
89+ undefined
90+fromRight (Right r) = return r