symantic-http-client/Symantic/HTTP/Client.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE StrictData #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
   8 -- for an example of how to use this module.
   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.Either (Either(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Foldable (null, for_, toList)
  18 import Data.Function (($), (.), id, on)
  19 import Data.Functor (Functor(..), (<$>))
  20 import Data.Maybe (Maybe(..), maybe, fromMaybe)
  21 import Data.Ord (Ord(..))
  22 import Data.Proxy (Proxy(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.String (IsString(..))
  25 import Data.Text (Text)
  26 import Data.Traversable (sequence)
  27 import Data.Tuple (fst)
  28 import GHC.Exts (fromList)
  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.Base64 as BS64
  39 import qualified Data.ByteString.Builder as BSB
  40 import qualified Data.ByteString.Lazy as BSL
  41 import qualified Data.IORef as IO
  42 import qualified Data.List as List
  43 import qualified Data.List.NonEmpty as NonEmpty
  44 import qualified Data.Sequence as Seq
  45 import qualified Data.Text as Text
  46 import qualified Data.Text.Encoding as Text
  47 import qualified Data.Time.Clock as Time
  48 import qualified Network.HTTP.Client as Client
  49 import qualified Network.HTTP.Media as Media
  50 import qualified Network.HTTP.Types as HTTP
  51 import qualified Network.URI as URI
  52 import qualified Web.HttpApiData as Web
  53
  54 import Symantic.HTTP.API
  55 import Symantic.HTTP.URI
  56 import Symantic.HTTP.MIME
  57
  58 -- * Type 'Client'
  59 -- | (@'Client' a k@) is a recipe to produce a 'ClientRequest'
  60 -- from returned ('callers') (one per number of alternative routes)
  61 -- separated by (':!:').
  62 --
  63 -- 'Client' is analogous to a printf using the API as a format customized for HTTP routing.
  64 newtype Client callers k
  65  =      Client
  66  {    unClient :: (ClientModifier -> k) -> callers
  67  }
  68
  69 -- | @'client' callers@ returns the 'ClientRequest'
  70 -- builders from the given API.
  71 client :: Client callers ClientRequest -> callers
  72 client (Client callers) = callers ($ ini)
  73         where
  74         ini = ClientRequest
  75          {    clientReq_httpVersion = HTTP.http11
  76          ,    clientReq_method      = HTTP.methodGet
  77          ,    clientReq_path        = ""
  78          ,    clientReq_queryString = Seq.empty
  79          ,    clientReq_accept      = Seq.empty
  80          ,    clientReq_headers     = Seq.empty
  81          ,    clientReq_body        = Nothing
  82          }
  83
  84 -- ** Type 'ClientModifier'
  85 type ClientModifier = ClientRequest -> ClientRequest
  86
  87 instance Cat Client where
  88         Client x <.> Client y = Client $ \k ->
  89                 x $ \fx -> y $ \fy -> k $ fy . fx
  90 instance Alt Client where
  91         Client x <!> Client y = Client $ \k ->
  92                 x k :!: y k
  93         {-
  94         type AltMerge Client = (:!:)
  95         Client x <!> Client y = Client $ \k ->
  96                 x (\cm -> let n:!:_ = k cm in n) :!:
  97                 y (\cm -> let _:!:n = k cm in n)
  98         -}
  99         -- try = id -- FIXME: see what to do
 100 instance Pro Client where
 101         dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
 102
 103 instance HTTP_Path Client where
 104         type PathConstraint Client a = Web.ToHttpApiData a
 105         segment s = Client $ \k -> k $ \req ->
 106                 req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece s }
 107         capture' _n = Client $ \k a -> k $ \req ->
 108                 req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece a }
 109         captureAll = Client $ \k ss -> k $ \req ->
 110                 req{ clientReq_path =
 111                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
 112                         Web.toUrlPiece <$> ss
 113                  }
 114 instance HTTP_Header Client where
 115         header n = Client $ \k v -> k $ \req ->
 116                 req{ clientReq_headers = clientReq_headers req Seq.|> (n, Web.toHeader v) }
 117 instance HTTP_BasicAuth Client where
 118         type BasicAuthConstraint Client a = ()
 119         type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
 120         basicAuth' realm = Client $ \k user pass -> k $ \req ->
 121                 req{ clientReq_headers =
 122                         let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
 123                         clientReq_headers req Seq.|>
 124                          ( HTTP.hAuthorization
 125                          , Web.toHeader $ "Basic " <> BS64.encode user_pass
 126                          )
 127                  }
 128 instance HTTP_Query Client where
 129         type QueryConstraint Client a = Web.ToHttpApiData a
 130         queryParams' n = Client $ \k vs -> k $ \req ->
 131                 req{ clientReq_queryString =
 132                         clientReq_queryString req <>
 133                         fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
 134 instance HTTP_Version Client where
 135         version v = Client $ \k -> k $ \req ->
 136                 req{clientReq_httpVersion = v}
 137
 138 -- ** Type 'ClientBodyArg'
 139 newtype ClientBodyArg (ts::[*]) a = ClientBodyArg a
 140 instance HTTP_Body Client where
 141         type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
 142         type BodyArg Client a ts = ClientBodyArg ts a
 143         body' ::
 144          forall a ts k repr.
 145          BodyConstraint repr a ts =>
 146          repr ~ Client =>
 147          repr (BodyArg repr a ts -> k) k
 148         body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
 149                 req{clientReq_body =
 150                         case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
 151                          MimeType (mt::Proxy t) ->
 152                                 Just
 153                                  ( Client.RequestBodyLBS $ mimeEncode mt a
 154                                  , mediaType @t )
 155                  }
 156
 157 -- ** Type 'ClientBodyStreamArg'
 158 newtype ClientBodyStreamArg framing (ts::[*]) as = ClientBodyStreamArg as
 159 instance HTTP_BodyStream Client where
 160         type BodyStreamConstraint Client as ts framing =
 161          ( FramingEncode framing as
 162          , MimeTypes ts (MimeEncodable (FramingYield as))
 163          )
 164         type BodyStreamArg Client as ts framing = ClientBodyStreamArg framing ts as
 165         bodyStream' ::
 166          forall as ts framing k repr.
 167          BodyStreamConstraint repr as ts framing =>
 168          repr ~ Client =>
 169          repr (BodyStreamArg repr as ts framing -> k) k
 170         bodyStream'= Client $ \k (ClientBodyStreamArg as) -> k $ \req ->
 171                 req{clientReq_body =
 172                         case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable (FramingYield as)) of
 173                          MimeType (mt::Proxy t) ->
 174                                 Just $ (, mediaType @t) $
 175                                         Client.RequestBodyStreamChunked $ \write -> do
 176                                                 let enc = framingEncode (Proxy @framing) (mimeEncode mt)
 177                                                 ini <- enc as
 178                                                 ioref <- IO.newIORef ini
 179                                                 let go curr =
 180                                                         case curr of
 181                                                          Left _end -> return ""
 182                                                          Right (bsl, next)
 183                                                           | BSL.null bsl -> enc next >>= go
 184                                                                 -- NOTE: skip all null 'ByteString' because it would end the stream.
 185                                                           | otherwise -> enc next >>= \n -> do
 186                                                                 IO.writeIORef ioref n
 187                                                                 return $ BSL.toStrict bsl
 188                                                                 -- NOTE: strictify the 'bsl' 'ByteString'
 189                                                                 -- instead of iterating on its chunks,
 190                                                                 -- in order to diminish the number of 'Client.connectionWrite'.
 191                                                 write $ IO.readIORef ioref >>= go
 192                  }
 193
 194 instance HTTP_Response Client where
 195         type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
 196         type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
 197         type Response Client = ClientRequest
 198         response ::
 199          forall a ts repr.
 200          ResponseConstraint repr a ts =>
 201          repr ~ Client =>
 202          HTTP.Method ->
 203          repr (ResponseArgs repr a ts)
 204               (Response repr)
 205         response m = Client $ \k Proxy Proxy -> k $ \req ->
 206                 req
 207                  { clientReq_method = m
 208                  , clientReq_accept =
 209                         clientReq_accept req <>
 210                         fromList (toList $ mediaTypes @ts @(MimeDecodable a))
 211                  }
 212
 213 instance HTTP_ResponseStream Client where
 214         type ResponseStreamConstraint Client as ts framing =
 215                 MimeTypes ts (MimeDecodable (FramingYield as))
 216         type ResponseStreamArgs Client as ts framing =
 217                 Proxy framing ->
 218                 Proxy ts ->
 219                 Proxy as ->
 220                 ClientRequest
 221         type ResponseStream Client = ClientRequest
 222
 223         responseStream ::
 224          forall as ts framing repr.
 225          ResponseStreamConstraint repr as ts framing =>
 226          repr ~ Client =>
 227          HTTP.Method ->
 228          repr (ResponseStreamArgs repr as ts framing)
 229               (ResponseStream repr)
 230         responseStream m = Client $ \k Proxy Proxy Proxy -> k $ \req ->
 231                 req
 232                  { clientReq_method = m
 233                  , clientReq_accept =
 234                         clientReq_accept req <>
 235                         fromList (toList $ mediaTypes @ts @(MimeDecodable (FramingYield as)))
 236                  }
 237
 238 instance Web.ToHttpApiData BS.ByteString where
 239         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
 240         toHeader = id
 241
 242 -- * Type 'ClientConn'
 243 -- | A monadic connection from a client to a server.
 244 -- It is specialized in 'ClientConnection' and 'ClientConnectionStream'.
 245 --
 246 -- NOTE: no 'Monad' transformer is put within this newtype
 247 -- to let @monad-classes@ handle all the |lift|ing.
 248 newtype ClientConn m a
 249  =      ClientConn
 250  {    unClientConn :: m a
 251  } deriving (Functor, Applicative, Monad)
 252 -- | All supported effects are handled by nested 'Monad's.
 253 type instance MC.CanDo (ClientConn m) eff = 'False
 254 instance MonadTrans ClientConn where
 255         lift = ClientConn
 256
 257 -- ** Type 'ClientEnv'
 258 data ClientEnv
 259  =   ClientEnv
 260  {   clientEnv_manager   :: Client.Manager
 261  ,   clientEnv_baseURI   :: URI
 262  ,   clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
 263  }
 264 clientEnv :: Client.Manager -> URI -> ClientEnv
 265 clientEnv clientEnv_manager clientEnv_baseURI =
 266         ClientEnv
 267          { clientEnv_cookieJar = Nothing
 268          , ..
 269          }
 270
 271 -- ** Type 'ClientError'
 272 data ClientError
 273      -- | The server returned an error response
 274  =   ClientError_FailureResponse ClientResponse
 275      -- | The body could not be decoded at the expected type
 276  |   ClientError_DecodeFailure Text ClientResponse
 277      -- | The content-type of the response is not supported
 278  |   ClientError_UnsupportedContentType BS.ByteString ClientResponse
 279      -- | There was a connection error, and no response was received
 280  |   ClientError_ConnectionError Client.HttpException
 281      -- | 'ClientConn' is 'empty'
 282  |   ClientError_EmptyClient
 283  deriving (Eq, Show{-, Generic, Typeable-})
 284 instance Exn.Exception ClientError
 285 instance Eq Client.HttpException where
 286         (==) = (==) `on` show
 287
 288 -- ** Type 'ClientRequest'
 289 data ClientRequest
 290  =   ClientRequest
 291  {   clientReq_httpVersion :: HTTP.HttpVersion
 292  ,   clientReq_method      :: HTTP.Method
 293  ,   clientReq_path        :: BSB.Builder
 294  ,   clientReq_queryString :: Seq.Seq HTTP.QueryItem
 295  ,   clientReq_accept      :: Seq.Seq Media.MediaType
 296  ,   clientReq_headers     :: Seq.Seq HTTP.Header
 297  ,   clientReq_body        :: Maybe (Client.RequestBody, Media.MediaType)
 298  }
 299 instance Show ClientRequest where
 300         show _ = "ClientRequest"
 301
 302 clientRequest :: URI -> ClientRequest -> Client.Request
 303 clientRequest baseURI req =
 304         Client.defaultRequest
 305          { Client.method         = clientReq_method req
 306          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
 307          , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
 308                                     Just (':':p) | Just port <- readMaybe p -> port
 309                                     _ -> 0
 310          , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReq_path req)
 311          , Client.queryString    = HTTP.renderQuery True . toList $ clientReq_queryString req
 312          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 313          , Client.requestBody
 314          , Client.secure         = URI.uriScheme baseURI == "https"
 315          }
 316         where
 317         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 318                 toList $ clientReq_headers req
 319
 320         acceptHeader | null hs   = []
 321                      | otherwise = [("Accept", Media.renderHeader hs)]
 322                 where
 323                 hs = toList $ clientReq_accept req
 324
 325         (requestBody, contentTypeHeader) =
 326                 case clientReq_body req of
 327                  Nothing -> (Client.RequestBodyBS "", [])
 328                  Just (b, mt) -> (b, [(HTTP.hContentType, Media.renderHeader mt)])
 329
 330 -- ** Type 'ClientConnection'
 331 type ClientConnection
 332  =   ClientConn (R.ReaderT ClientEnv (E.ExceptT ClientError IO))
 333
 334 {-
 335 -- | Try clients in order, last error is preserved.
 336 instance Alternative ClientConnection where
 337         empty = MC.throw $ ClientError_EmptyClient
 338         x <|> y = ClientConn $ do
 339                 env <- MC.ask
 340                 MC.exec @IO (E.runExceptT $ R.runReaderT (unClientConn x) env) >>= \case
 341                  Right xa -> return xa
 342                  Left _err -> unClientConn y
 343 -}
 344
 345 runClient ::
 346  MimeTypes ts (MimeDecodable a) =>
 347  ClientEnv ->
 348  (Proxy ts -> Proxy a -> ClientRequest) ->
 349  IO (Either ClientError a)
 350 runClient env =
 351         E.runExceptT .
 352         (`R.runReaderT` env) .
 353         unClientConn .
 354         clientConnection
 355
 356 clientConnection ::
 357  forall a ts.
 358  MimeTypes ts (MimeDecodable a) =>
 359  (Proxy ts -> Proxy a -> ClientRequest) ->
 360  ClientConnection a
 361 clientConnection req = do
 362         clientRes <- doClientRequest $ req (Proxy::Proxy ts) (Proxy::Proxy a)
 363         let mtRes =
 364                 fromMaybe "application/octet-stream" $
 365                 List.lookup "Content-Type" $
 366                 Client.responseHeaders clientRes
 367         case matchContent @ts @(MimeDecodable a) mtRes of
 368          Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 369          Just (MimeType mt) ->
 370                 case mimeDecode mt $ Client.responseBody clientRes of
 371                  Left  err -> MC.throw $ ClientError_DecodeFailure (Text.pack err) clientRes
 372                  Right val -> return val
 373
 374 doClientRequest :: ClientRequest -> ClientConnection ClientResponse
 375 doClientRequest clientReq = do
 376         ClientEnv{..} <- MC.ask
 377         req <-
 378                 let req = clientRequest clientEnv_baseURI clientReq in
 379                 case clientEnv_cookieJar of
 380                  Nothing -> pure req
 381                  Just cj ->
 382                         MC.exec @IO $ do
 383                                 now <- Time.getCurrentTime
 384                                 STM.atomically $ do
 385                                         oldCookieJar <- STM.readTVar cj
 386                                         let (newRequest, newCookieJar) =
 387                                                 Client.insertCookiesIntoRequest req oldCookieJar now
 388                                         STM.writeTVar cj newCookieJar
 389                                         pure newRequest
 390         lrRes <-
 391                 MC.exec @IO $ catchClientConnectionError $
 392                 Client.httpLbs req clientEnv_manager
 393         case lrRes of
 394                 Left err -> MC.throw err
 395                 Right res -> do
 396                         for_ clientEnv_cookieJar $ \cj ->
 397                                 MC.exec @IO $ do
 398                                         now <- Time.getCurrentTime
 399                                         STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
 400                         let code = HTTP.statusCode $ Client.responseStatus res
 401                         unless (code >= 200 && code < 300) $
 402                                 MC.throw $ ClientError_FailureResponse res
 403                         return res
 404
 405 catchClientConnectionError :: IO a -> IO (Either ClientError a)
 406 catchClientConnectionError ma =
 407         Exn.catch (Right <$> ma) $ \err ->
 408                 return $ Left $ ClientError_ConnectionError err
 409
 410 -- *** Type 'ClientResponse'
 411 type ClientResponse
 412  =   Client.Response BSL.ByteString
 413
 414 -- ** Type 'ClientConnectionStream'
 415 type ClientConnectionStream
 416  =   ClientConn (R.ReaderT ClientEnv (Codensity (E.ExceptT ClientError IO)))
 417
 418 runClientStream ::
 419  FramingDecode framing as =>
 420  MC.MonadExec IO (FramingMonad as) =>
 421  MimeTypes ts (MimeDecodable (FramingYield as)) =>
 422  ClientEnv ->
 423  (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
 424  (as -> IO b) -> IO (Either ClientError b)
 425 runClientStream env req k =
 426         E.runExceptT $
 427         (`runCodensity` lift . k) $
 428         (`R.runReaderT` env) $
 429         unClientConn $
 430         clientConnectionStream req
 431
 432 clientConnectionStream ::
 433  forall as ts framing.
 434  FramingDecode framing as =>
 435  MC.MonadExec IO (FramingMonad as) =>
 436  MimeTypes ts (MimeDecodable (FramingYield as)) =>
 437  (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
 438  ClientConnectionStream as
 439 clientConnectionStream req = do
 440         doClientRequestStream (Proxy::Proxy ts) (req Proxy Proxy Proxy) $ \(MimeType mt) clientRes ->
 441                 return $
 442                         framingDecode (Proxy @framing) (mimeDecode mt) $
 443                                 MC.exec @IO $ Client.responseBody clientRes
 444
 445 doClientRequestStream ::
 446  forall (ts::[*]) as.
 447  MimeTypes ts (MimeDecodable (FramingYield as)) =>
 448  Proxy ts ->
 449  ClientRequest ->
 450  ( MimeType (MimeDecodable (FramingYield as)) ->
 451    Client.Response Client.BodyReader ->
 452    E.ExceptT ClientError IO as ) ->
 453  ClientConnectionStream as
 454 doClientRequestStream Proxy clientReq k = do
 455         ClientEnv{..} <- MC.ask
 456         let req = clientRequest clientEnv_baseURI $ clientReq
 457         ClientConn $ lift $ Codensity $ \k' ->
 458                 E.ExceptT $ Client.withResponse req clientEnv_manager $ \res ->
 459                         E.runExceptT $ do{-E.ExceptT ClientError IO-}
 460                                 -- Check status
 461                                 let code = HTTP.statusCode $ Client.responseStatus res
 462                                 unless (code >= 200 && code < 300) $ do
 463                                         err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
 464                                         E.throwE $ ClientError_FailureResponse err
 465                                 -- Check Content-Type header
 466                                 let contentTypeH =
 467                                         fromMaybe "application/octet-stream" $
 468                                         List.lookup "Content-Type" $
 469                                         Client.responseHeaders res
 470                                 case matchContent @ts @(MimeDecodable (FramingYield as)) contentTypeH of
 471                                  Nothing -> do
 472                                         err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
 473                                         E.throwE $ ClientError_UnsupportedContentType contentTypeH err
 474                                  Just ct -> k ct res >>= k'
 475
 476 -- *** Type 'Codensity'
 477 -- | Copy from the @kan-extensions@ package to avoid the dependencies.
 478 newtype Codensity m a
 479  =      Codensity
 480  {   runCodensity :: forall b. (a -> m b) -> m b }
 481 type instance MC.CanDo (Codensity m) (MC.EffExec eff) = 'False
 482 instance Functor (Codensity k) where
 483         fmap f (Codensity m) = Codensity (\k -> m (k .f))
 484         {-# INLINE fmap #-}
 485 instance Applicative (Codensity f) where
 486         pure x = Codensity (\k -> k x)
 487         {-# INLINE pure #-}
 488         Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))
 489         {-# INLINE (<*>) #-}
 490 instance Monad (Codensity f) where
 491         return = pure
 492         {-# INLINE return #-}
 493         m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))
 494         {-# INLINE (>>=) #-}
 495 instance MonadTrans Codensity where
 496         lift m = Codensity (m >>=)
 497         {-# INLINE lift #-}