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