diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -1,5 +1,5 @@ name: docker -version: 0.6.0.6 +version: 0.7.0.0 synopsis: An API client for docker written in Haskell description: See API documentation below. homepage: https://github.com/denibertovic/docker-hs @@ -25,9 +25,9 @@ exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils -- other-modules: Docker.Internal build-depends: base >= 4.7 && < 5 - , aeson >= 0.9.0 && < 2.0.0 + , aeson >= 0.9.0 && < 3.0.0 , blaze-builder >= 0.4.0 && < 0.5.0 - , bytestring >= 0.10.0 && < 0.11.0 + , bytestring >= 0.10.0 && < 0.12.0 , containers >= 0.5.0 && < 0.7.0 , data-default-class >= 0.0.1 && < 0.2.0 , http-client >= 0.4.0 && < 0.8.0 @@ -59,7 +59,7 @@ , x509-store >= 1.6.0 && < 1.8.0 , x509-system >= 1.6.0 && < 1.8.0 , http-conduit - , unliftio-core >= 0.1.0.0 && < 0.2.0 + , unliftio-core >= 0.1.0.0 && < 0.3.0 -- if flag(small-http-conduit) -- build-depends: http-conduit < 2.3.0 -- else diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -121,6 +121,10 @@ -- | Blocks until a container with the given 'ContainerID' stops, -- then returns the exit code +-- +-- __NOTE__: this endpoint will not return a response until the container +-- has stopped. This function may therefore fail with a timeout error if +-- the timeout is configured incorrectly in the HTTP manager. waitContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ExitCode) waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse) where diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -21,7 +21,8 @@ import Network.HTTP.Client (defaultManagerSettings, managerRawConnection, method, newManager, parseRequest, - requestBody, requestHeaders) + requestBody, requestHeaders, + responseTimeout) import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.Internal (makeConnection) import qualified Network.HTTP.Simple as NHS @@ -46,7 +47,8 @@ import Docker.Client.Internal (getEndpoint, getEndpointContentType, - getEndpointRequestBody) + getEndpointRequestBody, + getEndpointTimeout) import Docker.Client.Types (DockerClientOpts, Endpoint (..), apiVer, baseUrl) @@ -71,7 +73,7 @@ (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v instance Monad m => Monad (DockerT m) where - (DockerT m) >>= f = DockerT $ m >>= unDockerT . f + (DockerT m) >>= f = DockerT $ m >>= \x -> unDockerT (f x) return = pure instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where @@ -101,6 +103,7 @@ request' = case initialR of Just ir -> return $ ir {method = (encodeUtf8 . T.pack $ show verb), + responseTimeout = getEndpointTimeout e, requestHeaders = [("Content-Type", (getEndpointContentType e))]} Nothing -> Nothing request = (\r -> maybe r (\body -> r {requestBody = body, -- This will either be a HTTP.RequestBodyLBS or HTTP.RequestBodySourceChunked for the build endpoint @@ -133,6 +136,20 @@ #endif Left e -> return $ Left $ GenericDockerError (T.pack $ show e) +-- | Use 'httpHandler' with 'defaultUnixManagerSettings' @unixSocketPath@ as +-- argument as an alternative to 'unixHttpHandler' that lets you customise +-- the settings of the 'HTTP.ManagerSettings' value that is returned. +defaultUnixManagerSettings :: FilePath -- ^ The socket to connect to + -> HTTP.ManagerSettings +defaultUnixManagerSettings fp = defaultManagerSettings { + managerRawConnection = return $ openUnixSocket fp +} where openUnixSocket filePath _ _ _ = do + s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect s (S.SockAddrUnix filePath) + makeConnection (SBS.recv s 8096) + (SBS.sendAll s) + (S.close s) + -- | Connect to a unix domain socket (the default docker socket is -- at \/var\/run\/docker.sock) -- @@ -145,18 +162,9 @@ MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to -> m (HttpHandler m) unixHttpHandler fp = do - let mSettings = defaultManagerSettings - { managerRawConnection = return $ openUnixSocket fp} + let mSettings = defaultUnixManagerSettings fp manager <- liftIO $ newManager mSettings return $ httpHandler manager - - where - openUnixSocket filePath _ _ _ = do - s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol - S.connect s (S.SockAddrUnix filePath) - makeConnection (SBS.recv s 8096) - (SBS.sendAll s) - (S.close s) -- TODO: -- Move this to http-client-tls or network? diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -106,3 +106,15 @@ getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" getEndpointContentType _ = BSC.pack "application/json; charset=utf-8" +#if MIN_VERSION_http_client(0,5,0) +getEndpointTimeout :: Endpoint -> HTTP.ResponseTimeout +getEndpointTimeout (WaitContainerEndpoint _) = HTTP.responseTimeoutNone +getEndpointTimeout _ = HTTP.responseTimeoutDefault +#else +-- Prior to version 0.5.0 of `http-client`, `ResponseTimeout` does not exist +-- and we can't easily say "use the manager setting" here. So this is a bit +-- ugly and only exists for the sake of backwards compatibility. +getEndpointTimeout :: Endpoint -> Maybe Int +getEndpointTimeout (WaitContainerEndpoint _) = Nothing +getEndpointTimeout _ = Just 30000000 +#endif diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -104,7 +104,11 @@ genericToJSON, object, parseJSON, toJSON, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as JSON -import Data.Aeson.Types (defaultOptions, fieldLabelModifier) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +#endif +import Data.Aeson.Types (emptyObject, defaultOptions, fieldLabelModifier) import Data.Char (isAlphaNum, toUpper) import qualified Data.HashMap.Strict as HM import Data.Maybe (fromMaybe) @@ -461,7 +465,7 @@ deriving (Eq, Show) instance {-# OVERLAPPING #-} FromJSON [Network] where - parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) (toHashMap o) where f accM k' v' = do acc <- accM @@ -576,13 +580,13 @@ -- If there are multiple lables with the same Name in the list -- then the last one wins. instance {-# OVERLAPPING #-} ToJSON [Label] where - toJSON [] = emptyJsonObject + toJSON [] = emptyObject toJSON (l:ls) = toJsonKeyVal (l:ls) key val where key (Label k _) = T.unpack k val (Label _ v) = v instance {-# OVERLAPPING #-} FromJSON [Label] where - parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) (toHashMap o) where f accM k v = do acc <- accM value <- parseJSON v @@ -660,9 +664,14 @@ let ccJSON = toJSON cc let hcJSON = toJSON hc case ccJSON of - JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do + JSON.Object o -> do +#if MIN_VERSION_aeson(2,0,0) + let o1 = KM.insert "HostConfig" hcJSON o + let o2 = KM.insert "NetworkingConfig" (toJSON nc) o1 +#else let o1 = HM.insert "HostConfig" hcJSON o let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1 +#endif JSON.Object o2 _ -> error "ContainerConfig is not an object." -- This should never happen. @@ -888,12 +897,16 @@ newtype Volume = Volume FilePath deriving (Eq, Show) instance {-# OVERLAPPING #-} ToJSON [Volume] where - toJSON [] = emptyJsonObject + toJSON [] = emptyObject toJSON (v:vs) = toJsonKey (v:vs) getKey where getKey (Volume v) = v instance {-# OVERLAPPING #-} FromJSON [Volume] where +#if MIN_VERSION_aeson(2,0,0) + parseJSON (JSON.Object o) = return $ map (Volume . K.toString) $ KM.keys o +#else parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o +#endif parseJSON (JSON.Null) = return [] parseJSON _ = fail "Volume is not an object" @@ -993,13 +1006,13 @@ data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show) instance {-# OVERLAPPING #-} ToJSON [LogDriverOption] where - toJSON [] = emptyJsonObject + toJSON [] = emptyObject toJSON (o:os) = toJsonKeyVal (o:os) key val where key (LogDriverOption n _) = T.unpack n val (LogDriverOption _ v) = v instance {-# OVERLAPPING #-} FromJSON [LogDriverOption] where - parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) (toHashMap o) where f accM k v = do acc <- accM value <- parseJSON v @@ -1153,7 +1166,7 @@ instance {-# OVERLAPPING #-} FromJSON [PortBinding] where - parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) (toHashMap o) where f accM k v = case T.split (== '/') k of [port', portType'] -> do @@ -1167,7 +1180,7 @@ parseJSON _ = fail "PortBindings is not an object" instance {-# OVERLAPPING #-} ToJSON [PortBinding] where - toJSON [] = emptyJsonObject + toJSON [] = emptyObject toJSON (p:ps) = toJsonKeyVal (p:ps) key val where key p = T.unpack $ portAndType2Text (containerPort p) (portType p) val p = hostPorts p @@ -1478,7 +1491,7 @@ data ExposedPort = ExposedPort Port PortType deriving (Eq, Show) instance {-# OVERLAPPING #-} FromJSON [ExposedPort] where - parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o + parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) (toHashMap o) where f accM k _ = case T.split (== '/') k of [port', portType'] -> do @@ -1491,7 +1504,7 @@ parseJSON _ = fail "ExposedPorts is not an object" instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where - toJSON [] = emptyJsonObject + toJSON [] = emptyObject toJSON (p:ps) = toJsonKey (p:ps) key where key (ExposedPort p t) = show p <> slash <> show t slash = T.unpack "/" @@ -1582,15 +1595,33 @@ -- | Helper function for converting a data type [a] to a json dictionary -- like so {"something": {}, "something2": {}} toJsonKey :: Foldable t => t a -> (a -> String) -> JSON.Value +#if MIN_VERSION_aeson(2,0,0) +toJsonKey vs getKey = JSON.Object $ foldl f KM.empty vs + where f acc x = KM.insert (K.fromText $ T.pack $ getKey x) emptyObject acc +#else toJsonKey vs getKey = JSON.Object $ foldl f HM.empty vs - where f acc x = HM.insert (T.pack $ getKey x) (JSON.Object HM.empty) acc + where f acc x = HM.insert (T.pack $ getKey x) emptyObject acc +#endif -- | Helper function for converting a data type [a] to a json dictionary -- like so {"something": "val1", "something2": "val2"} toJsonKeyVal :: (Foldable t, JSON.ToJSON r) => t a -> (a -> String) -> (a -> r) -> JSON.Value +#if MIN_VERSION_aeson(2,0,0) +toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f KM.empty vs + where f acc x = KM.insert (K.fromString $ getKey x) (toJSON $ getVal x) acc +#else toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs where f acc x = HM.insert (T.pack $ getKey x) (toJSON $ getVal x) acc +#endif --- | Helper function that return an empty dictionary "{}" -emptyJsonObject :: JSON.Value -emptyJsonObject = JSON.Object HM.empty +-- | Helper function to convert from aeson's new @KeyMap@ type to an ordinary +-- @HashMap@. A no-op for older versions of aeson. Used to avoid CPP everywhere +-- and @KeyMap@ has no equivalent of @foldlWithKey'@ so even more code changes +-- would be required. +#if MIN_VERSION_aeson(2,0,0) +toHashMap :: KM.KeyMap v -> HM.HashMap T.Text v +toHashMap = KM.toHashMapText +#else +toHashMap :: HM.HashMap T.Text v -> HM.HashMap T.Text v +toHashMap = id +#endif diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Data.Either (rights) +import Data.String (IsString(..)) import Prelude hiding (all) import qualified Test.QuickCheck.Monadic as QCM import Test.Tasty @@ -16,8 +18,12 @@ import Control.Monad.Trans.Class (lift) import qualified Data.Aeson as JSON import Data.Aeson ((.=)) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM +#endif import Data.Aeson.Lens (key, _Array, _Null, _Object, _String, _Value) +import qualified Data.Aeson.Types as JSON import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as BL @@ -38,6 +44,14 @@ import Docker.Client +#if MIN_VERSION_lens_aeson(1,2,0) +emptyMap :: KM.KeyMap v +emptyMap = KM.empty +#else +emptyMap :: HM.HashMap k v +emptyMap = HM.empty +#endif + -- opts = defaultClientOpts testImageName = "docker-hs/test" imageToDeleteFullName = "hello-world:latest" @@ -51,7 +65,7 @@ -- let settings = mkManagerSettings (TLSSettings params) Nothing -- mgr <- newManager settings = do - h <- defaultHttpHandler + h <- unixHttpHandler "/var/run/docker.sock" runDockerT (defaultClientOpts, h) f testDockerVersion :: IO () @@ -153,17 +167,19 @@ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override" sample = [LogDriverOption key1 val1, LogDriverOption key2 val2] sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"] + key1 :: IsString a => a key1 = "some-key" val1 = "some-val" + key2 :: IsString a => a key2 = "some-key2" val2 = "some-key2" testExposedPortsJson :: TestTree testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP] where - testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty + testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == emptyMap testUDP = - testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty + testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == emptyMap sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP] testLabelsJson :: TestTree @@ -177,8 +193,10 @@ _String == "override" sampleLS = [Label key1 val1, Label key2 val2] + key1 :: IsString a => a key1 = "com.example.some-label" val1 = "some-value" + key2 :: IsString a => a key2 = "something" val2 = "value" @@ -187,10 +205,10 @@ where testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == - HM.empty + emptyMap testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == - HM.empty + emptyMap sampleVolumes = [Volume "/tmp", Volume "/opt"] testBindsJson :: TestTree