@@ -20,41 +20,37 @@ import Control.Monad
2020import Control.Monad.Base (MonadBase (..))
2121import Control.Monad.Catch (MonadCatch, MonadThrow)
2222import Control.Monad.Error.Class (MonadError (..))
23−import Control.Monad.IO.Class ()
23+import Data.ByteString.Builder (toLazyByteString)
24+import qualified Data.ByteString.Lazy as BSL
25+import Data.Monoid ((<>))
26+import Data.String (fromString)
27+import qualified Data.Text as T
28+import GHC.Exts (fromList)
29+{-import Control.Monad.IO.Class ()-}
2430import Control.Monad.Reader
2531import Control.Monad.Trans.Control (MonadBaseControl (..))
2632import Control.Monad.Trans.Except
27−import Data.ByteString.Lazy hiding (any, elem, filter, map,
28− null, pack)
33+{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-}
34+ {-null, pack)-}
2935import Data.Foldable (toList)
3036import Data.Functor.Alt (Alt (..))
3137import Data.Proxy
32−import Data.String.Conversions (cs)
38+{-import Data.String.Conversions (cs)-}
3339import GHC.Generics
34−import Network.HTTP.Media
35−import Network.HTTP.Types
36−import Servant.API.ContentTypes
37−import Servant.Client.Class
38−import Servant.Common.BaseUrl
39−import Servant.Common.Req
40+import Network.HTTP.Media (parseAccept, renderHeader, (//))
41+import Network.HTTP.Types (hContentType, renderQuery,
42+ statusCode)
43+{-import Servant.API.ContentTypes-}
44+import Servant.Client.Core
45+{-import Servant.Common.BaseUrl-}
46+{-import Servant.Common.Req-}
4047
4148import qualified Network.HTTP.Client as Client
42−import qualified Network.HTTP.Types.Header as HTTP
43−
44−instance RunClient ClientM NoContent ( Int, ByteString, MediaType
45− , [HTTP.Header], Response ByteString) where
46− runRequest _ meth req = performRequest meth req
47−
48−instance (MimeUnrender ct a) =>
49− RunClient ClientM ct ([HTTP.Header], a) where
50− runRequest p meth req = performRequestCT p meth req
51−
52−instance RunClient ClientM NoContent [HTTP.Header] where
53− runRequest _ meth req = performRequestNoBody meth req
49+{-import qualified Network.HTTP.Types.Header as HTTP-}
5450
5551data ClientEnv
5652 = ClientEnv
57− { manager :: Manager
53+ { manager :: Client.Manager
5854 , baseUrl :: BaseUrl
5955 }
6056
@@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where
8278instance Alt ClientM where
8379 a <!> b = a `catchError` \_ -> b
8480
81+instance RunClient ClientM where
82+ runRequest = performRequest
83+
8584runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
8685runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
8786
8887
89−performRequest :: Method -> Req
90− -> ClientM Response
91−performRequest reqMethod req = do
92− m <- asks manager
93− reqHost <- asks baseUrl
94− partialRequest <- liftIO $ reqToRequest req reqHost
9588
96− let request = partialRequest { Client.method = reqMethod }
89+performRequest :: Request -> ClientM Response
90+performRequest req = do
91+ m <- asks manager
92+ burl <- asks baseUrl
93+ let request = requestToClientRequest burl req
9794
9895 eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
9996 case eResponse of
100− Left err ->
101− throwError . ConnectionError $ SomeException err
102−
97+ Left err -> throwError $ err
10398 Right response -> do
10499 let status = Client.responseStatus response
105100 body = Client.responseBody response
106101 hdrs = Client.responseHeaders response
107102 status_code = statusCode status
103+ ourResponse = clientResponseToReponse response
108104 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
109105 Nothing -> pure $ "application"//"octet-stream"
110106 Just t -> case parseAccept t of
111− Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
107+ Nothing -> throwError $ InvalidContentTypeHeader ourResponse
112108 Just t' -> pure t'
113109 unless (status_code >= 200 && status_code < 300) $
114− throwError $ FailureResponse (UrlReq reqHost req) status ct body
115− return (status_code, body, ct, hdrs, response)
116−
117−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
118− -> ClientM ([HTTP.Header], result)
119−performRequestCT ct reqMethod req = do
120− let acceptCTS = contentTypes ct
121− (_status, respBody, respCT, hdrs, _response) <-
122− performRequest reqMethod (req { reqAccept = toList acceptCTS })
123− unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
124− case mimeUnrender ct respBody of
125− Left err -> throwError $ DecodeFailure err respCT respBody
126− Right val -> return (hdrs, val)
127−
128−performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
129−performRequestNoBody reqMethod req = do
130− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
131− return hdrs
110+ throwError $ FailureResponse ourResponse
111+ return ourResponse
112+
113+clientResponseToReponse :: Client.Response BSL.ByteString -> Response
114+clientResponseToReponse r = Response
115+ { responseStatusCode = Client.responseStatus r
116+ , responseBody = Client.responseBody r
117+ , responseHeaders = fromList $ Client.responseHeaders r
118+ , responseHttpVersion = Client.responseVersion r
119+ }
120+
121+requestToClientRequest :: BaseUrl -> Request -> Client.Request
122+requestToClientRequest burl r = Client.defaultRequest
123+ { Client.method = requestMethod r
124+ , Client.host = fromString $ baseUrlHost burl
125+ , Client.port = baseUrlPort burl
126+ , Client.path = BSL.toStrict
127+ $ fromString (baseUrlPath burl)
128+ <> toLazyByteString (requestPath r)
129+ , Client.queryString = renderQuery True . toList $ requestQueryString r
130+ , Client.requestHeaders =
131+ let orig = toList $ requestHeaders r
132+ in maybe orig (: orig) contentTypeHdr
133+ , Client.requestBody = body
134+ }
135+ where
136+ (body, contentTypeHdr) = case requestBody r of
137+ Nothing -> (Client.RequestBodyLBS "", Nothing)
138+ Just (RequestBodyLBS body, typ)
139+ -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ))
140+
141+{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-}
142+ {--> ClientM ([HTTP.Header], result)-}
143+{-performRequestCT ct reqMethod req = do-}
144+ {-let acceptCTS = contentTypes ct-}
145+ {-(_status, respBody, respCT, hdrs, _response) <--}
146+ {-performRequest reqMethod (req { reqAccept = toList acceptCTS })-}
147+ {-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-}
148+ {-case mimeUnrender ct respBody of-}
149+ {-Left err -> throwError $ DecodeFailure err respCT respBody-}
150+ {-Right val -> return (hdrs, val)-}
151+
152+{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-}
153+{-performRequestNoBody reqMethod req = do-}
154+ {-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-}
155+ {-return hdrs-}
132156
133157catchConnectionError :: IO a -> IO (Either ServantError a)
134158catchConnectionError action =
135159 catch (Right <$> action) $ \e ->
136− pure . Left . ConnectionError $ SomeException (e :: HttpException)
160+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)