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