Language/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 Language.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 Language.Symantic.HTTP.Media
  50 import Language.Symantic.HTTP.Mime
  51 import Language.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         mimeUnserializeResponse (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
 145 clientRequest :: URI -> ClientRequest -> Client.Request
 146 clientRequest baseURI req =
 147         Client.defaultRequest
 148          { Client.method         = clientReqMethod req
 149          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
 150          , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
 151                                     Just (':':p) | Just port <- readMaybe p -> port
 152                                     _ -> 0
 153          , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
 154          , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
 155          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 156          , Client.requestBody
 157          , Client.secure         = URI.uriScheme baseURI == "https"
 158          }
 159         where
 160         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 161                 toList $ clientReqHeaders req
 162
 163         acceptHeader | null hs   = []
 164                      | otherwise = [("Accept", Media.renderHeader hs)]
 165                 where
 166                 hs = toList $ clientReqAccept req
 167
 168         (requestBody, contentTypeHeader) =
 169                 case clientReqBody req of
 170                  Nothing          -> (Client.RequestBodyLBS "", [])
 171                  Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 172
 173 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
 174 setClientRequestBodyLBS body mt req = req{ clientReqBody = Just (Client.RequestBodyLBS body, mt) }
 175
 176 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
 177 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
 178
 179 -- ** Type 'ClientResponse'
 180 type ClientResponse = ClientResponseWithBody BSL.ByteString
 181 data ClientResponseWithBody a = ClientResponse
 182  { clientResStatus      :: HTTP.Status
 183  , clientResHeaders     :: Seq HTTP.Header
 184  , clientResHttpVersion :: HTTP.HttpVersion
 185  , clientResBody        :: a
 186  } deriving (Eq, Show, Functor)
 187
 188 clientResponse :: Client.Response a -> ClientResponseWithBody a
 189 clientResponse res =
 190         ClientResponse
 191          { clientResStatus      = Client.responseStatus res
 192          , clientResBody        = Client.responseBody res
 193          , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
 194          , clientResHttpVersion = Client.responseVersion res
 195          }
 196
 197 doClientRequest :: ClientRequest -> Client ClientResponse
 198 doClientRequest clientReq = do
 199         ClientEnv{..} <- MC.ask
 200         req <-
 201                 let req = clientRequest clientEnv_baseURI clientReq in
 202                 case clientEnv_cookieJar of
 203                  Nothing -> pure req
 204                  Just cj ->
 205                         MC.exec $ do
 206                                 now <- Time.getCurrentTime
 207                                 STM.atomically $ do
 208                                         oldCookieJar <- STM.readTVar cj
 209                                         let (newRequest, newCookieJar) =
 210                                                 Client.insertCookiesIntoRequest req oldCookieJar now
 211                                         STM.writeTVar cj newCookieJar
 212                                         pure newRequest
 213         lrRes <-
 214                 MC.exec $ catchConnectionError $
 215                 Client.httpLbs req clientEnv_manager
 216         case lrRes of
 217                 Left err -> MC.throw err
 218                 Right res -> do
 219                         for_ clientEnv_cookieJar $ \cj ->
 220                                 MC.exec $ do
 221                                         now <- Time.getCurrentTime
 222                                         STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
 223                         let status    = HTTP.statusCode $ Client.responseStatus res
 224                             clientRes = clientResponse res
 225                         unless (status >= 200 && status < 300) $
 226                                 MC.throw $ ClientError_FailureResponse clientRes
 227                         return clientRes
 228
 229 catchConnectionError :: IO a -> IO (Either ClientError a)
 230 catchConnectionError action =
 231         Exn.catch (Right <$> action) $ \err ->
 232                 return $ Left $ ClientError_ConnectionError err
 233
 234 -- ** Type 'ClientResponseStreaming'
 235 newtype ClientResponseStreaming = ClientResponseStreaming
 236  { runResponseStreaming ::
 237      forall a. (ClientResponseWithBody (IO BS.ByteString) -> IO a) -> IO a }
 238
 239 doClientRequestStreaming :: ClientRequest -> Client ClientResponseStreaming
 240 doClientRequestStreaming clientReq = do
 241         ClientEnv{..} <- MC.ask
 242         let req = clientRequest clientEnv_baseURI clientReq
 243         return $ ClientResponseStreaming $ \k ->
 244                 Client.withResponse req clientEnv_manager $ \res -> do
 245                         let status = HTTP.statusCode $ Client.responseStatus res
 246                         unless (status >= 200 && status < 300) $ do
 247                                 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
 248                                 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 249                         k $ clientResponse res
 250
 251 getContentType ::
 252  MC.MonadExcept ClientError m =>
 253  ClientResponse -> m MediaType
 254 getContentType clientRes =
 255         case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
 256          Nothing -> return $ "application"Media.//"octet-stream"
 257          Just mt ->
 258                 case Media.parseAccept mt of
 259                  Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
 260                  Just mt' -> return mt'
 261
 262 mimeUnserializeResponse ::
 263  MimeUnserialize mt a =>
 264  MC.MonadExcept ClientError m =>
 265  Proxy mt -> ClientResponse -> m a
 266 mimeUnserializeResponse mt clientRes = do
 267         mtRes <- getContentType clientRes
 268         unless (any (Media.matches mtRes) $ mediaTypes mt) $
 269                 MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 270         case mimeUnserialize mt $ clientResBody clientRes of
 271          Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
 272          Right val -> return val