Merge pull request #79 from mbg/wait-timeout

Various improvements related to waitContainer
denibertovic · Apr 1, 2022 · 81e2f5d · 81e2f5d
2 parents 16924c5 + 458a9a3
commit 81e2f5d
Show file tree

Hide file tree

Showing 3 changed files with 21 additions and 2 deletions.
diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs
@@ -121,6 +121,10 @@ stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
 
 -- | 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
@@ -21,7 +21,8 @@ import           Data.X509.File               (readKeyFile, readSignedObject)
 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 qualified Network.Socket.ByteString    as SBS
 
 import           Docker.Client.Internal       (getEndpoint,
                                                getEndpointContentType,
-                                               getEndpointRequestBody)
+                                               getEndpointRequestBody,
+                                               getEndpointTimeout)
 import           Docker.Client.Types          (DockerClientOpts, Endpoint (..),
                                                apiVer, baseUrl)
 
@@ -101,6 +103,7 @@ mkHttpRequest verb e opts = request
               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

diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs
@@ -106,3 +106,15 @@ getEndpointContentType :: Endpoint -> BSC.ByteString
 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