module Docker.Client.Http where
import Control.Monad.Catch (MonadMask (..))
#if MIN_VERSION_http_conduit(2,3,0)
import Control.Monad.IO.Unlift (MonadUnliftIO)
#endif
import Control.Monad.Reader (ReaderT (..), runReaderT)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (Sink)
import Data.Default.Class (def)
import Data.Monoid ((<>))
import Data.Text.Encoding (encodeUtf8)
import Data.X509 (CertificateChain (..))
import Data.X509.CertificateStore (makeCertificateStore)
import Data.X509.File (readKeyFile, readSignedObject)
import Network.HTTP.Client (defaultManagerSettings,
managerRawConnection, method,
newManager, parseRequest,
requestBody, requestHeaders)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Internal (makeConnection)
import qualified Network.HTTP.Simple as NHS
import Network.HTTP.Types (StdMethod, status101, status200,
status201, status204)
import Network.TLS (ClientHooks (..),
ClientParams (..), Shared (..),
Supported (..),
defaultParamsClient)
import Network.TLS.Extra (ciphersuite_strong)
import System.X509 (getSystemCertificateStore)
import Control.Monad.Catch (try)
import Control.Monad.Except
import Control.Monad.Reader.Class
import Data.Text as T
import Data.Typeable (Typeable)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SBS
import Docker.Client.Internal (getEndpoint,
getEndpointContentType,
getEndpointRequestBody)
import Docker.Client.Types (DockerClientOpts, Endpoint (..),
apiVer, baseUrl)
type Request = HTTP.Request
type Response = HTTP.Response BL.ByteString
type HttpVerb = StdMethod
newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))
data DockerError = DockerConnectionError NHS.HttpException
| DockerInvalidRequest Endpoint
| DockerClientError Text
| DockerClientDecodeError Text
| DockerInvalidStatusCode HTTP.Status
| GenericDockerError Text deriving (Show, Typeable)
newtype DockerT m a = DockerT {
unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
} deriving (Functor)
instance Applicative m => Applicative (DockerT m) where
pure a = DockerT $ pure a
(<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v
instance Monad m => Monad (DockerT m) where
(DockerT m) >>= f = DockerT $ m >>= unDockerT . f
return = pure
instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where
ask = DockerT ask
local f (DockerT m) = DockerT $ local f m
instance MonadTrans DockerT where
lift m = DockerT $ lift m
instance MonadIO m => MonadIO (DockerT m) where
liftIO = lift . liftIO
runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
mkHttpRequest verb e opts = request
where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)
initialR = parseRequest fullE
request' = case initialR of
Just ir ->
return $ ir {method = (encodeUtf8 . T.pack $ show verb),
requestHeaders = [("Content-Type", (getEndpointContentType e))]}
Nothing -> Nothing
request = (\r -> maybe r (\body -> r {requestBody = body,
requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
defaultHttpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
MonadUnliftIO m,
#endif
MonadIO m, MonadMask m) => m (HttpHandler m)
defaultHttpHandler = do
manager <- liftIO $ newManager defaultManagerSettings
return $ httpHandler manager
httpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
MonadUnliftIO m,
#endif
MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
httpHandler manager = HttpHandler $ \request' sink -> do
let request = NHS.setRequestManager manager request'
try (NHS.httpSink request sink) >>= \res -> case res of
Right res -> return res
#if MIN_VERSION_http_client(0,5,0)
Left e@(HTTP.HttpExceptionRequest _ HTTP.ConnectionFailure{}) -> return $ Left $ DockerConnectionError e
#else
Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
#endif
Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
unixHttpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
MonadUnliftIO m,
#endif
MonadIO m, MonadMask m) => FilePath
-> m (HttpHandler m)
unixHttpHandler fp = do
let mSettings = defaultManagerSettings
{ managerRawConnection = return $ openUnixSocket 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)
clientParamsWithClientAuthentication :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO (Either String ClientParams)
clientParamsWithClientAuthentication host port keyFile certificateFile = do
keys <- readKeyFile keyFile
cert <- readSignedObject certificateFile
case keys of
[key] ->
let params = (defaultParamsClient host $ BSC.pack $ show port) {
clientHooks = def
{ onCertificateRequest = \_ -> return (Just (CertificateChain cert, key))}
, clientSupported = def
{ supportedCiphers = ciphersuite_strong}
}
in
return $ Right params
_ ->
return $ Left $ "Could not read key file: " ++ keyFile
clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams
clientParamsSetCA params path = do
userStore <- makeCertificateStore <$> readSignedObject path
systemStore <- getSystemCertificateStore
let store = userStore <> systemStore
let oldShared = clientShared params
return $ params { clientShared = oldShared
{ sharedCAStore = store }
}
statusCodeToError :: Endpoint -> HTTP.Status -> Maybe DockerError
statusCodeToError VersionEndpoint st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (ListContainersEndpoint _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (ListImagesEndpoint _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (CreateContainerEndpoint _ _) st =
if st == status201 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (StartContainerEndpoint _ _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (StopContainerEndpoint _ _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (WaitContainerEndpoint _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (KillContainerEndpoint _ _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (RestartContainerEndpoint _ _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (PauseContainerEndpoint _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (UnpauseContainerEndpoint _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (ContainerLogsEndpoint _ _ _) st =
if st == status200 || st == status101 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (DeleteContainerEndpoint _ _) st =
if st == status204 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (InspectContainerEndpoint _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (BuildImageEndpoint _ _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st
statusCodeToError (CreateImageEndpoint _ _ _) st =
if st == status200 then
Nothing
else
Just $ DockerInvalidStatusCode st