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 runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
  90 runClientRequest env = runClientConnection env . doClientRequest
  91
  92 -- ** Type 'ClientEnv'
  93 data ClientEnv
  94  =   ClientEnv
  95  {   clientEnv_manager   :: Client.Manager
  96  ,   clientEnv_baseURI   :: URI
  97  ,   clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
  98  }
  99 clientEnv :: Client.Manager -> URI -> ClientEnv
 100 clientEnv clientEnv_manager clientEnv_baseURI =
 101         ClientEnv
 102          { clientEnv_cookieJar = Nothing
 103          , ..
 104          }
 105
 106 -- ** Type 'ClientError'
 107 data ClientError
 108      -- | The server returned an error response
 109  =   ClientError_FailureResponse ClientResponse
 110      -- | The body could not be decoded at the expected type
 111  |   ClientError_DecodeFailure Text ClientResponse
 112      -- | The content-type of the response is not supported
 113  |   ClientError_UnsupportedContentType BS.ByteString ClientResponse
 114  {-
 115      -- | The content-type header is invalid
 116  |   ClientError_InvalidContentTypeHeader ClientResponse
 117  -}
 118      -- | There was a connection error, and no response was received
 119  |   ClientError_ClientConnectionectionError Client.HttpException
 120      -- | 'ClientConnection' is 'empty'
 121  |   ClientError_EmptyClient
 122  deriving (Eq, Show{-, Generic, Typeable-})
 123 instance Exn.Exception ClientError
 124 instance Eq Client.HttpException where
 125         (==) = (==) `on` show
 126
 127 -- * Type 'ClientRequest'
 128 data ClientRequest
 129  =   ClientRequest
 130  {   clientReqHttpVersion :: HTTP.HttpVersion
 131  ,   clientReqMethod      :: HTTP.Method
 132  ,   clientReqPath        :: BSB.Builder
 133  ,   clientReqQueryString :: Seq HTTP.QueryItem
 134  ,   clientReqAccept      :: Seq Media.MediaType
 135  ,   clientReqHeaders     :: Seq HTTP.Header
 136  ,   clientReqBody        :: Maybe (Client.RequestBody, Media.MediaType)
 137  }
 138 instance Default ClientRequest where
 139         def = ClientRequest
 140          {    clientReqHttpVersion = HTTP.http11
 141          ,    clientReqMethod      = HTTP.methodGet
 142          ,    clientReqPath        = ""
 143          ,    clientReqQueryString = Seq.empty
 144          ,    clientReqAccept      = Seq.empty
 145          ,    clientReqHeaders     = Seq.empty
 146          ,    clientReqBody        = Nothing
 147          }
 148 instance Show ClientRequest where
 149         show _ = "ClientRequest"
 150
 151 clientRequest :: URI -> ClientRequest -> Client.Request
 152 clientRequest baseURI req =
 153         Client.defaultRequest
 154          { Client.method         = clientReqMethod req
 155          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
 156          , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
 157                                     Just (':':p) | Just port <- readMaybe p -> port
 158                                     _ -> 0
 159          , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
 160          , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
 161          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 162          , Client.requestBody
 163          , Client.secure         = URI.uriScheme baseURI == "https"
 164          }
 165         where
 166         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 167                 toList $ clientReqHeaders req
 168
 169         acceptHeader | null hs   = []
 170                      | otherwise = [("Accept", Media.renderHeader hs)]
 171                 where
 172                 hs = toList $ clientReqAccept req
 173
 174         (requestBody, contentTypeHeader) =
 175                 case clientReqBody req of
 176                  Nothing          -> (Client.RequestBodyLBS "", [])
 177                  Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 178
 179 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
 180 setClientRequestBodyLBS body mt req = req{ clientReqBody =
 181         Just (Client.RequestBodyLBS body, mt) }
 182
 183 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
 184 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
 185
 186 -- ** Type 'ClientResponse'
 187 type ClientResponse
 188  =   ClientResponseWithBody BSL.ByteString
 189 data ClientResponseWithBody a
 190  =   ClientResponse
 191  {   clientResStatus      :: HTTP.Status
 192  ,   clientResHeaders     :: Seq HTTP.Header
 193  ,   clientResHttpVersion :: HTTP.HttpVersion
 194  ,   clientResBody        :: a
 195  } deriving (Eq, Show, Functor)
 196
 197 clientResponse :: Client.Response a -> ClientResponseWithBody a
 198 clientResponse res =
 199         ClientResponse
 200          { clientResStatus      = Client.responseStatus res
 201          , clientResBody        = Client.responseBody res
 202          , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
 203          , clientResHttpVersion = Client.responseVersion res
 204          }
 205
 206 doClientRequest :: ClientRequest -> ClientConnection ClientResponse
 207 doClientRequest clientReq = do
 208         ClientEnv{..} <- MC.ask
 209         req <-
 210                 let req = clientRequest clientEnv_baseURI clientReq in
 211                 case clientEnv_cookieJar of
 212                  Nothing -> pure req
 213                  Just cj ->
 214                         liftIO $ do
 215                                 now <- Time.getCurrentTime
 216                                 STM.atomically $ do
 217                                         oldCookieJar <- STM.readTVar cj
 218                                         let (newRequest, newCookieJar) =
 219                                                 Client.insertCookiesIntoRequest req oldCookieJar now
 220                                         STM.writeTVar cj newCookieJar
 221                                         pure newRequest
 222         lrRes <-
 223                 liftIO $ catchClientConnectionectionError $
 224                 Client.httpLbs req clientEnv_manager
 225         case lrRes of
 226                 Left err -> MC.throw err
 227                 Right res -> do
 228                         for_ clientEnv_cookieJar $ \cj ->
 229                                 liftIO $ do
 230                                         now <- Time.getCurrentTime
 231                                         STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
 232                         let status    = HTTP.statusCode $ Client.responseStatus res
 233                             clientRes = clientResponse res
 234                         unless (status >= 200 && status < 300) $
 235                                 MC.throw $ ClientError_FailureResponse clientRes
 236                         return clientRes
 237
 238 catchClientConnectionectionError :: IO a -> IO (Either ClientError a)
 239 catchClientConnectionectionError action =
 240         Exn.catch (Right <$> action) $ \err ->
 241                 return $ Left $ ClientError_ClientConnectionectionError err
 242
 243 -- ** Type 'ClientResponseStreaming'
 244 newtype ClientResponseStreaming
 245  =      ClientResponseStreaming
 246  { runClientResponseStreaming ::
 247         forall a.
 248         (ClientResponseWithBody (IO BS.ByteString) -> IO a) ->
 249         IO a
 250  }
 251
 252 doClientRequestStreaming :: ClientRequest -> ClientConnection ClientResponseStreaming
 253 doClientRequestStreaming clientReq = do
 254         ClientEnv{..} <- MC.ask
 255         let req = clientRequest clientEnv_baseURI clientReq
 256         return $ ClientResponseStreaming $ \k ->
 257                 Client.withResponse req clientEnv_manager $ \res -> do
 258                         let status = HTTP.statusCode $ Client.responseStatus res
 259                         unless (status >= 200 && status < 300) $ do
 260                                 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
 261                                 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 262                         k $ clientResponse res
 263
 264 clientResMimeDecode ::
 265  forall ts m a.
 266  MimeTypes ts (MimeDecodable a) =>
 267  MC.MonadExcept ClientError m =>
 268  Proxy ts -> ClientResponse -> m a
 269 clientResMimeDecode Proxy clientRes = do
 270         let mtRes =
 271                 fromMaybe "application/octet-stream" $
 272                 List.lookup "Content-Type" $ toList $ clientResHeaders clientRes
 273         case matchContent @ts @(MimeDecodable a) mtRes of
 274          Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 275          Just (MimeType mt) ->
 276                 case mimeDecode mt $ clientResBody clientRes of
 277                  Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
 278                  Right val -> return val