2017-09-07 22:38:31 +02:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2017-09-06 23:13:05 +02:00
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
2017-09-14 15:53:51 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2017-09-13 01:49:55 +02:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2017-09-13 17:05:48 +02:00
|
|
|
-- | Types for possible backends to run client-side `Request` queries
|
2017-09-13 18:36:20 +02:00
|
|
|
module Servant.Client.Core.Internal.RunClient where
|
2017-09-06 23:13:05 +02:00
|
|
|
|
2017-09-14 15:53:51 +02:00
|
|
|
import Prelude ()
|
2017-09-15 20:57:03 +02:00
|
|
|
import Prelude.Compat
|
2017-09-14 15:53:51 +02:00
|
|
|
|
2017-09-13 01:49:55 +02:00
|
|
|
import Control.Monad (unless)
|
2017-09-14 15:53:51 +02:00
|
|
|
import Data.Foldable (toList)
|
2017-09-13 01:49:55 +02:00
|
|
|
import Data.Proxy (Proxy)
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import Network.HTTP.Media (MediaType, matches,
|
|
|
|
parseAccept, (//))
|
|
|
|
import Servant.API (MimeUnrender,
|
|
|
|
contentTypes,
|
|
|
|
mimeUnrender)
|
2018-01-30 17:40:02 +01:00
|
|
|
import Servant.Client.Core.Internal.Request (Request, Response, GenResponse (..),
|
2017-10-25 02:12:21 +02:00
|
|
|
StreamingResponse (..),
|
2017-09-13 01:49:55 +02:00
|
|
|
ServantError (..))
|
2017-09-06 23:13:05 +02:00
|
|
|
|
2017-09-15 20:57:03 +02:00
|
|
|
class (Monad m) => RunClient m where
|
2017-09-13 01:49:55 +02:00
|
|
|
-- | How to make a request.
|
2017-09-07 22:38:31 +02:00
|
|
|
runRequest :: Request -> m Response
|
2017-10-25 02:12:21 +02:00
|
|
|
streamingRequest :: Request -> m StreamingResponse
|
2017-09-15 20:57:03 +02:00
|
|
|
throwServantError :: ServantError -> m a
|
|
|
|
catchServantError :: m a -> (ServantError -> m a) -> m a
|
2017-09-13 01:49:55 +02:00
|
|
|
|
|
|
|
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
|
|
|
checkContentTypeHeader response =
|
|
|
|
case lookup "Content-Type" $ toList $ responseHeaders response of
|
2017-09-14 15:53:51 +02:00
|
|
|
Nothing -> return $ "application"//"octet-stream"
|
2017-09-13 01:49:55 +02:00
|
|
|
Just t -> case parseAccept t of
|
2017-09-15 20:57:03 +02:00
|
|
|
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
2017-09-14 15:53:51 +02:00
|
|
|
Just t' -> return t'
|
2017-09-13 01:49:55 +02:00
|
|
|
|
|
|
|
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
|
|
|
=> Response -> Proxy ct -> m a
|
|
|
|
decodedAs response contentType = do
|
|
|
|
responseContentType <- checkContentTypeHeader response
|
|
|
|
unless (any (matches responseContentType) accept) $
|
2017-09-15 20:57:03 +02:00
|
|
|
throwServantError $ UnsupportedContentType responseContentType response
|
2017-09-13 01:49:55 +02:00
|
|
|
case mimeUnrender contentType $ responseBody response of
|
2017-09-15 20:57:03 +02:00
|
|
|
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
2017-09-13 01:49:55 +02:00
|
|
|
Right val -> return val
|
|
|
|
where
|
|
|
|
accept = toList $ contentTypes contentType
|