{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Symantic.HTTP.Client.Connection where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), unless) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Bool import Data.Default.Class (Default(..)) import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Foldable (null, for_, toList) import Data.Function (($), (.), 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.Sequence (Seq) import Data.String (IsString(..)) import Data.Text (Text) import Data.Tuple (fst) 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.Builder as BSB import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text as T 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 Symantic.HTTP.Utils import Symantic.HTTP.MIME import Symantic.HTTP.URI -- * Type 'ClientConnection' -- [ A monadic connection for a client query a server. newtype ClientConnection a = ClientConnection { unClientConnection :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a } deriving (Functor, Applicative, Monad) type instance MC.CanDo ClientConnection (MC.EffReader ClientEnv) = 'True type instance MC.CanDo ClientConnection (MC.EffExcept ClientError) = 'True type instance MC.CanDo ClientConnection (MC.EffExec IO) = 'True instance MC.MonadExceptN 'MC.Zero ClientError ClientConnection where throwN px = ClientConnection . lift . MC.throwN px instance MC.MonadReaderN 'MC.Zero ClientEnv ClientConnection where askN px = ClientConnection $ MC.askN px instance MC.MonadExecN 'MC.Zero IO ClientConnection where execN _px = ClientConnection . lift . lift -- | Try clients in order, last error is preserved. instance Alternative ClientConnection where empty = MC.throw $ ClientError_EmptyClient x <|> y = ClientConnection $ do env <- MC.ask liftIO (runClientConnection env x) >>= \case Right xa -> return xa Left _err -> unClientConnection y 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) clientResMimeDecode (Proxy::Proxy ts) clientRes runClientConnection :: ClientEnv -> ClientConnection a -> IO (Either ClientError a) runClientConnection env (ClientConnection c) = E.runExceptT $ R.runReaderT c env runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse) runClientRequest env = runClientConnection env . doClientRequest -- ** 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 {- -- | The content-type header is invalid | ClientError_InvalidContentTypeHeader ClientResponse -} -- | There was a connection error, and no response was received | ClientError_ClientConnectionectionError Client.HttpException -- | 'ClientConnection' 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 { clientReqHttpVersion :: HTTP.HttpVersion , clientReqMethod :: HTTP.Method , clientReqPath :: BSB.Builder , clientReqQueryString :: Seq HTTP.QueryItem , clientReqAccept :: Seq Media.MediaType , clientReqHeaders :: Seq HTTP.Header , clientReqBody :: Maybe (Client.RequestBody, Media.MediaType) } instance Default ClientRequest where def = ClientRequest { clientReqHttpVersion = HTTP.http11 , clientReqMethod = HTTP.methodGet , clientReqPath = "" , clientReqQueryString = Seq.empty , clientReqAccept = Seq.empty , clientReqHeaders = Seq.empty , clientReqBody = Nothing } instance Show ClientRequest where show _ = "ClientRequest" clientRequest :: URI -> ClientRequest -> Client.Request clientRequest baseURI req = Client.defaultRequest { Client.method = clientReqMethod 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 (clientReqPath req) , Client.queryString = HTTP.renderQuery True . toList $ clientReqQueryString 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 $ clientReqHeaders req acceptHeader | null hs = [] | otherwise = [("Accept", Media.renderHeader hs)] where hs = toList $ clientReqAccept req (requestBody, contentTypeHeader) = case clientReqBody req of Nothing -> (Client.RequestBodyLBS "", []) Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)]) setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest setClientRequestBodyLBS body mt req = req{ clientReqBody = Just (Client.RequestBodyLBS body, mt) } setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) } -- ** Type 'ClientResponse' type ClientResponse = ClientResponseWithBody BSL.ByteString data ClientResponseWithBody a = ClientResponse { clientResStatus :: HTTP.Status , clientResHeaders :: Seq HTTP.Header , clientResHttpVersion :: HTTP.HttpVersion , clientResBody :: a } deriving (Eq, Show, Functor) clientResponse :: Client.Response a -> ClientResponseWithBody a clientResponse res = ClientResponse { clientResStatus = Client.responseStatus res , clientResBody = Client.responseBody res , clientResHeaders = Seq.fromList $ Client.responseHeaders res , clientResHttpVersion = Client.responseVersion res } 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 -> liftIO $ 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 <- liftIO $ catchClientConnectionectionError $ Client.httpLbs req clientEnv_manager case lrRes of Left err -> MC.throw err Right res -> do for_ clientEnv_cookieJar $ \cj -> liftIO $ do now <- Time.getCurrentTime STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now) let status = HTTP.statusCode $ Client.responseStatus res clientRes = clientResponse res unless (status >= 200 && status < 300) $ MC.throw $ ClientError_FailureResponse clientRes return clientRes catchClientConnectionectionError :: IO a -> IO (Either ClientError a) catchClientConnectionectionError action = Exn.catch (Right <$> action) $ \err -> return $ Left $ ClientError_ClientConnectionectionError err -- ** Type 'ClientResponseStreaming' newtype ClientResponseStreaming = ClientResponseStreaming { runClientResponseStreaming :: forall a. (ClientResponseWithBody (IO BS.ByteString) -> IO a) -> IO a } doClientRequestStreaming :: ClientRequest -> ClientConnection ClientResponseStreaming doClientRequestStreaming clientReq = do ClientEnv{..} <- MC.ask let req = clientRequest clientEnv_baseURI clientReq return $ ClientResponseStreaming $ \k -> Client.withResponse req clientEnv_manager $ \res -> do let status = HTTP.statusCode $ Client.responseStatus res unless (status >= 200 && status < 300) $ do responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody} k $ clientResponse res clientResMimeDecode :: forall ts m a. MimeTypes ts (MimeDecodable a) => MC.MonadExcept ClientError m => Proxy ts -> ClientResponse -> m a clientResMimeDecode Proxy clientRes = do let mtRes = fromMaybe "application/octet-stream" $ List.lookup "Content-Type" $ toList $ clientResHeaders clientRes case matchContent @ts @(MimeDecodable a) mtRes of Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes Just (MimeType mt) -> case mimeDecode mt $ clientResBody clientRes of Left err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes Right val -> return val