Symantic/HTTP/Client/Connection.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE StrictData #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Symantic.HTTP.Client.Connection where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Control.Monad (Monad(..), unless)
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Data.Bool
  13 import Data.Default.Class (Default(..))
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (null, for_, toList)
  17 import Data.Function (($), (.), on)
  18 import Data.Functor (Functor, (<$>))
  19 import Data.Maybe (Maybe(..), maybe, fromMaybe)
  20 import Data.Ord (Ord(..))
  21 import Data.Proxy (Proxy(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Sequence (Seq)
  24 import Data.String (IsString(..))
  25 import Data.Text (Text)
  26 import Data.Tuple (fst)
  27 import System.IO (IO)
  28 import Text.Read (readMaybe)
  29 import Text.Show (Show(..))
  30 import qualified Control.Concurrent.STM as STM
  31 import qualified Control.Exception as Exn
  32 import qualified Control.Monad.Classes as MC
  33 import qualified Control.Monad.Trans.Except as E
  34 import qualified Control.Monad.Trans.Reader as R
  35 import qualified Data.ByteString as BS
  36 import qualified Data.ByteString.Builder as BSB
  37 import qualified Data.ByteString.Lazy as BSL
  38 import qualified Data.List as List
  39 import qualified Data.Sequence as Seq
  40 import qualified Data.Text as T
  41 import qualified Data.Time.Clock as Time
  42 import qualified Network.HTTP.Client as Client
  43 import qualified Network.HTTP.Media as Media
  44 import qualified Network.HTTP.Types as HTTP
  45 import qualified Network.URI as URI
  46
  47 import Symantic.HTTP.Utils
  48 import Symantic.HTTP.MIME
  49 import Symantic.HTTP.URI
  50
  51 -- * Type 'ClientConnection'
  52 -- [ A monadic connection for a client query a server.
  53 newtype ClientConnection a = ClientConnection { unClientConnection ::
  54         R.ReaderT ClientEnv
  55                   (E.ExceptT ClientError IO)
  56                   a
  57  } deriving (Functor, Applicative, Monad)
  58 type instance MC.CanDo ClientConnection (MC.EffReader ClientEnv)   = 'True
  59 type instance MC.CanDo ClientConnection (MC.EffExcept ClientError) = 'True
  60 type instance MC.CanDo ClientConnection (MC.EffExec   IO)          = 'True
  61 instance MC.MonadExceptN 'MC.Zero ClientError ClientConnection where
  62         throwN px = ClientConnection . lift . MC.throwN px
  63 instance MC.MonadReaderN 'MC.Zero ClientEnv ClientConnection where
  64         askN px = ClientConnection $ MC.askN px
  65 instance MC.MonadExecN 'MC.Zero IO ClientConnection where
  66         execN _px = ClientConnection . lift . lift
  67
  68 -- | Try clients in order, last error is preserved.
  69 instance Alternative ClientConnection where
  70         empty = MC.throw $ ClientError_EmptyClient
  71         x <|> y = ClientConnection $ do
  72                 env <- MC.ask
  73                 liftIO (runClientConnection env x) >>= \case
  74                  Right xa -> return xa
  75                  Left _err -> unClientConnection y
  76
  77 clientConnection ::
  78  forall a ts.
  79  MimeTypes ts (MimeDecodable a) =>
  80  (Proxy ts -> Proxy a -> ClientRequest) ->
  81  ClientConnection a
  82 clientConnection req = do
  83         clientRes <- doClientRequest $ req (Proxy::Proxy ts) (Proxy::Proxy a)
  84         clientResMimeDecode (Proxy::Proxy ts) clientRes
  85
  86 runClientConnection :: ClientEnv -> ClientConnection a -> IO (Either ClientError a)
  87 runClientConnection env (ClientConnection c) = E.runExceptT $ R.runReaderT c env
  88
  89 runClient ::
  90  MimeTypes ts (MimeDecodable a) =>
  91  ClientEnv ->
  92  (Proxy ts -> Proxy a -> ClientRequest) ->
  93  IO (Either ClientError a)
  94 runClient env = runClientConnection env . clientConnection
  95
  96 -- ** Type 'ClientEnv'
  97 data ClientEnv
  98  =   ClientEnv
  99  {   clientEnv_manager   :: Client.Manager
 100  ,   clientEnv_baseURI   :: URI
 101  ,   clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
 102  }
 103 clientEnv :: Client.Manager -> URI -> ClientEnv
 104 clientEnv clientEnv_manager clientEnv_baseURI =
 105         ClientEnv
 106          { clientEnv_cookieJar = Nothing
 107          , ..
 108          }
 109
 110 -- ** Type 'ClientError'
 111 data ClientError
 112      -- | The server returned an error response
 113  =   ClientError_FailureResponse ClientResponse
 114      -- | The body could not be decoded at the expected type
 115  |   ClientError_DecodeFailure Text ClientResponse
 116      -- | The content-type of the response is not supported
 117  |   ClientError_UnsupportedContentType BS.ByteString ClientResponse
 118  {-
 119      -- | The content-type header is invalid
 120  |   ClientError_InvalidContentTypeHeader ClientResponse
 121  -}
 122      -- | There was a connection error, and no response was received
 123  |   ClientError_ClientConnectionError Client.HttpException
 124      -- | 'ClientConnection' is 'empty'
 125  |   ClientError_EmptyClient
 126  deriving (Eq, Show{-, Generic, Typeable-})
 127 instance Exn.Exception ClientError
 128 instance Eq Client.HttpException where
 129         (==) = (==) `on` show
 130
 131 -- * Type 'ClientRequest'
 132 data ClientRequest
 133  =   ClientRequest
 134  {   clientReqHttpVersion :: HTTP.HttpVersion
 135  ,   clientReqMethod      :: HTTP.Method
 136  ,   clientReqPath        :: BSB.Builder
 137  ,   clientReqQueryString :: Seq HTTP.QueryItem
 138  ,   clientReqAccept      :: Seq Media.MediaType
 139  ,   clientReqHeaders     :: Seq HTTP.Header
 140  ,   clientReqBody        :: Maybe (Client.RequestBody, Media.MediaType)
 141  }
 142 instance Default ClientRequest where
 143         def = ClientRequest
 144          {    clientReqHttpVersion = HTTP.http11
 145          ,    clientReqMethod      = HTTP.methodGet
 146          ,    clientReqPath        = ""
 147          ,    clientReqQueryString = Seq.empty
 148          ,    clientReqAccept      = Seq.empty
 149          ,    clientReqHeaders     = Seq.empty
 150          ,    clientReqBody        = Nothing
 151          }
 152 instance Show ClientRequest where
 153         show _ = "ClientRequest"
 154
 155 clientRequest :: URI -> ClientRequest -> Client.Request
 156 clientRequest baseURI req =
 157         Client.defaultRequest
 158          { Client.method         = clientReqMethod req
 159          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
 160          , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
 161                                     Just (':':p) | Just port <- readMaybe p -> port
 162                                     _ -> 0
 163          , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
 164          , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
 165          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 166          , Client.requestBody
 167          , Client.secure         = URI.uriScheme baseURI == "https"
 168          }
 169         where
 170         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 171                 toList $ clientReqHeaders req
 172
 173         acceptHeader | null hs   = []
 174                      | otherwise = [("Accept", Media.renderHeader hs)]
 175                 where
 176                 hs = toList $ clientReqAccept req
 177
 178         (requestBody, contentTypeHeader) =
 179                 case clientReqBody req of
 180                  Nothing          -> (Client.RequestBodyLBS "", [])
 181                  Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 182
 183 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
 184 setClientRequestBodyLBS body mt req = req{ clientReqBody =
 185         Just (Client.RequestBodyLBS body, mt) }
 186
 187 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
 188 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
 189
 190 -- ** Type 'ClientResponse'
 191 type ClientResponse
 192  =   ClientResponseWithBody BSL.ByteString
 193 data ClientResponseWithBody a
 194  =   ClientResponse
 195  {   clientResStatus      :: HTTP.Status
 196  ,   clientResHeaders     :: Seq HTTP.Header
 197  ,   clientResHttpVersion :: HTTP.HttpVersion
 198  ,   clientResBody        :: a
 199  } deriving (Eq, Show, Functor)
 200
 201 clientResponse :: Client.Response a -> ClientResponseWithBody a
 202 clientResponse res =
 203         ClientResponse
 204          { clientResStatus      = Client.responseStatus res
 205          , clientResBody        = Client.responseBody res
 206          , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
 207          , clientResHttpVersion = Client.responseVersion res
 208          }
 209
 210 doClientRequest :: ClientRequest -> ClientConnection ClientResponse
 211 doClientRequest clientReq = do
 212         ClientEnv{..} <- MC.ask
 213         req <-
 214                 let req = clientRequest clientEnv_baseURI clientReq in
 215                 case clientEnv_cookieJar of
 216                  Nothing -> pure req
 217                  Just cj ->
 218                         liftIO $ do
 219                                 now <- Time.getCurrentTime
 220                                 STM.atomically $ do
 221                                         oldCookieJar <- STM.readTVar cj
 222                                         let (newRequest, newCookieJar) =
 223                                                 Client.insertCookiesIntoRequest req oldCookieJar now
 224                                         STM.writeTVar cj newCookieJar
 225                                         pure newRequest
 226         lrRes <-
 227                 liftIO $ catchClientConnectionError $
 228                 Client.httpLbs req clientEnv_manager
 229         case lrRes of
 230                 Left err -> MC.throw err
 231                 Right res -> do
 232                         for_ clientEnv_cookieJar $ \cj ->
 233                                 liftIO $ do
 234                                         now <- Time.getCurrentTime
 235                                         STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
 236                         let status    = HTTP.statusCode $ Client.responseStatus res
 237                             clientRes = clientResponse res
 238                         unless (status >= 200 && status < 300) $
 239                                 MC.throw $ ClientError_FailureResponse clientRes
 240                         return clientRes
 241
 242 catchClientConnectionError :: IO a -> IO (Either ClientError a)
 243 catchClientConnectionError action =
 244         Exn.catch (Right <$> action) $ \err ->
 245                 return $ Left $ ClientError_ClientConnectionError err
 246
 247 -- ** Type 'ClientResponseStreaming'
 248 newtype ClientResponseStreaming
 249  =      ClientResponseStreaming
 250  { runClientResponseStreaming ::
 251         forall a.
 252         (ClientResponseWithBody (IO BS.ByteString) -> IO a) ->
 253         IO a
 254  }
 255
 256 doClientRequestStreaming :: ClientRequest -> ClientConnection ClientResponseStreaming
 257 doClientRequestStreaming clientReq = do
 258         ClientEnv{..} <- MC.ask
 259         let req = clientRequest clientEnv_baseURI clientReq
 260         return $ ClientResponseStreaming $ \k ->
 261                 Client.withResponse req clientEnv_manager $ \res -> do
 262                         let status = HTTP.statusCode $ Client.responseStatus res
 263                         unless (status >= 200 && status < 300) $ do
 264                                 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
 265                                 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 266                         k $ clientResponse res
 267
 268 clientResMimeDecode ::
 269  forall ts m a.
 270  MimeTypes ts (MimeDecodable a) =>
 271  MC.MonadExcept ClientError m =>
 272  Proxy ts -> ClientResponse -> m a
 273 clientResMimeDecode Proxy clientRes = do
 274         let mtRes =
 275                 fromMaybe "application/octet-stream" $
 276                 List.lookup "Content-Type" $ toList $ clientResHeaders clientRes
 277         case matchContent @ts @(MimeDecodable a) mtRes of
 278          Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 279          Just (MimeType mt) ->
 280                 case mimeDecode mt $ clientResBody clientRes of
 281                  Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
 282                  Right val -> return val