Symantic/HTTP/API.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE StrictData #-}
   4 module Symantic.HTTP.API where
   5
   6 import Data.Bool
   7 import Data.Eq (Eq(..))
   8 import Data.Functor (Functor)
   9 import Data.Kind (Constraint)
  10 import Data.Ord (Ord(..))
  11 import Data.String (String)
  12 import Data.Text (Text)
  13 import Prelude (and, pure)
  14 import Text.Show (Show(..))
  15 import qualified Data.ByteString as BS
  16 import qualified Network.HTTP.Types as HTTP
  17
  18 -- * Class 'HTTP_API'
  19 class
  20  ( Cat            repr
  21  , Alt            repr
  22  -- , Pro            repr
  23  , HTTP_Version   repr
  24  , HTTP_Path      repr
  25  , HTTP_Header    repr
  26  , HTTP_Query     repr
  27  , HTTP_BasicAuth repr
  28  , HTTP_Response  repr
  29  ) => HTTP_API (repr:: * -> * -> *)
  30
  31 -- * Class 'Cat'
  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 class Alt repr where
  38         {-
  39         type AltMerge repr :: * -> * -> *
  40         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
  41         -}
  42         (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
  43         -- try :: repr k k -> repr k k
  44         -- option :: k -> repr k k -> repr k k
  45
  46 -- ** Type ':!:'
  47 -- Like '(,)' but 'infixl'.
  48 -- Used to get alternative commands from a 'Client'
  49 -- or to supply alternative handlers to a 'Server'.
  50 data (:!:) a b = a:!:b
  51 infixl 3 :!:
  52
  53 -- * Class 'Pro'
  54 -- | Mainly useful to write a combinator which is a specialization of another,
  55 -- by calling it instead of rewriting its logic.
  56 -- Because type @a@ is asked by a 'Client' but given to a 'Server',
  57 -- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
  58 -- Hence the names 'Pro' and 'dimap'.
  59 class Pro repr where
  60         dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
  61
  62 -- * Class 'HTTP_Path'
  63 class HTTP_Path repr where
  64         type PathConstraint repr a :: Constraint
  65         type PathConstraint repr a = ()
  66         segment :: Segment -> repr k k
  67         capture' ::
  68          PathConstraint repr a =>
  69          Name -> repr (a -> k) k
  70         captureAll :: repr ([Segment] -> k) k
  71
  72 -- | Convenient wrapper of 'segment'.
  73 (</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
  74 (</>) n = (segment n <.>); infixr 5 </>
  75
  76 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  77 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  78 capture ::
  79  forall a k repr.
  80  HTTP_Path repr =>
  81  PathConstraint repr a =>
  82  Name -> repr (a -> k) k
  83 capture = capture'
  84 {-# INLINE capture #-}
  85
  86 type Segment = Text
  87 type Path    = [Segment]
  88 type Name    = String
  89
  90 -- * Class 'HTTP_Header'
  91 class HTTP_Header repr where
  92         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
  93
  94 type HeaderValue = BS.ByteString
  95
  96 -- * Class 'HTTP_Body'
  97 class HTTP_Body repr where
  98         type BodyArg repr :: * -> [*] -> *
  99         type BodyConstraint repr a (ts::[*]) :: Constraint
 100         type BodyConstraint repr a ts = ()
 101         body' ::
 102          forall a (ts::[*]) k.
 103          BodyConstraint repr a ts =>
 104          repr (BodyArg repr a ts -> k) k
 105
 106 -- | Like |body'| but with the type variables 'a' and 'ts' first instead or 'repr'
 107 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
 108 body ::
 109  forall a ts k repr.
 110  HTTP_Body repr =>
 111  BodyConstraint repr a ts =>
 112  repr (BodyArg repr a ts -> k) k
 113 body = body' @repr
 114 {-# INLINE body #-}
 115
 116 -- * Class 'HTTP_Query'
 117 class HTTP_Query repr where
 118         type QueryConstraint repr a :: Constraint
 119         type QueryConstraint repr a = ()
 120         queryParams' ::
 121          QueryConstraint repr a =>
 122          QueryName -> repr ([a] -> k) k
 123         queryFlag ::
 124          QueryConstraint repr Bool =>
 125          QueryName -> repr (Bool -> k) k
 126         default queryFlag ::
 127          Pro repr =>
 128          QueryConstraint repr Bool =>
 129          QueryName -> repr (Bool -> k) k
 130         queryFlag n = dimap and pure (queryParams' n)
 131 type QueryName   = BS.ByteString
 132 type QueryValue  = BS.ByteString
 133
 134 queryParams ::
 135  forall a k repr.
 136  HTTP_Query repr =>
 137  QueryConstraint repr a =>
 138  QueryName -> repr ([a] -> k) k
 139 queryParams = queryParams'
 140 {-# INLINE queryParams #-}
 141
 142 -- * Class 'HTTP_BasicAuth'
 143 -- | <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>
 144 class HTTP_BasicAuth repr where
 145         type BasicAuthConstraint repr a :: Constraint
 146         type BasicAuthConstraint repr a = ()
 147         type BasicAuthArgs repr a k :: *
 148         basicAuth' ::
 149          BasicAuthConstraint repr a =>
 150          BasicAuthRealm -> repr (BasicAuthArgs repr a k) k
 151
 152 basicAuth ::
 153  forall a k repr.
 154  HTTP_BasicAuth repr =>
 155  BasicAuthConstraint repr a =>
 156  BasicAuthRealm ->
 157  repr (BasicAuthArgs repr a k) k
 158 basicAuth = basicAuth' @repr @a @k
 159 {-# INLINE basicAuth #-}
 160
 161 -- ** Type 'BasicAuth'
 162 data BasicAuth usr
 163  =   BasicAuth_Authorized usr
 164  |   BasicAuth_BadPassword
 165  |   BasicAuth_NoSuchUser
 166  |   BasicAuth_Unauthorized
 167  deriving (Eq, Show, Functor)
 168
 169 type BasicAuthRealm = Text
 170 type BasicAuthUser  = Text
 171 type BasicAuthPass  = Text
 172
 173 -- * Class 'HTTP_Version'
 174 class HTTP_Version repr where
 175         version :: HTTP.HttpVersion -> repr k k
 176
 177 -- * Class 'HTTP_Status'
 178 class HTTP_Status repr where
 179         status :: StatusIs -> repr (HTTP.Status -> k) k
 180
 181 -- ** Type 'StatusIs'
 182 data StatusIs
 183    = StatusIsInformational
 184    | StatusIsSuccessful
 185    | StatusIsRedirection
 186    | StatusIsClientError
 187    | StatusIsServerError
 188    | StatusIs HTTP.Status
 189    deriving (Eq, Ord, Show)
 190 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 191 statusIs = \case
 192  StatusIsInformational -> HTTP.statusIsInformational
 193  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 194  StatusIsRedirection   -> HTTP.statusIsRedirection
 195  StatusIsClientError   -> HTTP.statusIsClientError
 196  StatusIsServerError   -> HTTP.statusIsServerError
 197  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 198
 199 -- * Class 'HTTP_Response'
 200 class HTTP_Response repr where
 201         type ResponseConstraint repr a (ts::[*]) :: Constraint
 202         type ResponseConstraint repr a ts = ()
 203         type ResponseArgs repr a (ts::[*]) :: *
 204         type Response repr :: *
 205         response ::
 206          ResponseConstraint repr a ts =>
 207          HTTP.Method ->
 208          repr (ResponseArgs repr a ts)
 209               (Response repr)
 210
 211 -- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
 212 -- and put the type variables 'a' then 'ts' first instead or 'repr'
 213 -- so they can be passed using 'TypeApplications'
 214 -- without adding a |@_| for 'repr'.
 215 get,head,put,post,delete,trace,connect,options,patch ::
 216  forall a ts repr.
 217  HTTP_Response repr =>
 218  ResponseConstraint repr a ts =>
 219  repr (ResponseArgs repr a ts)
 220       (Response repr)
 221 get     = response @repr @a @ts HTTP.methodGet
 222 head    = response @repr @a @ts HTTP.methodHead
 223 put     = response @repr @a @ts HTTP.methodPut
 224 post    = response @repr @a @ts HTTP.methodPost
 225 delete  = response @repr @a @ts HTTP.methodDelete
 226 trace   = response @repr @a @ts HTTP.methodTrace
 227 connect = response @repr @a @ts HTTP.methodConnect
 228 options = response @repr @a @ts HTTP.methodOptions
 229 patch   = response @repr @a @ts HTTP.methodPatch
 230 {-# INLINE get     #-}
 231 {-# INLINE head    #-}
 232 {-# INLINE put     #-}
 233 {-# INLINE post    #-}
 234 {-# INLINE delete  #-}
 235 {-# INLINE trace   #-}
 236 {-# INLINE connect #-}
 237 {-# INLINE options #-}
 238 {-# INLINE patch   #-}