Symantic/HTTP/Client/Connection.hs

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