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