{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.HTTP.Client where
import Control.Applicative (Applicative(..))
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
newtype Client requests k
= Client
{ unClient :: (ClientModifier -> k) -> requests
}
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 = 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
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}
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 )
}
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
| otherwise -> enc next >>= \n -> do
IO.writeIORef ioref n
return $ BSL.toStrict bsl
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
newtype ClientConn m a
= ClientConn
{ unClientConn :: m a
} deriving (Functor, Applicative, Monad)
type instance MC.CanDo (ClientConn m) eff = 'False
instance MonadTrans ClientConn where
lift = ClientConn
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
, ..
}
data ClientError
= ClientError_FailureResponse ClientResponse
| ClientError_DecodeFailure Text ClientResponse
| ClientError_UnsupportedContentType BS.ByteString ClientResponse
| ClientError_ConnectionError Client.HttpException
| ClientError_EmptyClient
deriving (Eq, Show)
instance Exn.Exception ClientError
instance Eq Client.HttpException where
(==) = (==) `on` show
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
= ClientConn (R.ReaderT ClientEnv (E.ExceptT ClientError IO))
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
= Client.Response BSL.ByteString
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
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
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'
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 #-}