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