{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
-- for an example of how to use this module.
module Symantic.HTTP.Client where
import Control.Applicative (Applicative(..){-, Alternative(..)-})
import Control.Monad (Monad(..), unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, for_, toList)
import Data.Function (($), (.), id, on)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import Data.Traversable (sequence)
import Data.Tuple (fst)
import GHC.Exts (fromList)
import System.IO (IO)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exn
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Reader as R
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import qualified Data.IORef as IO
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Time.Clock as Time
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.URI as URI
import qualified Web.HttpApiData as Web
import Symantic.HTTP.API
import Symantic.HTTP.URI
import Symantic.HTTP.MIME
-- * Type 'Client'
-- | @'Client' a k@ is a recipe to produce a 'ClientRequest'
-- from arguments 'requests' (one per number of alternative routes)
-- separated by (':!:').
--
-- 'Client' is analogous to a printf using a format customized for HTTP routing.
newtype Client requests k
= Client
{ unClient :: (ClientModifier -> k) -> requests
}
-- | @'client' requests@ returns the 'ClientRequest'
-- builders from the given API.
client :: Client requests ClientRequest -> requests
client (Client requests) = requests ($ ini)
where
ini = ClientRequest
{ clientReq_httpVersion = HTTP.http11
, clientReq_method = HTTP.methodGet
, clientReq_path = ""
, clientReq_queryString = Seq.empty
, clientReq_accept = Seq.empty
, clientReq_headers = Seq.empty
, clientReq_body = Nothing
}
-- ** Type 'ClientModifier'
type ClientModifier = ClientRequest -> ClientRequest
instance Cat Client where
Client x <.> Client y = Client $ \k ->
x $ \fx -> y $ \fy -> k $ fy . fx
instance Alt Client where
Client x <!> Client y = Client $ \k ->
x k :!: y k
{-
type AltMerge Client = (:!:)
Client x <!> Client y = Client $ \k ->
x (\cm -> let n:!:_ = k cm in n) :!:
y (\cm -> let _:!:n = k cm in n)
-}
-- try = id -- FIXME: see what to do
instance Pro Client where
dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
instance HTTP_Path Client where
type PathConstraint Client a = Web.ToHttpApiData a
segment s = Client $ \k -> k $ \req ->
req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece s }
capture' _n = Client $ \k a -> k $ \req ->
req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece a }
captureAll = Client $ \k ss -> k $ \req ->
req{ clientReq_path =
List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
Web.toUrlPiece <$> ss
}
instance HTTP_Header Client where
header n = Client $ \k v -> k $ \req ->
req{ clientReq_headers = clientReq_headers req Seq.|> (n, Web.toHeader v) }
instance HTTP_BasicAuth Client where
type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
basicAuth' realm = Client $ \k user pass -> k $ \req ->
req{ clientReq_headers =
let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
clientReq_headers req Seq.|>
( HTTP.hAuthorization
, Web.toHeader $ "Basic " <> BS64.encode user_pass
)
}
instance HTTP_Query Client where
type QueryConstraint Client a = Web.ToHttpApiData a
queryParams' n = Client $ \k vs -> k $ \req ->
req{ clientReq_queryString =
clientReq_queryString req <>
fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
instance HTTP_Version Client where
version v = Client $ \k -> k $ \req ->
req{clientReq_httpVersion = v}
-- ** Type 'ClientBodyArg'
newtype ClientBodyArg (ts::[*]) a = ClientBodyArg a
instance HTTP_Body Client where
type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
type BodyArg Client a ts = ClientBodyArg ts a
body' ::
forall a ts k repr.
BodyConstraint repr a ts =>
repr ~ Client =>
repr (BodyArg repr a ts -> k) k
body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
req{clientReq_body =
case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
MimeType (mt::Proxy t) ->
Just
( Client.RequestBodyLBS $ mimeEncode mt a
, mediaType @t )
}
-- ** Type 'ClientBodyStreamArg'
newtype ClientBodyStreamArg framing (ts::[*]) as = ClientBodyStreamArg as
instance HTTP_BodyStream Client where
type BodyStreamConstraint Client as ts framing =
( FramingEncode framing as
, MimeTypes ts (MimeEncodable (FramingYield as))
)
type BodyStreamArg Client as ts framing = ClientBodyStreamArg framing ts as
bodyStream' ::
forall as ts framing k repr.
BodyStreamConstraint repr as ts framing =>
repr ~ Client =>
repr (BodyStreamArg repr as ts framing -> k) k
bodyStream'= Client $ \k (ClientBodyStreamArg as) -> k $ \req ->
req{clientReq_body =
case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable (FramingYield as)) of
MimeType (mt::Proxy t) ->
Just $ (, mediaType @t) $
Client.RequestBodyStreamChunked $ \write -> do
let enc = framingEncode (Proxy @framing) (mimeEncode mt)
ini <- enc as
ioref <- IO.newIORef ini
let go curr =
case curr of
Left _end -> return ""
Right (bsl, next)
| BSL.null bsl -> enc next >>= go
-- NOTE: skip all null 'ByteString' because it would end the stream.
| otherwise -> enc next >>= \n -> do
IO.writeIORef ioref n
return $ BSL.toStrict bsl
-- NOTE: strictify the 'bsl' 'ByteString'
-- instead of iterating on its chunks,
-- in order to diminish the number of 'Client.connectionWrite'.
write $ IO.readIORef ioref >>= go
}
instance HTTP_Response Client where
type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
type Response Client = ClientRequest
response ::
forall a ts repr.
ResponseConstraint repr a ts =>
repr ~ Client =>
HTTP.Method ->
repr (ResponseArgs repr a ts)
(Response repr)
response m = Client $ \k Proxy Proxy -> k $ \req ->
req
{ clientReq_method = m
, clientReq_accept =
clientReq_accept req <>
fromList (toList $ mediaTypes @ts @(MimeDecodable a))
}
instance HTTP_ResponseStream Client where
type ResponseStreamConstraint Client as ts framing =
MimeTypes ts (MimeDecodable (FramingYield as))
type ResponseStreamArgs Client as ts framing =
Proxy framing ->
Proxy ts ->
Proxy as ->
ClientRequest
type ResponseStream Client = ClientRequest
responseStream ::
forall as ts framing repr.
ResponseStreamConstraint repr as ts framing =>
repr ~ Client =>
HTTP.Method ->
repr (ResponseStreamArgs repr as ts framing)
(ResponseStream repr)
responseStream m = Client $ \k Proxy Proxy Proxy -> k $ \req ->
req
{ clientReq_method = m
, clientReq_accept =
clientReq_accept req <>
fromList (toList $ mediaTypes @ts @(MimeDecodable (FramingYield as)))
}
instance Web.ToHttpApiData BS.ByteString where
toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
toHeader = id
-- * Type 'ClientConn'
-- | A monadic connection from a client to a server.
-- It is specialized in 'ClientConnection' and 'ClientConnectionStream'.
--
-- NOTE: no 'Monad' transformer is put within this newtype
-- to let @monad-classes@ handle all the |lift|ing.
newtype ClientConn m a
= ClientConn
{ unClientConn :: m a
} deriving (Functor, Applicative, Monad)
-- | All supported effects are handled by nested 'Monad's.
type instance MC.CanDo (ClientConn m) eff = 'False
instance MonadTrans ClientConn where
lift = ClientConn
-- ** Type 'ClientEnv'
data ClientEnv
= ClientEnv
{ clientEnv_manager :: Client.Manager
, clientEnv_baseURI :: URI
, clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
}
clientEnv :: Client.Manager -> URI -> ClientEnv
clientEnv clientEnv_manager clientEnv_baseURI =
ClientEnv
{ clientEnv_cookieJar = Nothing
, ..
}
-- ** Type 'ClientError'
data ClientError
-- | The server returned an error response
= ClientError_FailureResponse ClientResponse
-- | The body could not be decoded at the expected type
| ClientError_DecodeFailure Text ClientResponse
-- | The content-type of the response is not supported
| ClientError_UnsupportedContentType BS.ByteString ClientResponse
-- | There was a connection error, and no response was received
| ClientError_ConnectionError Client.HttpException
-- | 'ClientConn' is 'empty'
| ClientError_EmptyClient
deriving (Eq, Show{-, Generic, Typeable-})
instance Exn.Exception ClientError
instance Eq Client.HttpException where
(==) = (==) `on` show
-- ** Type 'ClientRequest'
data ClientRequest
= ClientRequest
{ clientReq_httpVersion :: HTTP.HttpVersion
, clientReq_method :: HTTP.Method
, clientReq_path :: BSB.Builder
, clientReq_queryString :: Seq.Seq HTTP.QueryItem
, clientReq_accept :: Seq.Seq Media.MediaType
, clientReq_headers :: Seq.Seq HTTP.Header
, clientReq_body :: Maybe (Client.RequestBody, Media.MediaType)
}
instance Show ClientRequest where
show _ = "ClientRequest"
clientRequest :: URI -> ClientRequest -> Client.Request
clientRequest baseURI req =
Client.defaultRequest
{ Client.method = clientReq_method req
, Client.host = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
, Client.port = case URI.uriPort <$> URI.uriAuthority baseURI of
Just (':':p) | Just port <- readMaybe p -> port
_ -> 0
, Client.path = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReq_path req)
, Client.queryString = HTTP.renderQuery True . toList $ clientReq_queryString req
, Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
, Client.requestBody
, Client.secure = URI.uriScheme baseURI == "https"
}
where
headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
toList $ clientReq_headers req
acceptHeader | null hs = []
| otherwise = [("Accept", Media.renderHeader hs)]
where
hs = toList $ clientReq_accept req
(requestBody, contentTypeHeader) =
case clientReq_body req of
Nothing -> (Client.RequestBodyBS "", [])
Just (b, mt) -> (b, [(HTTP.hContentType, Media.renderHeader mt)])
-- ** Type 'ClientConnection'
type ClientConnection
= ClientConn (R.ReaderT ClientEnv (E.ExceptT ClientError IO))
{-
-- | Try clients in order, last error is preserved.
instance Alternative ClientConnection where
empty = MC.throw $ ClientError_EmptyClient
x <|> y = ClientConn $ do
env <- MC.ask
MC.exec @IO (E.runExceptT $ R.runReaderT (unClientConn x) env) >>= \case
Right xa -> return xa
Left _err -> unClientConn y
-}
runClient ::
MimeTypes ts (MimeDecodable a) =>
ClientEnv ->
(Proxy ts -> Proxy a -> ClientRequest) ->
IO (Either ClientError a)
runClient env =
E.runExceptT .
(`R.runReaderT` env) .
unClientConn .
clientConnection
clientConnection ::
forall a ts.
MimeTypes ts (MimeDecodable a) =>
(Proxy ts -> Proxy a -> ClientRequest) ->
ClientConnection a
clientConnection req = do
clientRes <- doClientRequest $ req (Proxy::Proxy ts) (Proxy::Proxy a)
let mtRes =
fromMaybe "application/octet-stream" $
List.lookup "Content-Type" $
Client.responseHeaders clientRes
case matchContent @ts @(MimeDecodable a) mtRes of
Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
Just (MimeType mt) ->
case mimeDecode mt $ Client.responseBody clientRes of
Left err -> MC.throw $ ClientError_DecodeFailure (Text.pack err) clientRes
Right val -> return val
doClientRequest :: ClientRequest -> ClientConnection ClientResponse
doClientRequest clientReq = do
ClientEnv{..} <- MC.ask
req <-
let req = clientRequest clientEnv_baseURI clientReq in
case clientEnv_cookieJar of
Nothing -> pure req
Just cj ->
MC.exec @IO $ do
now <- Time.getCurrentTime
STM.atomically $ do
oldCookieJar <- STM.readTVar cj
let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest req oldCookieJar now
STM.writeTVar cj newCookieJar
pure newRequest
lrRes <-
MC.exec @IO $ catchClientConnectionError $
Client.httpLbs req clientEnv_manager
case lrRes of
Left err -> MC.throw err
Right res -> do
for_ clientEnv_cookieJar $ \cj ->
MC.exec @IO $ do
now <- Time.getCurrentTime
STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
let code = HTTP.statusCode $ Client.responseStatus res
unless (code >= 200 && code < 300) $
MC.throw $ ClientError_FailureResponse res
return res
catchClientConnectionError :: IO a -> IO (Either ClientError a)
catchClientConnectionError ma =
Exn.catch (Right <$> ma) $ \err ->
return $ Left $ ClientError_ConnectionError err
-- *** Type 'ClientResponse'
type ClientResponse
= Client.Response BSL.ByteString
-- ** Type 'ClientConnectionStream'
type ClientConnectionStream
= ClientConn (R.ReaderT ClientEnv (Codensity (E.ExceptT ClientError IO)))
runClientStream ::
FramingDecode framing as =>
MC.MonadExec IO (FramingMonad as) =>
MimeTypes ts (MimeDecodable (FramingYield as)) =>
ClientEnv ->
(Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
(as -> IO b) -> IO (Either ClientError b)
runClientStream env req k =
E.runExceptT $
(`runCodensity` lift . k) $
(`R.runReaderT` env) $
unClientConn $
clientConnectionStream req
clientConnectionStream ::
forall as ts framing.
FramingDecode framing as =>
MC.MonadExec IO (FramingMonad as) =>
MimeTypes ts (MimeDecodable (FramingYield as)) =>
(Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
ClientConnectionStream as
clientConnectionStream req = do
doClientRequestStream (Proxy::Proxy ts) (req Proxy Proxy Proxy) $ \(MimeType mt) clientRes ->
return $
framingDecode (Proxy @framing) (mimeDecode mt) $
MC.exec @IO $ Client.responseBody clientRes
doClientRequestStream ::
forall (ts::[*]) as.
MimeTypes ts (MimeDecodable (FramingYield as)) =>
Proxy ts ->
ClientRequest ->
( MimeType (MimeDecodable (FramingYield as)) ->
Client.Response Client.BodyReader ->
E.ExceptT ClientError IO as ) ->
ClientConnectionStream as
doClientRequestStream Proxy clientReq k = do
ClientEnv{..} <- MC.ask
let req = clientRequest clientEnv_baseURI $ clientReq
ClientConn $ lift $ Codensity $ \k' ->
E.ExceptT $ Client.withResponse req clientEnv_manager $ \res ->
E.runExceptT $ do{-E.ExceptT ClientError IO-}
-- Check status
let code = HTTP.statusCode $ Client.responseStatus res
unless (code >= 200 && code < 300) $ do
err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
E.throwE $ ClientError_FailureResponse err
-- Check Content-Type header
let contentTypeH =
fromMaybe "application/octet-stream" $
List.lookup "Content-Type" $
Client.responseHeaders res
case matchContent @ts @(MimeDecodable (FramingYield as)) contentTypeH of
Nothing -> do
err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
E.throwE $ ClientError_UnsupportedContentType contentTypeH err
Just ct -> k ct res >>= k'
-- *** Type 'Codensity'
-- | Copy from the @kan-extensions@ package to avoid the dependencies.
newtype Codensity m a
= Codensity
{ runCodensity :: forall b. (a -> m b) -> m b }
type instance MC.CanDo (Codensity m) (MC.EffExec eff) = 'False
instance Functor (Codensity k) where
fmap f (Codensity m) = Codensity (\k -> m (k .f))
{-# INLINE fmap #-}
instance Applicative (Codensity f) where
pure x = Codensity (\k -> k x)
{-# INLINE pure #-}
Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))
{-# INLINE (<*>) #-}
instance Monad (Codensity f) where
return = pure
{-# INLINE return #-}
m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))
{-# INLINE (>>=) #-}
instance MonadTrans Codensity where
lift m = Codensity (m >>=)
{-# INLINE lift #-}