{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Docker.Client.Http where

-- import           Control.Monad.Base           (MonadBase(..), liftBaseDefault)
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,
                                               responseTimeout)
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,
                                               getEndpointTimeout)
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 -- ^ Could not parse the response from the Docker endpoint.
                 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
                 | GenericDockerError Text deriving (Int -> DockerError -> ShowS
[DockerError] -> ShowS
DockerError -> String
(Int -> DockerError -> ShowS)
-> (DockerError -> String)
-> ([DockerError] -> ShowS)
-> Show DockerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DockerError] -> ShowS
$cshowList :: [DockerError] -> ShowS
show :: DockerError -> String
$cshow :: DockerError -> String
showsPrec :: Int -> DockerError -> ShowS
$cshowsPrec :: Int -> DockerError -> ShowS
Show, Typeable)

newtype DockerT m a = DockerT {
        DockerT m a
-> Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
    } deriving (a -> DockerT m b -> DockerT m a
(a -> b) -> DockerT m a -> DockerT m b
(forall a b. (a -> b) -> DockerT m a -> DockerT m b)
-> (forall a b. a -> DockerT m b -> DockerT m a)
-> Functor (DockerT m)
forall a b. a -> DockerT m b -> DockerT m a
forall a b. (a -> b) -> DockerT m a -> DockerT m b
forall (m :: * -> *) a b.
Functor m =>
a -> DockerT m b -> DockerT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DockerT m a -> DockerT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DockerT m b -> DockerT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> DockerT m b -> DockerT m a
fmap :: (a -> b) -> DockerT m a -> DockerT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DockerT m a -> DockerT m b
Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans

instance Applicative m => Applicative (DockerT m) where
    pure :: a -> DockerT m a
pure a
a = (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT ((Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
 -> DockerT m a)
-> (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall a b. (a -> b) -> a -> b
$ a -> ReaderT (DockerClientOpts, HttpHandler m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    <*> :: DockerT m (a -> b) -> DockerT m a -> DockerT m b
(<*>) (DockerT Monad m => ReaderT (DockerClientOpts, HttpHandler m) m (a -> b)
f) (DockerT Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
v) =  (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
-> DockerT m b
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT ((Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
 -> DockerT m b)
-> (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
-> DockerT m b
forall a b. (a -> b) -> a -> b
$ ReaderT (DockerClientOpts, HttpHandler m) m (a -> b)
Monad m => ReaderT (DockerClientOpts, HttpHandler m) m (a -> b)
f ReaderT (DockerClientOpts, HttpHandler m) m (a -> b)
-> ReaderT (DockerClientOpts, HttpHandler m) m a
-> ReaderT (DockerClientOpts, HttpHandler m) m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT (DockerClientOpts, HttpHandler m) m a
Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
v

instance Monad m => Monad (DockerT m) where
    (DockerT Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
m) >>= :: DockerT m a -> (a -> DockerT m b) -> DockerT m b
>>= a -> DockerT m b
f = (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
-> DockerT m b
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT ((Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
 -> DockerT m b)
-> (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b)
-> DockerT m b
forall a b. (a -> b) -> a -> b
$ ReaderT (DockerClientOpts, HttpHandler m) m a
Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
m ReaderT (DockerClientOpts, HttpHandler m) m a
-> (a -> ReaderT (DockerClientOpts, HttpHandler m) m b)
-> ReaderT (DockerClientOpts, HttpHandler m) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> DockerT m b
-> Monad m => ReaderT (DockerClientOpts, HttpHandler m) m b
forall (m :: * -> *) a.
DockerT m a
-> Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
unDockerT (a -> DockerT m b
f a
x)
    return :: a -> DockerT m a
return = a -> DockerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where
    ask :: DockerT m (DockerClientOpts, HttpHandler m)
ask = (Monad m =>
 ReaderT
   (DockerClientOpts, HttpHandler m)
   m
   (DockerClientOpts, HttpHandler m))
-> DockerT m (DockerClientOpts, HttpHandler m)
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT Monad m =>
ReaderT
  (DockerClientOpts, HttpHandler m)
  m
  (DockerClientOpts, HttpHandler m)
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: ((DockerClientOpts, HttpHandler m)
 -> (DockerClientOpts, HttpHandler m))
-> DockerT m a -> DockerT m a
local (DockerClientOpts, HttpHandler m)
-> (DockerClientOpts, HttpHandler m)
f (DockerT Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
m) = (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT ((Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
 -> DockerT m a)
-> (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall a b. (a -> b) -> a -> b
$ ((DockerClientOpts, HttpHandler m)
 -> (DockerClientOpts, HttpHandler m))
-> ReaderT (DockerClientOpts, HttpHandler m) m a
-> ReaderT (DockerClientOpts, HttpHandler m) m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (DockerClientOpts, HttpHandler m)
-> (DockerClientOpts, HttpHandler m)
f ReaderT (DockerClientOpts, HttpHandler m) m a
Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
m

instance MonadTrans DockerT where
    lift :: m a -> DockerT m a
lift m a
m = (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall (m :: * -> *) a.
(Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
DockerT ((Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
 -> DockerT m a)
-> (Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a)
-> DockerT m a
forall a b. (a -> b) -> a -> b
$ m a -> ReaderT (DockerClientOpts, HttpHandler m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m

instance MonadIO m => MonadIO (DockerT m) where
    liftIO :: IO a -> DockerT m a
liftIO = m a -> DockerT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DockerT m a) -> (IO a -> m a) -> IO a -> DockerT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- instance MonadBase IO m => MonadBase IO (DockerT m) where
--     liftBase = liftBaseDefault

runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
runDockerT :: (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
runDockerT (DockerClientOpts
opts, HttpHandler m
h) DockerT m a
r = ReaderT (DockerClientOpts, HttpHandler m) m a
-> (DockerClientOpts, HttpHandler m) -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DockerT m a
-> Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
forall (m :: * -> *) a.
DockerT m a
-> Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
unDockerT DockerT m a
r) (DockerClientOpts
opts, HttpHandler m
h)

-- The reason we return Maybe Request is because the parseURL function
-- might find out parameters are invalid and will fail to build a Request
-- Since we are the ones building the Requests this shouldn't happen, but would
-- benefit from testing that on all of our Endpoints
mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
mkHttpRequest HttpVerb
verb Endpoint
e DockerClientOpts
opts = Maybe Request
request
        where fullE :: String
fullE = Text -> String
T.unpack (DockerClientOpts -> Text
baseUrl DockerClientOpts
opts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Text -> Endpoint -> Text
getEndpoint (DockerClientOpts -> Text
apiVer DockerClientOpts
opts) Endpoint
e)
              initialR :: Maybe Request
initialR = String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
fullE
              request' :: Maybe Request
request' = case  Maybe Request
initialR of
                            Just ir ->
                                Request -> Maybe Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Maybe Request) -> Request -> Maybe Request
forall a b. (a -> b) -> a -> b
$ Request
ir {method :: Method
method = (Text -> Method
encodeUtf8 (Text -> Method) -> (String -> Text) -> String -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ HttpVerb -> String
forall a. Show a => a -> String
show HttpVerb
verb),
                                              responseTimeout :: ResponseTimeout
responseTimeout = Endpoint -> ResponseTimeout
getEndpointTimeout Endpoint
e,
                                              requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"Content-Type", (Endpoint -> Method
getEndpointContentType Endpoint
e))]}
                            Maybe Request
Nothing -> Maybe Request
forall a. Maybe a
Nothing
              request :: Maybe Request
request = (\Request
r -> Request -> (RequestBody -> Request) -> Maybe RequestBody -> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request
r (\RequestBody
body -> Request
r {requestBody :: RequestBody
requestBody = RequestBody
body,  -- This will either be a HTTP.RequestBodyLBS  or HTTP.RequestBodySourceChunked for the build endpoint
                                                    requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"Content-Type", Method
"application/json; charset=utf-8")]}) (Maybe RequestBody -> Request) -> Maybe RequestBody -> Request
forall a b. (a -> b) -> a -> b
$ Endpoint -> Maybe RequestBody
getEndpointRequestBody Endpoint
e) (Request -> Request) -> Maybe Request -> Maybe Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Request
request'
              -- Note: Do we need to set length header?

defaultHttpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
    MonadUnliftIO m, 
#endif
    MonadIO m, MonadMask m) => m (HttpHandler m)
defaultHttpHandler :: m (HttpHandler m)
defaultHttpHandler = do
    Manager
manager <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
    HttpHandler m -> m (HttpHandler m)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpHandler m -> m (HttpHandler m))
-> HttpHandler m -> m (HttpHandler m)
forall a b. (a -> b) -> a -> b
$ Manager -> HttpHandler m
forall (m :: * -> *).
(MonadUnliftIO m, MonadIO m, MonadMask m) =>
Manager -> HttpHandler m
httpHandler Manager
manager

httpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
    MonadUnliftIO m, 
#endif
    MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
httpHandler :: Manager -> HttpHandler m
httpHandler Manager
manager = (forall a.
 Request
 -> (Response () -> Sink Method m (Either DockerError a))
 -> m (Either DockerError a))
-> HttpHandler m
forall (m :: * -> *).
(forall a.
 Request
 -> (Response () -> Sink Method m (Either DockerError a))
 -> m (Either DockerError a))
-> HttpHandler m
HttpHandler ((forall a.
  Request
  -> (Response () -> Sink Method m (Either DockerError a))
  -> m (Either DockerError a))
 -> HttpHandler m)
-> (forall a.
    Request
    -> (Response () -> Sink Method m (Either DockerError a))
    -> m (Either DockerError a))
-> HttpHandler m
forall a b. (a -> b) -> a -> b
$ \Request
request' Response () -> Sink Method m (Either DockerError a)
sink -> do -- runResourceT ..
    let request :: Request
request = Manager -> Request -> Request
NHS.setRequestManager Manager
manager Request
request'
    m (Either DockerError a)
-> m (Either HttpException (Either DockerError a))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (Request
-> (Response () -> Sink Method m (Either DockerError a))
-> m (Either DockerError a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM Method Void m a) -> m a
NHS.httpSink Request
request Response () -> Sink Method m (Either DockerError a)
sink) m (Either HttpException (Either DockerError a))
-> (Either HttpException (Either DockerError a)
    -> m (Either DockerError a))
-> m (Either DockerError a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either HttpException (Either DockerError a)
res -> case Either HttpException (Either DockerError a)
res of
        Right Either DockerError a
res                              -> Either DockerError a -> m (Either DockerError a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either DockerError a
res
#if MIN_VERSION_http_client(0,5,0)
        Left e :: HttpException
e@(HTTP.HttpExceptionRequest Request
_ HTTP.ConnectionFailure{})  -> Either DockerError a -> m (Either DockerError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DockerError a -> m (Either DockerError a))
-> Either DockerError a -> m (Either DockerError a)
forall a b. (a -> b) -> a -> b
$ DockerError -> Either DockerError a
forall a b. a -> Either a b
Left (DockerError -> Either DockerError a)
-> DockerError -> Either DockerError a
forall a b. (a -> b) -> a -> b
$ HttpException -> DockerError
DockerConnectionError HttpException
e
#else
        Left e@HTTP.FailedConnectionException{}  -> return $ Left $ DockerConnectionError e
        Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
#endif
        Left HttpException
e                                 -> Either DockerError a -> m (Either DockerError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DockerError a -> m (Either DockerError a))
-> Either DockerError a -> m (Either DockerError a)
forall a b. (a -> b) -> a -> b
$ DockerError -> Either DockerError a
forall a b. a -> Either a b
Left (DockerError -> Either DockerError a)
-> DockerError -> Either DockerError a
forall a b. (a -> b) -> a -> b
$ Text -> DockerError
GenericDockerError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
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 :: String -> ManagerSettings
defaultUnixManagerSettings String
fp = ManagerSettings
defaultManagerSettings {
    managerRawConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerRawConnection = (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe HostAddress -> String -> Int -> IO Connection)
 -> IO (Maybe HostAddress -> String -> Int -> IO Connection))
-> (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall a b. (a -> b) -> a -> b
$ String -> Maybe HostAddress -> String -> Int -> IO Connection
forall p p p. String -> p -> p -> p -> IO Connection
openUnixSocket String
fp
} where openUnixSocket :: String -> p -> p -> p -> IO Connection
openUnixSocket String
filePath p
_ p
_ p
_ = do
            Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Stream ProtocolNumber
S.defaultProtocol
            Socket -> SockAddr -> IO ()
S.connect Socket
s (String -> SockAddr
S.SockAddrUnix String
filePath)
            IO Method -> (Method -> IO ()) -> IO () -> IO Connection
makeConnection (Socket -> Int -> IO Method
SBS.recv Socket
s Int
8096)
                            (Socket -> Method -> IO ()
SBS.sendAll Socket
s)
                            (Socket -> IO ()
S.close Socket
s)

-- | Connect to a unix domain socket (the default docker socket is
--   at \/var\/run\/docker.sock)
--
--   Docker seems to ignore the hostname in requests sent over unix domain
--   sockets (and the port obviously doesn't matter either)
unixHttpHandler :: (
#if MIN_VERSION_http_conduit(2,3,0)
    MonadUnliftIO m, 
#endif
    MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
                -> m (HttpHandler m)
unixHttpHandler :: String -> m (HttpHandler m)
unixHttpHandler String
fp = do
  let mSettings :: ManagerSettings
mSettings = String -> ManagerSettings
defaultUnixManagerSettings String
fp
  Manager
manager <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
mSettings
  HttpHandler m -> m (HttpHandler m)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpHandler m -> m (HttpHandler m))
-> HttpHandler m -> m (HttpHandler m)
forall a b. (a -> b) -> a -> b
$ Manager -> HttpHandler m
forall (m :: * -> *).
(MonadUnliftIO m, MonadIO m, MonadMask m) =>
Manager -> HttpHandler m
httpHandler Manager
manager

-- TODO:
--  Move this to http-client-tls or network?
--  Add CA.
--  Maybe change this to: HostName -> PortNumber -> ClientParams -> IO (Either String TLSSettings)
clientParamsWithClientAuthentication :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO (Either String ClientParams)
clientParamsWithClientAuthentication :: String
-> PortNumber
-> String
-> String
-> IO (Either String ClientParams)
clientParamsWithClientAuthentication String
host PortNumber
port String
keyFile String
certificateFile = do
    [PrivKey]
keys <- String -> IO [PrivKey]
readKeyFile String
keyFile
    [SignedExact Certificate]
cert <- String -> IO [SignedExact Certificate]
forall a.
(ASN1Object a, Eq a, Show a) =>
String -> IO [SignedExact a]
readSignedObject String
certificateFile
    case [PrivKey]
keys of
        [PrivKey
key] ->
            -- TODO: load keys/path from file
            let params :: ClientParams
params = (String -> Method -> ClientParams
defaultParamsClient String
host (Method -> ClientParams) -> Method -> ClientParams
forall a b. (a -> b) -> a -> b
$ String -> Method
BSC.pack (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port) {
                    clientHooks :: ClientHooks
clientHooks = ClientHooks
forall a. Default a => a
def
                        { onCertificateRequest :: OnCertificateRequest
onCertificateRequest = \([CertificateType], Maybe [HashAndSignatureAlgorithm],
 [DistinguishedName])
_ -> Maybe (CertificateChain, PrivKey)
-> IO (Maybe (CertificateChain, PrivKey))
forall (m :: * -> *) a. Monad m => a -> m a
return ((CertificateChain, PrivKey) -> Maybe (CertificateChain, PrivKey)
forall a. a -> Maybe a
Just ([SignedExact Certificate] -> CertificateChain
CertificateChain [SignedExact Certificate]
cert, PrivKey
key))}
                  , clientSupported :: Supported
clientSupported = Supported
forall a. Default a => a
def
                        { supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_strong}
                  }
            in
            Either String ClientParams -> IO (Either String ClientParams)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ClientParams -> IO (Either String ClientParams))
-> Either String ClientParams -> IO (Either String ClientParams)
forall a b. (a -> b) -> a -> b
$ ClientParams -> Either String ClientParams
forall a b. b -> Either a b
Right ClientParams
params
        [PrivKey]
_ ->
            Either String ClientParams -> IO (Either String ClientParams)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ClientParams -> IO (Either String ClientParams))
-> Either String ClientParams -> IO (Either String ClientParams)
forall a b. (a -> b) -> a -> b
$ String -> Either String ClientParams
forall a b. a -> Either a b
Left (String -> Either String ClientParams)
-> String -> Either String ClientParams
forall a b. (a -> b) -> a -> b
$ String
"Could not read key file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
keyFile

clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams
clientParamsSetCA :: ClientParams -> String -> IO ClientParams
clientParamsSetCA ClientParams
params String
path = do
    CertificateStore
userStore <- [SignedExact Certificate] -> CertificateStore
makeCertificateStore ([SignedExact Certificate] -> CertificateStore)
-> IO [SignedExact Certificate] -> IO CertificateStore
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [SignedExact Certificate]
forall a.
(ASN1Object a, Eq a, Show a) =>
String -> IO [SignedExact a]
readSignedObject String
path
    CertificateStore
systemStore <- IO CertificateStore
getSystemCertificateStore
    let store :: CertificateStore
store = CertificateStore
userStore CertificateStore -> CertificateStore -> CertificateStore
forall a. Semigroup a => a -> a -> a
<> CertificateStore
systemStore
    let oldShared :: Shared
oldShared = ClientParams -> Shared
clientShared ClientParams
params
    ClientParams -> IO ClientParams
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientParams -> IO ClientParams)
-> ClientParams -> IO ClientParams
forall a b. (a -> b) -> a -> b
$ ClientParams
params { clientShared :: Shared
clientShared = Shared
oldShared
            { sharedCAStore :: CertificateStore
sharedCAStore = CertificateStore
store }
        }


-- If the status is an error, returns a Just DockerError. Otherwise, returns Nothing.
statusCodeToError :: Endpoint -> HTTP.Status -> Maybe DockerError
statusCodeToError :: Endpoint -> Status -> Maybe DockerError
statusCodeToError Endpoint
VersionEndpoint Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (ListContainersEndpoint ListOpts
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (ListImagesEndpoint ListOpts
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (CreateContainerEndpoint CreateOpts
_ Maybe Text
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status201 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (StartContainerEndpoint StartOpts
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (StopContainerEndpoint Timeout
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (WaitContainerEndpoint ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (KillContainerEndpoint Signal
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (RestartContainerEndpoint Timeout
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (PauseContainerEndpoint ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (UnpauseContainerEndpoint ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (ContainerLogsEndpoint LogOpts
_ Bool
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 Bool -> Bool -> Bool
|| Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status101 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (DeleteContainerEndpoint ContainerDeleteOpts
_ ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (InspectContainerEndpoint ContainerID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (BuildImageEndpoint BuildOpts
_ String
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (CreateImageEndpoint Text
_ Text
_ Maybe Text
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (DeleteImageEndpoint ImageDeleteOpts
_ ImageID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (CreateNetworkEndpoint CreateNetworkOpts
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status201 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st
statusCodeToError (RemoveNetworkEndpoint NetworkID
_) Status
st =
    if Status
st Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status204 then
        Maybe DockerError
forall a. Maybe a
Nothing
    else
        DockerError -> Maybe DockerError
forall a. a -> Maybe a
Just (DockerError -> Maybe DockerError)
-> DockerError -> Maybe DockerError
forall a b. (a -> b) -> a -> b
$ Status -> DockerError
DockerInvalidStatusCode Status
st