Symantic/HTTP/API.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# LANGUAGE TypeApplications #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE TypeOperators #-}
   8 module Symantic.HTTP.API where
   9
  10 import Data.Bool
  11 import Data.Eq (Eq(..))
  12 import Data.Functor (Functor)
  13 import Data.Kind (Constraint)
  14 import Data.Ord (Ord(..))
  15 import Data.Proxy (Proxy(..))
  16 import Data.String (String)
  17 import Prelude (and, pure)
  18 import System.IO (IO)
  19 import Text.Show (Show(..))
  20 import qualified Data.ByteString as BS
  21 import qualified Data.Text as T
  22 import qualified Network.HTTP.Types as HTTP
  23 import qualified Web.HttpApiData as Web
  24
  25 import Symantic.HTTP.Mime
  26
  27 -- * Class 'HTTP_API'
  28 class
  29  ( Cat            repr
  30  , Alt            repr
  31  -- , Pro            repr
  32  , HTTP_Version   repr
  33  , HTTP_Path      repr
  34  , HTTP_Header    repr
  35  , HTTP_Query     repr
  36  -- , HTTP_BasicAuth repr
  37  , HTTP_Response  repr
  38  ) => HTTP_API (repr:: * -> * -> *)
  39
  40 -- * Class 'Cat'
  41 class Cat repr where
  42         (<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
  43         -- (.>)  :: repr x y -> repr a c -> repr a c; infixl 4  .>
  44
  45 -- * Class 'Alt'
  46 class Alt repr where
  47         {-
  48         type AltMerge repr :: * -> * -> *
  49         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
  50         -}
  51         (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
  52         -- try :: repr k k -> repr k k
  53         -- option :: k -> repr k k -> repr k k
  54
  55 -- ** Type ':!:'
  56 -- Like '(,)' but 'infixl'.
  57 -- Used to get alternative commands from a 'Client'
  58 -- or to supply alternative handlers to a 'Server'.
  59 data (:!:) a b = a:!:b
  60 infixl 3 :!:
  61
  62 -- * Class 'Pro'
  63 -- | Mainly useful to write a combinator which is a specialization of another,
  64 -- by calling it instead of rewriting its logic.
  65 -- Because 'a' si asked by a 'Client' but given to a 'Server',
  66 -- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
  67 -- Hence the names 'Pro' and 'dimap'.
  68 class Pro repr where
  69         dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
  70
  71 -- * Type family 'HttpApiData'
  72 -- | Either 'Web.ToHttpApiData' for a 'Client',
  73 -- or 'Web.FromHttpApiData' for a 'Server'.
  74 type family HttpApiData (repr:: * -> * -> *) :: * -> Constraint
  75
  76 -- * Class 'HTTP_Path'
  77 class HTTP_Path repr where
  78         segment :: Segment -> repr k k
  79         capture' ::
  80          HttpApiData repr a =>
  81          Name -> repr (a -> k) k
  82         captureAll :: repr ([Segment] -> k) k
  83
  84 -- | Convenient wrapper of 'segment'.
  85 (</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
  86 (</>) n = (segment n <.>); infixr 5 </>
  87
  88 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  89 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  90 capture ::
  91  forall a k repr.
  92  HTTP_Path repr =>
  93  HttpApiData repr a =>
  94  Name -> repr (a -> k) k
  95 capture = capture'
  96 {-# INLINE capture #-}
  97
  98 type Segment = T.Text
  99 type Path    = [Segment]
 100 type Name    = String
 101
 102 -- * Class 'HTTP_Header'
 103 class HTTP_Header repr where
 104         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
 105 type HeaderValue = BS.ByteString
 106
 107 -- * Class 'HTTP_Body'
 108 class HTTP_Body repr where
 109         type BodyArg repr :: * -> * -> *
 110         body' ::
 111          forall a mt k.
 112          MimeUnserialize a mt =>
 113          MimeSerialize a mt =>
 114          repr (BodyArg repr mt a -> k) k
 115
 116 -- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
 117 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
 118 body ::
 119  forall a mt k repr.
 120  HTTP_Body repr =>
 121  MimeUnserialize a mt =>
 122  MimeSerialize a mt =>
 123  repr (BodyArg repr mt a -> k) k
 124 body = body' @repr
 125 {-# INLINE body #-}
 126
 127 {-
 128 data AcceptResponse repr a =
 129  forall mt. MimeSerialize a mt =>
 130  AcceptResponse (Proxy mt, repr a)
 131 -}
 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 BasicAuthable repr :: * -> * -> Constraint
 161         basicAuth' ::
 162          BasicAuthable repr context a =>
 163          BasicAuthRealm -> context -> repr (a -> k) k
 164
 165 basicAuth ::
 166  forall a context k repr.
 167  HTTP_BasicAuth repr =>
 168  BasicAuthable repr context a =>
 169  BasicAuthRealm ->
 170  context -> repr (a -> k) k
 171 basicAuth = basicAuth' @repr @context @a
 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 = BS.ByteString
 183 type BasicAuthName  = BS.ByteString
 184 type BasicAuthPass  = BS.ByteString
 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 Response repr :: *
 215         type ResponseArg repr :: * -> * -> *
 216         response ::
 217          MimeUnserialize a mt =>
 218          MimeSerialize a mt =>
 219          k ~ Response repr =>
 220          HTTP.Method ->
 221          repr (ResponseArg repr mt a -> k) k
 222
 223 -- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
 224 -- and put the type variables 'a' then 'mt' first instead or 'repr'
 225 -- so they can be passed using 'TypeApplications'
 226 -- without adding a '@_' for 'repr'.
 227 get,head,put,post,delete,trace,connect,options,patch ::
 228  forall a mt k repr.
 229  HTTP_Response repr =>
 230  MimeUnserialize a mt =>
 231  MimeSerialize a mt =>
 232  k ~ Response repr =>
 233  repr (ResponseArg repr mt a -> k) k
 234 get     = response HTTP.methodGet
 235 head    = response HTTP.methodHead
 236 put     = response HTTP.methodPut
 237 post    = response HTTP.methodPost
 238 delete  = response HTTP.methodDelete
 239 trace   = response HTTP.methodTrace
 240 connect = response HTTP.methodConnect
 241 options = response HTTP.methodOptions
 242 patch   = response 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   #-}