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