symantic-http/Symantic/HTTP/API.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
   6 -- | Combinators to build a Web API.
   7 module Symantic.HTTP.API where
   8
   9 import Control.Monad (Monad(..))
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Function ((.))
  14 import Data.Functor (Functor, (<$>))
  15 import Data.Kind (Constraint)
  16 import Data.Proxy (Proxy)
  17 import Data.String (String)
  18 import Data.Text (Text)
  19 import Prelude (and)
  20 import System.IO (IO)
  21 import Text.Show (Show(..))
  22 import qualified Data.ByteString as BS
  23 import qualified Data.ByteString.Lazy as BSL
  24 import qualified Network.HTTP.Types as HTTP
  25
  26 -- * Class 'Cat'
  27 -- | A soft and cute animal asking strokes and croquettes.
  28 -- Or rather here a composition of two combinators
  29 -- (as in a category without an identity morphism).
  30 --
  31 -- Note that the order of combinators generally matters (the left one is applied first),
  32 -- with the notable exception of the server instance
  33 -- where some HTTP error codes must be prioritized.
  34 class Cat repr where
  35         (<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
  36         -- Trans defaults
  37         default (<.>) ::
  38          Trans repr =>
  39          Cat (UnTrans repr) =>
  40          repr a b -> repr b c -> repr a c
  41         x <.> y = noTrans (unTrans x <.> unTrans y)
  42         -- (.>)  :: repr x y -> repr a c -> repr a c; infixl 4  .>
  43
  44 -- * Class 'Alt'
  45 -- | There are two choices, either the right one or the left one.
  46 -- The (':!:') data type will be used in the instances
  47 -- to get multiple client callers or to supply multiple server handlers.
  48 class Alt repr where
  49         {-
  50         type AltMerge repr :: * -> * -> *
  51         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
  52         -}
  53         (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
  54         -- Trans defaults
  55         default (<!>) ::
  56          Trans repr =>
  57          Alt (UnTrans repr) =>
  58          repr a k -> repr b k -> repr (a:!:b) k
  59         x <!> y = noTrans (unTrans x <!> unTrans y)
  60         -- try :: repr k k -> repr k k
  61         -- option :: k -> repr k k -> repr k k
  62
  63 -- ** Type (':!:')
  64 -- | Like @(,)@ but @infixl@.
  65 -- Used to get alternative commands from a 'Client'
  66 -- or to supply alternative handlers to a 'Server'.
  67 data (:!:) a b = a:!:b
  68 infixl 3 :!:
  69
  70 -- * Class 'Trans'
  71 -- | A 'Trans'formation from one representation @('UnTrans t')@ to another one: 't'.
  72 --
  73 -- * 'noTrans' lifts to the identity 'Trans'formation
  74 --   (the one which does nothing wrt. the 'UnTrans'formed @(repr)@esentation).
  75 -- * 'unTrans' unlifts a 'Trans'formed value to its underlying @(repr)@esentation.
  76 --
  77 -- At its @class@ definition,
  78 -- a combinator should be defined with a default value using 'noTrans'.
  79 -- And at its @instance@ definition,
  80 -- a combinator can be overwritten to apply a specific 'Trans'formation for 't'.
  81 class Trans t where
  82         -- | The @(repr)@esentation that 't' 'Trans'forms.
  83         type UnTrans t :: * -> * -> *
  84         -- | Lift the underlying @(repr)@esentation to 't'.
  85         -- Useful to define a combinator that does nothing in a 'Trans'formation.
  86         noTrans :: UnTrans t a b -> t a b
  87         -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
  88         -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
  89         -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
  90         -- from the inferred 't' value (eg. in 'server').
  91         unTrans :: t a b -> UnTrans t a b
  92
  93 -- * Class 'Pro'
  94 -- | Mainly useful to write a combinator which is a specialization of another
  95 -- (eg. 'queryFlag' wrt. 'queryParams'),
  96 -- by calling it directly in the class declaration
  97 -- instead of rewriting its logic in the instance declaration.
  98 --
  99 -- Because type @(a)@ is asked by a 'Client' but given to a 'Server',
 100 -- both @(a->b)@ and @(b->a)@ are used. This is reminiscent of a 'Profunctor'.
 101 -- Hence the names 'Pro' and 'dimap'.
 102 class Pro repr where
 103         dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
 104         -- Trans defaults
 105         default dimap ::
 106          Trans repr =>
 107          Pro (UnTrans repr) =>
 108          (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
 109         dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
 110
 111 -- * Class 'HTTP_Path'
 112 class HTTP_Path repr where
 113         type PathConstraint repr a :: Constraint
 114         segment :: PathSegment -> repr k k
 115         capture' :: PathConstraint repr a => Name -> repr (a -> k) k
 116         captureAll :: repr ([PathSegment] -> k) k
 117         -- Trans defaults
 118         type PathConstraint repr a = PathConstraint (UnTrans repr) a
 119         default segment ::
 120          Trans repr =>
 121          HTTP_Path (UnTrans repr) =>
 122          PathSegment -> repr k k
 123         default capture' ::
 124          Trans repr =>
 125          HTTP_Path (UnTrans repr) =>
 126          PathConstraint (UnTrans repr) a =>
 127          Name -> repr (a -> k) k
 128         default captureAll ::
 129          Trans repr =>
 130          HTTP_Path (UnTrans repr) =>
 131          repr ([PathSegment] -> k) k
 132         segment    = noTrans . segment
 133         capture'   = noTrans . capture'
 134         captureAll = noTrans captureAll
 135
 136 -- | Convenient wrapper of 'segment'.
 137 (</>) :: Cat repr => HTTP_Path repr => PathSegment -> repr a b -> repr a b
 138 (</>) n = (segment n <.>); infixr 5 </>
 139
 140 -- | Like 'capture'' but with the type variable @(a)@ first instead or @(repr)@
 141 -- so it can be passed using 'TypeApplications' without adding a @@_@ for @(repr)@.
 142 capture ::
 143  forall a k repr.
 144  HTTP_Path repr =>
 145  PathConstraint repr a =>
 146  Name -> repr (a -> k) k
 147 capture = capture'
 148 {-# INLINE capture #-}
 149
 150 type PathSegment = Text
 151 type Path = [PathSegment]
 152 type Name = String
 153
 154 -- * Class 'HTTP_Header'
 155 class HTTP_Header repr where
 156         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
 157         -- Trans defaults
 158         default header ::
 159          Trans repr =>
 160          HTTP_Header (UnTrans repr) =>
 161          HTTP.HeaderName -> repr (HeaderValue -> k) k
 162         header = noTrans . header
 163
 164 type HeaderValue = BS.ByteString
 165
 166 -- * Class 'HTTP_Body'
 167 class HTTP_Body repr where
 168         type BodyArg repr a (ts::[*]) :: *
 169         type BodyConstraint repr a (ts::[*]) :: Constraint
 170         body' ::
 171          BodyConstraint repr a ts =>
 172          repr (BodyArg repr a ts -> k) k
 173         -- Trans defaults
 174         type BodyArg repr a ts = BodyArg (UnTrans repr) a ts
 175         type BodyConstraint repr a ts = BodyConstraint (UnTrans repr) a ts
 176         default body' ::
 177          forall a (ts::[*]) k.
 178          Trans repr =>
 179          HTTP_Body (UnTrans repr) =>
 180          BodyConstraint (UnTrans repr) a ts =>
 181          BodyArg repr a ts ~ BodyArg (UnTrans repr) a ts =>
 182          repr (BodyArg repr a ts -> k) k
 183         body' = noTrans (body' @_ @a @ts)
 184
 185 -- | Like 'body'' but with the type variables @(a)@ and @(ts)@ first instead or @(repr)@,
 186 -- so it can be passed using 'TypeApplications' without adding a @@_@ for @(repr)@.
 187 body ::
 188  forall a ts k repr.
 189  HTTP_Body repr =>
 190  BodyConstraint repr a ts =>
 191  repr (BodyArg repr a ts -> k) k
 192 body = body' @repr @a @ts
 193 {-# INLINE body #-}
 194
 195 -- * Class 'HTTP_BodyStream'
 196 class HTTP_BodyStream repr where
 197         type BodyStreamArg repr as (ts::[*]) framing :: *
 198         type BodyStreamConstraint repr as (ts::[*]) framing :: Constraint
 199         bodyStream' ::
 200          BodyStreamConstraint repr as ts framing =>
 201          repr (BodyStreamArg repr as ts framing -> k) k
 202         -- Trans defaults
 203         type BodyStreamArg repr as ts framing = BodyStreamArg (UnTrans repr) as ts framing
 204         type BodyStreamConstraint repr as ts framing = BodyStreamConstraint (UnTrans repr) as ts framing
 205         default bodyStream' ::
 206          forall as ts framing k.
 207          Trans repr =>
 208          HTTP_BodyStream (UnTrans repr) =>
 209          BodyStreamConstraint (UnTrans repr) as ts framing =>
 210          BodyStreamArg repr as ts framing ~ BodyStreamArg (UnTrans repr) as ts framing =>
 211          repr (BodyStreamArg repr as ts framing -> k) k
 212         bodyStream' = noTrans (bodyStream' @_ @as @ts @framing)
 213
 214 -- | Like 'bodyStream'' but with the type variables @(as)@, @(ts)@ and @(framing)@
 215 -- first instead or @(repr)@, so it can be passed using 'TypeApplications'
 216 -- without adding a @@_@ for @(repr)@.
 217 bodyStream ::
 218  forall as ts framing k repr.
 219  HTTP_BodyStream repr =>
 220  BodyStreamConstraint repr as ts framing =>
 221  repr (BodyStreamArg repr as ts framing -> k) k
 222 bodyStream = bodyStream' @repr @as @ts @framing
 223 {-# INLINE bodyStream #-}
 224
 225 -- * Class 'HTTP_Query'
 226 class HTTP_Query repr where
 227         type QueryConstraint repr a :: Constraint
 228         queryParams' ::
 229          QueryConstraint repr a =>
 230          QueryName -> repr ([a] -> k) k
 231         queryFlag ::
 232          QueryConstraint repr Bool =>
 233          QueryName -> repr (Bool -> k) k
 234         default queryFlag ::
 235          Pro repr =>
 236          QueryConstraint repr Bool =>
 237          QueryName -> repr (Bool -> k) k
 238         queryFlag n = dimap and return (queryParams' n)
 239         -- Trans defaults
 240         type QueryConstraint repr a = QueryConstraint (UnTrans repr) a
 241         default queryParams' ::
 242          Trans repr =>
 243          HTTP_Query (UnTrans repr) =>
 244          QueryConstraint (UnTrans repr) a =>
 245          QueryName -> repr ([a] -> k) k
 246         queryParams' = noTrans . queryParams'
 247 type QueryName  = BS.ByteString
 248 type QueryValue = BS.ByteString
 249
 250 -- | Like 'capture'' but with the type variable @(a)@ first instead or @(repr)@
 251 -- so it can be passed using 'TypeApplications' without adding a @@_@ for @(repr)@.
 252 queryParams ::
 253  forall a k repr.
 254  HTTP_Query repr =>
 255  QueryConstraint repr a =>
 256  QueryName -> repr ([a] -> k) k
 257 queryParams = queryParams'
 258 {-# INLINE queryParams #-}
 259
 260 -- * Class 'HTTP_BasicAuth'
 261 -- | <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>
 262 class HTTP_BasicAuth repr where
 263         type BasicAuthConstraint repr a :: Constraint
 264         type BasicAuthArgs repr a k :: *
 265         basicAuth' ::
 266          BasicAuthConstraint repr a =>
 267          BasicAuthRealm -> repr (BasicAuthArgs repr a k) k
 268         -- Trans defaults
 269         type BasicAuthConstraint repr a = BasicAuthConstraint (UnTrans repr) a
 270         type BasicAuthArgs repr a k = BasicAuthArgs (UnTrans repr) a k
 271         default basicAuth' ::
 272          forall a k.
 273          Trans repr =>
 274          HTTP_BasicAuth (UnTrans repr) =>
 275          BasicAuthConstraint (UnTrans repr) a =>
 276          BasicAuthArgs repr a k ~ BasicAuthArgs (UnTrans repr) a k =>
 277          BasicAuthRealm -> repr (BasicAuthArgs repr a k) k
 278         basicAuth' = noTrans . basicAuth' @_ @a
 279
 280 -- | Like 'basicAuth'' but with the type variable @(a)@ first instead or @(repr)@
 281 -- so it can be passed using 'TypeApplications' without adding a @@_@ for @(repr)@.
 282 basicAuth ::
 283  forall a k repr.
 284  HTTP_BasicAuth repr =>
 285  BasicAuthConstraint repr a =>
 286  BasicAuthRealm ->
 287  repr (BasicAuthArgs repr a k) k
 288 basicAuth = basicAuth' @repr @a @k
 289 {-# INLINE basicAuth #-}
 290
 291 -- ** Type 'BasicAuth'
 292 data BasicAuth usr
 293  =   BasicAuth_Authorized usr
 294  |   BasicAuth_BadPassword
 295  |   BasicAuth_NoSuchUser
 296  |   BasicAuth_Unauthorized
 297  deriving (Eq, Show, Functor)
 298
 299 type BasicAuthRealm = Text
 300 type BasicAuthUser  = Text
 301 type BasicAuthPass  = Text
 302
 303 -- * Class 'HTTP_Version'
 304 class HTTP_Version repr where
 305         version :: HTTP.HttpVersion -> repr k k
 306
 307 {- TODO: see if this is useful somewhere.
 308 -- * Class 'HTTP_Status'
 309 class HTTP_Status repr where
 310         status :: StatusIs -> repr (HTTP.Status -> k) k
 311
 312 -- ** Type 'StatusIs'
 313 data StatusIs
 314    = StatusIsInformational
 315    | StatusIsSuccessful
 316    | StatusIsRedirection
 317    | StatusIsClientError
 318    | StatusIsServerError
 319    | StatusIs HTTP.Status
 320    deriving (Eq, Ord, Show)
 321 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 322 statusIs = \case
 323  StatusIsInformational -> HTTP.statusIsInformational
 324  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 325  StatusIsRedirection   -> HTTP.statusIsRedirection
 326  StatusIsClientError   -> HTTP.statusIsClientError
 327  StatusIsServerError   -> HTTP.statusIsServerError
 328  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 329 -}
 330
 331 -- * Class 'HTTP_Response'
 332 class HTTP_Response repr where
 333         type ResponseConstraint repr a (ts::[*]) :: Constraint
 334         type ResponseArgs repr a (ts::[*]) :: *
 335         type Response repr :: *
 336         response ::
 337          ResponseConstraint repr a ts =>
 338          HTTP.Method ->
 339          repr (ResponseArgs repr a ts)
 340               (Response repr)
 341         -- Trans defaults
 342         type ResponseConstraint repr a ts = ResponseConstraint (UnTrans repr) a ts
 343         type ResponseArgs repr a ts = ResponseArgs (UnTrans repr) a ts
 344         type Response repr = Response (UnTrans repr)
 345         default response ::
 346          forall a ts.
 347          Trans repr =>
 348          HTTP_Response (UnTrans repr) =>
 349          ResponseConstraint (UnTrans repr) a ts =>
 350          ResponseArgs repr a ts ~ ResponseArgs (UnTrans repr) a ts =>
 351          Response repr ~ Response (UnTrans repr) =>
 352          HTTP.Method ->
 353          repr (ResponseArgs repr a ts)
 354               (Response repr)
 355         response = noTrans . response @_ @a @ts
 356
 357 -- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
 358 -- and put the type variables @(a)@ then @(ts)@ first instead or @(repr)@
 359 -- so they can be passed using 'TypeApplications'
 360 -- without adding a |@_| for @(repr)@.
 361 get,head,put,post,delete,trace,connect,options,patch ::
 362  forall a ts repr.
 363  HTTP_Response repr =>
 364  ResponseConstraint repr a ts =>
 365  repr (ResponseArgs repr a ts)
 366       (Response repr)
 367 get     = response @repr @a @ts HTTP.methodGet
 368 head    = response @repr @a @ts HTTP.methodHead
 369 put     = response @repr @a @ts HTTP.methodPut
 370 post    = response @repr @a @ts HTTP.methodPost
 371 delete  = response @repr @a @ts HTTP.methodDelete
 372 trace   = response @repr @a @ts HTTP.methodTrace
 373 connect = response @repr @a @ts HTTP.methodConnect
 374 options = response @repr @a @ts HTTP.methodOptions
 375 patch   = response @repr @a @ts HTTP.methodPatch
 376 {-# INLINE get     #-}
 377 {-# INLINE head    #-}
 378 {-# INLINE put     #-}
 379 {-# INLINE post    #-}
 380 {-# INLINE delete  #-}
 381 {-# INLINE trace   #-}
 382 {-# INLINE connect #-}
 383 {-# INLINE options #-}
 384 {-# INLINE patch   #-}
 385
 386 -- * Class 'HTTP_ResponseStream'
 387 class HTTP_ResponseStream repr where
 388         type ResponseStreamConstraint repr as (ts::[*]) framing :: Constraint
 389         type ResponseStreamArgs repr as (ts::[*]) framing :: *
 390         type ResponseStream repr :: *
 391         responseStream ::
 392          ResponseStreamConstraint repr as ts framing =>
 393          HTTP.Method ->
 394          repr (ResponseStreamArgs repr as ts framing)
 395               (ResponseStream repr)
 396         -- Trans defaults
 397         type ResponseStreamConstraint repr as ts framing = ResponseStreamConstraint (UnTrans repr) as ts framing
 398         type ResponseStreamArgs repr as ts framing = ResponseStreamArgs (UnTrans repr) as ts framing
 399         type ResponseStream repr = ResponseStream (UnTrans repr)
 400         default responseStream ::
 401          forall as ts framing.
 402          Trans repr =>
 403          HTTP_ResponseStream (UnTrans repr) =>
 404          ResponseStreamConstraint (UnTrans repr) as ts framing =>
 405          ResponseStreamArgs repr as ts framing ~ ResponseStreamArgs (UnTrans repr) as ts framing =>
 406          ResponseStream repr ~ ResponseStream (UnTrans repr) =>
 407          HTTP.Method ->
 408          repr (ResponseStreamArgs repr as ts framing)
 409               (ResponseStream repr)
 410         responseStream = noTrans . responseStream @_ @as @ts @framing
 411
 412 getStream,headStream,putStream,postStream,deleteStream,traceStream,connectStream,optionsStream,patchStream ::
 413  forall as ts framing repr.
 414  HTTP_ResponseStream repr =>
 415  ResponseStreamConstraint repr as ts framing =>
 416  repr (ResponseStreamArgs repr as ts framing)
 417       (ResponseStream repr)
 418 getStream     = responseStream @repr @as @ts @framing HTTP.methodGet
 419 headStream    = responseStream @repr @as @ts @framing HTTP.methodHead
 420 putStream     = responseStream @repr @as @ts @framing HTTP.methodPut
 421 postStream    = responseStream @repr @as @ts @framing HTTP.methodPost
 422 deleteStream  = responseStream @repr @as @ts @framing HTTP.methodDelete
 423 traceStream   = responseStream @repr @as @ts @framing HTTP.methodTrace
 424 connectStream = responseStream @repr @as @ts @framing HTTP.methodConnect
 425 optionsStream = responseStream @repr @as @ts @framing HTTP.methodOptions
 426 patchStream   = responseStream @repr @as @ts @framing HTTP.methodPatch
 427 {-# INLINE getStream     #-}
 428 {-# INLINE headStream    #-}
 429 {-# INLINE putStream     #-}
 430 {-# INLINE postStream    #-}
 431 {-# INLINE deleteStream  #-}
 432 {-# INLINE traceStream   #-}
 433 {-# INLINE connectStream #-}
 434 {-# INLINE optionsStream #-}
 435 {-# INLINE patchStream   #-}
 436
 437 -- * Framing
 438 -- ** Type family 'FramingMonad'
 439 type family FramingMonad  p :: * -> *
 440 -- ** Type family 'FramingYield'
 441 type family FramingYield  p :: *
 442 -- ** Type family 'FramingReturn'
 443 type family FramingReturn p :: *
 444
 445 -- ** Class 'FramingEncode'
 446 class FramingEncode framing p where
 447         framingEncode ::
 448          Proxy framing ->
 449          {-mimeEncode-}(FramingYield p -> BSL.ByteString) ->
 450          p -> IO (Either (FramingReturn p) (BSL.ByteString, p))
 451
 452 -- ** Class 'FramingDecode'
 453 class FramingDecode framing p where
 454         framingDecode ::
 455          FramingMonad p ~ m =>
 456          Monad m =>
 457          Proxy framing ->
 458          {-mimeDecode-}(BSL.ByteString -> Either String (FramingYield p)) ->
 459          m BS.ByteString -> p
 460
 461 -- ** Type 'NoFraming'
 462 -- | A framing strategy that does not do any framing at all,
 463 -- it just passes the input data.
 464 -- Most of the time this will be used with binary data, such as files.
 465 data NoFraming
 466
 467 -- ** Type 'NewlineFraming'
 468 -- | A simple framing strategy that has no header,
 469 -- and inserts a newline character after each frame.
 470 -- WARNING: this assumes that it is used with a Content-Type
 471 -- that encodes without newlines (e.g. JSON).
 472 data NewlineFraming
 473
 474 -- ** Type 'NetstringFraming'
 475 -- | The netstring framing strategy as defined by djb:
 476 -- <http://cr.yp.to/proto/netstrings.txt>
 477 --
 478 -- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@.  Here
 479 -- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits
 480 -- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for
 481 -- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front
 482 -- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when
 483 -- @[string]@ is empty.
 484 --
 485 -- For example, the string @"hello world!"@ is encoded as
 486 -- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@,
 487 -- i.e., @"12:hello world!,"@.
 488 -- The empty string is encoded as @"0:,"@.
 489 data NetstringFraming