Symantic/HTTP/API.hs

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