61 lines
2.3 KiB
Haskell
61 lines
2.3 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
-- | Types for possible backends to run client-side `Request` queries
|
|
module Servant.Client.Core.Internal.RunClient where
|
|
|
|
import Prelude ()
|
|
import Prelude.Compat
|
|
|
|
import Control.Monad
|
|
(unless)
|
|
import Control.Monad.Free
|
|
(Free (..), liftF)
|
|
import Data.Foldable
|
|
(toList)
|
|
import Data.Proxy
|
|
(Proxy)
|
|
import qualified Data.Text as T
|
|
import Network.HTTP.Media
|
|
(MediaType, matches, parseAccept, (//))
|
|
import Servant.API
|
|
(MimeUnrender, contentTypes, mimeUnrender)
|
|
|
|
import Servant.Client.Core.Internal.ClientF
|
|
import Servant.Client.Core.Internal.Request
|
|
(GenResponse (..), Request, Response, ServantError (..),
|
|
StreamingResponse)
|
|
|
|
class Monad m => RunClient m where
|
|
-- | How to make a request.
|
|
runRequest :: Request -> m Response
|
|
streamingRequest :: Request -> m StreamingResponse
|
|
throwServantError :: ServantError -> m a
|
|
|
|
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
|
checkContentTypeHeader response =
|
|
case lookup "Content-Type" $ toList $ responseHeaders response of
|
|
Nothing -> return $ "application"//"octet-stream"
|
|
Just t -> case parseAccept t of
|
|
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
|
Just t' -> return t'
|
|
|
|
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) $
|
|
throwServantError $ UnsupportedContentType responseContentType response
|
|
case mimeUnrender contentType $ responseBody response of
|
|
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
|
Right val -> return val
|
|
where
|
|
accept = toList $ contentTypes contentType
|
|
|
|
instance ClientF ~ f => RunClient (Free f) where
|
|
runRequest req = liftF (RunRequest req id)
|
|
streamingRequest req = liftF (StreamingRequest req id)
|
|
throwServantError = liftF . Throw
|