symantic-http/Symantic/HTTP/API.hs

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