mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-10-26 10:58:14 +03:00
WIP: Adds ongoing work on refactoring the http client
Does not compile yet.
This commit is contained in:
parent
3526503fff
commit
05b211f0d1
@ -17,9 +17,14 @@ getDockerVersion :: forall m. Monad m => DockerT m DockerVersion
|
||||
getDockerVersion = do
|
||||
(opts, httpHandler) <- ask
|
||||
let request = fromJust $ mkHttpRequest GET VersionEndpoint opts
|
||||
response <- lift . lift $ (httpHandler request :: m Response)
|
||||
let res = decode $ responseBody response
|
||||
return $ fromJust res
|
||||
response <- lift $ httpHandler request
|
||||
-- let res = decode $ responseBody response
|
||||
-- return $ fromJust res
|
||||
case response of
|
||||
Right r -> do
|
||||
let res = decode $ responseBody r
|
||||
fromJust res
|
||||
Left err -> err
|
||||
|
||||
listContainers :: forall m. Monad m => ListOpts -> DockerT m [Container]
|
||||
listContainers lopts = do
|
||||
|
@ -1,30 +1,70 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Docker.Http where
|
||||
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.HTTP.Client (defaultManagerSettings, httpLbs,
|
||||
managerRawConnection, method, newManager,
|
||||
parseUrl)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Types (StdMethod)
|
||||
import Control.Exception (catch, throw)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.HTTP.Client (defaultManagerSettings, httpLbs,
|
||||
managerRawConnection, method,
|
||||
newManager, parseUrl)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Types (StdMethod)
|
||||
|
||||
import Docker.Internal (getEndpoint)
|
||||
import Docker.Types (DockerClientOpts, Endpoint, baseUrl)
|
||||
-- import Control.Monad.Except (ExceptT, MonadError, MonadError,
|
||||
-- catchError, lift, runExceptT,
|
||||
-- throwError, throwError)
|
||||
import Control.Applicative
|
||||
import Control.Exception (catch, try)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
-- import Control.Monad.Reader (ReaderT, runReaderT)
|
||||
-- import Control.Monad.Reader.Class (MonadReader)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Typeable (Typeable)
|
||||
import Network.HTTP.Client (defaultManagerSettings, httpLbs,
|
||||
method, newManager, parseUrl)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Types (StdMethod)
|
||||
import System.IO.Error (catchIOError, ioError)
|
||||
|
||||
import Docker.Internal (getEndpoint)
|
||||
import Docker.Types (DockerClientOpts, Endpoint,
|
||||
baseUrl)
|
||||
|
||||
type Request = HTTP.Request
|
||||
type Response = HTTP.Response BL.ByteString
|
||||
type HttpVerb = StdMethod
|
||||
type HttpHandler m = Request -> m Response
|
||||
type HttpHandler m = Request -> m (Either DockerError Response)
|
||||
|
||||
type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT String m) a
|
||||
data DockerError = DockerConnectionError
|
||||
| GenericDockerError Text deriving (Eq, Show, Typeable)
|
||||
|
||||
runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either String a)
|
||||
runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)
|
||||
newtype DockerT m a = DockerT {
|
||||
unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
|
||||
} deriving (Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans
|
||||
|
||||
|
||||
-- instance Applicative m => Applicative (DockerT m) where
|
||||
-- pure a = DockerT $ pure a
|
||||
-- (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v
|
||||
|
||||
|
||||
-- type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT DockerError m) a
|
||||
|
||||
-- runDockerT :: forall m a. Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either DockerError a)
|
||||
runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
|
||||
runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, 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
|
||||
@ -39,11 +79,21 @@ mkHttpRequest verb e opts = request
|
||||
-- TODO: manager = newManager defaultManagerSettings -- We likely need
|
||||
-- this for TLS.
|
||||
|
||||
-- mapHttpToDocker :: HTTP.HttpException -> DockerError
|
||||
-- mapHttpToDocker e = case e of
|
||||
-- HTTP.FailedConnectionException{} -> DockerConnectionError
|
||||
-- HTTP.FailedConnectionException2{} -> DockerConnectionError
|
||||
-- otherwise -> GenericDockerError "dinamo"
|
||||
|
||||
defaultHttpHandler :: HttpHandler IO
|
||||
defaultHttpHandler request = do
|
||||
manager <- newManager defaultManagerSettings
|
||||
response <- httpLbs request manager
|
||||
return response
|
||||
manager <- newManager defaultManagerSettings
|
||||
-- either mapHttpToDocker id <$> try httpLbs request manager
|
||||
try (httpLbs request manager) >>= \res -> case res of
|
||||
Right res -> return $ Right res
|
||||
Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
|
||||
Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
|
||||
Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
|
||||
|
||||
-- | Connect to a unix domain socket (the default docker socket is
|
||||
-- at \/var\/run\/docker.sock)
|
||||
|
Loading…
Reference in New Issue
Block a user