docker 0.6.0.6 → 0.7.0.0
raw patch · 6 files changed
+111/−38 lines, 6 filesdep ~aesondep ~bytestringdep ~unliftio-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson, bytestring, unliftio-core
API changes (from Hackage documentation)
+ Docker.Client.Http: defaultUnixManagerSettings :: FilePath -> ManagerSettings
+ Docker.Client.Internal: getEndpointTimeout :: Endpoint -> ResponseTimeout
Files
- docker.cabal +4/−4
- src/Docker/Client/Api.hs +4/−0
- src/Docker/Client/Http.hs +21/−13
- src/Docker/Client/Internal.hs +12/−0
- src/Docker/Client/Types.hs +47/−16
- tests/tests.hs +23/−5
docker.cabal view
@@ -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
src/Docker/Client/Api.hs view
@@ -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
src/Docker/Client/Http.hs view
@@ -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?
src/Docker/Client/Internal.hs view
@@ -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
src/Docker/Client/Types.hs view
@@ -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
tests/tests.hs view
@@ -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