Symantic/HTTP/API.hs

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