Symantic/HTTP/Client.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 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.Media
  50 import Symantic.HTTP.Mime
  51 import Symantic.HTTP.URI
  52
  53 -- * Type 'Client'
  54 newtype Client a = Client { unClient :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a }
  55  deriving (Functor, Applicative, Monad)
  56 type instance MC.CanDo Client (MC.EffReader ClientEnv)   = 'True
  57 type instance MC.CanDo Client (MC.EffExcept ClientError) = 'True
  58 type instance MC.CanDo Client (MC.EffExec   IO)          = 'True
  59 instance MC.MonadExceptN 'MC.Zero ClientError Client where
  60         throwN px = Client . lift . MC.throwN px
  61 instance MC.MonadReaderN 'MC.Zero ClientEnv Client where
  62         askN px = Client $ MC.askN px
  63 instance MC.MonadExecN 'MC.Zero IO Client where
  64         execN _px = Client . lift . lift
  65
  66 -- | Try clients in order, last error is preserved.
  67 instance Alternative Client where
  68         empty = MC.throw $ ClientError_EmptyClient
  69         x <|> y = Client $ do
  70                 env <- MC.ask
  71                 MC.exec (runClient env x) >>= \case
  72                  Right xa -> return xa
  73                  Left _err -> unClient y
  74
  75 client ::
  76  forall mt a.
  77  MimeUnserialize mt a =>
  78  (ClientRequestType mt a -> ClientRequest) -> Client a
  79 client req = do
  80         clientRes <- doClientRequest $ req ClientRequestType
  81         clientResMimeUnserialize (Proxy::Proxy mt) clientRes
  82
  83 runClient :: ClientEnv -> Client a -> IO (Either ClientError a)
  84 runClient env (Client c) = E.runExceptT $ R.runReaderT c env
  85
  86 runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
  87 runClientRequest env req = runClient env (doClientRequest req)
  88
  89 -- ** Type 'ClientRequestType'
  90 data ClientRequestType mt a = ClientRequestType
  91
  92 -- ** Type 'ClientEnv'
  93 data ClientEnv = ClientEnv
  94  { clientEnv_manager   :: Client.Manager
  95  , clientEnv_baseURI   :: URI
  96  , clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
  97  }
  98 clientEnv :: Client.Manager -> URI -> ClientEnv
  99 clientEnv clientEnv_manager clientEnv_baseURI =
 100         ClientEnv
 101          { clientEnv_cookieJar = Nothing
 102          , ..
 103          }
 104
 105 -- ** Type 'ClientError'
 106 data ClientError
 107    -- | The server returned an error response
 108    = ClientError_FailureResponse ClientResponse
 109    -- | The body could not be decoded at the expected type
 110    | ClientError_DecodeFailure Text ClientResponse
 111    -- | The content-type of the response is not supported
 112    | ClientError_UnsupportedContentType MediaType ClientResponse
 113    -- | The content-type header is invalid
 114    | ClientError_InvalidContentTypeHeader ClientResponse
 115    -- | There was a connection error, and no response was received
 116    | ClientError_ConnectionError Client.HttpException
 117    -- | 'Client' is 'empty'
 118    | ClientError_EmptyClient
 119    deriving (Eq, Show{-, Generic, Typeable-})
 120 instance Exn.Exception ClientError
 121 instance Eq Client.HttpException where
 122         (==) = (==) `on` show
 123
 124 -- * Type 'ClientRequest'
 125 data ClientRequest = ClientRequest
 126  { clientReqHttpVersion :: HTTP.HttpVersion
 127  , clientReqMethod      :: HTTP.Method
 128  , clientReqPath        :: BSB.Builder
 129  , clientReqQueryString :: Seq HTTP.QueryItem
 130  , clientReqAccept      :: Seq Media.MediaType
 131  , clientReqHeaders     :: Seq HTTP.Header
 132  , clientReqBody        :: Maybe (Client.RequestBody, Media.MediaType)
 133  }
 134 instance Default ClientRequest where
 135         def = ClientRequest
 136          { clientReqHttpVersion = HTTP.http11
 137          , clientReqMethod      = HTTP.methodGet
 138          , clientReqPath        = ""
 139          , clientReqQueryString = Seq.empty
 140          , clientReqAccept      = Seq.empty
 141          , clientReqHeaders     = Seq.empty
 142          , clientReqBody        = Nothing
 143          }
 144 instance Show ClientRequest where
 145         show _ = "ClientRequest"
 146
 147 clientRequest :: URI -> ClientRequest -> Client.Request
 148 clientRequest baseURI req =
 149         Client.defaultRequest
 150          { Client.method         = clientReqMethod req
 151          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
 152          , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
 153                                     Just (':':p) | Just port <- readMaybe p -> port
 154                                     _ -> 0
 155          , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
 156          , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
 157          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 158          , Client.requestBody
 159          , Client.secure         = URI.uriScheme baseURI == "https"
 160          }
 161         where
 162         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 163                 toList $ clientReqHeaders req
 164
 165         acceptHeader | null hs   = []
 166                      | otherwise = [("Accept", Media.renderHeader hs)]
 167                 where
 168                 hs = toList $ clientReqAccept req
 169
 170         (requestBody, contentTypeHeader) =
 171                 case clientReqBody req of
 172                  Nothing          -> (Client.RequestBodyLBS "", [])
 173                  Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 174
 175 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
 176 setClientRequestBodyLBS body mt req = req{ clientReqBody =
 177         Just (Client.RequestBodyLBS body, mt) }
 178
 179 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
 180 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
 181
 182 -- ** Type 'ClientResponse'
 183 type ClientResponse = ClientResponseWithBody BSL.ByteString
 184 data ClientResponseWithBody a = ClientResponse
 185  { clientResStatus      :: HTTP.Status
 186  , clientResHeaders     :: Seq HTTP.Header
 187  , clientResHttpVersion :: HTTP.HttpVersion
 188  , clientResBody        :: a
 189  } deriving (Eq, Show, Functor)
 190
 191 clientResponse :: Client.Response a -> ClientResponseWithBody a
 192 clientResponse res =
 193         ClientResponse
 194          { clientResStatus      = Client.responseStatus res
 195          , clientResBody        = Client.responseBody res
 196          , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
 197          , clientResHttpVersion = Client.responseVersion res
 198          }
 199
 200 doClientRequest :: ClientRequest -> Client ClientResponse
 201 doClientRequest clientReq = do
 202         ClientEnv{..} <- MC.ask
 203         req <-
 204                 let req = clientRequest clientEnv_baseURI clientReq in
 205                 case clientEnv_cookieJar of
 206                  Nothing -> pure req
 207                  Just cj ->
 208                         MC.exec $ do
 209                                 now <- Time.getCurrentTime
 210                                 STM.atomically $ do
 211                                         oldCookieJar <- STM.readTVar cj
 212                                         let (newRequest, newCookieJar) =
 213                                                 Client.insertCookiesIntoRequest req oldCookieJar now
 214                                         STM.writeTVar cj newCookieJar
 215                                         pure newRequest
 216         lrRes <-
 217                 MC.exec $ catchConnectionError $
 218                 Client.httpLbs req clientEnv_manager
 219         case lrRes of
 220                 Left err -> MC.throw err
 221                 Right res -> do
 222                         for_ clientEnv_cookieJar $ \cj ->
 223                                 MC.exec $ do
 224                                         now <- Time.getCurrentTime
 225                                         STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
 226                         let status    = HTTP.statusCode $ Client.responseStatus res
 227                             clientRes = clientResponse res
 228                         unless (status >= 200 && status < 300) $
 229                                 MC.throw $ ClientError_FailureResponse clientRes
 230                         return clientRes
 231
 232 catchConnectionError :: IO a -> IO (Either ClientError a)
 233 catchConnectionError action =
 234         Exn.catch (Right <$> action) $ \err ->
 235                 return $ Left $ ClientError_ConnectionError err
 236
 237 -- ** Type 'ClientResponseStreaming'
 238 newtype ClientResponseStreaming = ClientResponseStreaming
 239  { runResponseStreaming ::
 240      forall a. (ClientResponseWithBody (IO BS.ByteString) -> IO a) -> IO a }
 241
 242 doClientRequestStreaming :: ClientRequest -> Client ClientResponseStreaming
 243 doClientRequestStreaming clientReq = do
 244         ClientEnv{..} <- MC.ask
 245         let req = clientRequest clientEnv_baseURI clientReq
 246         return $ ClientResponseStreaming $ \k ->
 247                 Client.withResponse req clientEnv_manager $ \res -> do
 248                         let status = HTTP.statusCode $ Client.responseStatus res
 249                         unless (status >= 200 && status < 300) $ do
 250                                 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
 251                                 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 252                         k $ clientResponse res
 253
 254 clientResContentType ::
 255  MC.MonadExcept ClientError m =>
 256  ClientResponse -> m MediaType
 257 clientResContentType clientRes =
 258         case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
 259          Nothing -> return $ "application"Media.//"octet-stream"
 260          Just mt ->
 261                 case Media.parseAccept mt of
 262                  Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
 263                  Just mt' -> return mt'
 264
 265 clientResMimeUnserialize ::
 266  MimeUnserialize mt a =>
 267  MC.MonadExcept ClientError m =>
 268  Proxy mt -> ClientResponse -> m a
 269 clientResMimeUnserialize mt clientRes = do
 270         mtRes <- clientResContentType clientRes
 271         unless (any (Media.matches mtRes) $ mediaTypes mt) $
 272                 MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 273         case mimeUnserialize mt $ clientResBody clientRes of
 274          Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
 275          Right val -> return val