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