Symantic/HTTP/API.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 module Symantic.HTTP.API
   8  ( module Symantic.HTTP.API
   9  ) where
  10
  11 import Data.Bool
  12 import Prelude (and, pure)
  13 import Data.Eq (Eq(..))
  14 -- import Data.Maybe (Maybe(..))
  15 import Data.Ord (Ord(..))
  16 import Data.Proxy (Proxy(..))
  17 import Data.String (String)
  18 import Text.Show (Show(..))
  19 import qualified Data.ByteString as BS
  20 import qualified Data.Text as T
  21 import qualified Network.HTTP.Types as HTTP
  22 import qualified Web.HttpApiData as Web
  23
  24 import Symantic.HTTP.Media
  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_Method      repr
  35  , HTTP_Header      repr
  36  , HTTP_Accept      repr
  37  -- , HTTP_ContentType repr
  38  , HTTP_Query  repr
  39  , HTTP_Response    repr
  40  ) => HTTP_API (repr:: * -> * -> *)
  41
  42 -- * Class 'Cat'
  43 class Cat repr where
  44         (<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
  45         -- (.>)  :: repr x y -> repr a c -> repr a c; infixl 4  .>
  46
  47 -- * Class 'Alt'
  48 class Alt repr where
  49         {-
  50         type AltMerge repr :: * -> * -> *
  51         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
  52         -}
  53         (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
  54         -- try :: repr k k -> repr k k
  55         -- option :: k -> repr k k -> repr k k
  56
  57 -- ** Type ':!:'
  58 -- Like '(,)' but 'infixl'.
  59 data (:!:) a b = a:!:b
  60 infixl 3 :!:
  61
  62 -- * Class 'Pro'
  63 -- | Mainly useful to write a combinator which a specialization of another,
  64 -- by calling it instead of rewriting its logic.
  65 -- Because 'a' is asked in a client but given in 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 -- * Class 'HTTP_Path'
  72 class HTTP_Path repr where
  73         segment  :: Segment -> repr k k
  74         capture' ::
  75          Web.FromHttpApiData a =>
  76          Web.ToHttpApiData a =>
  77          Name -> repr (a -> k) k
  78         captureAll :: repr ([Segment] -> k) k
  79
  80 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  81 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  82 capture ::
  83  forall a k repr.
  84  HTTP_Path repr =>
  85  Web.FromHttpApiData a =>
  86  Web.ToHttpApiData a =>
  87  Name -> repr (a -> k) k
  88 capture = capture'
  89 {-# INLINE capture #-}
  90
  91 type Segment     = T.Text
  92 type Path        = [Segment]
  93 type Name        = String
  94
  95 -- * Class 'HTTP_Method'
  96 class HTTP_Method repr where
  97         method         :: HTTP.Method -> repr k k
  98         method_GET     :: repr k k
  99         method_POST    :: repr k k
 100         method_HEAD    :: repr k k
 101         method_PUT     :: repr k k
 102         method_DELETE  :: repr k k
 103         method_TRACE   :: repr k k
 104         method_CONNECT :: repr k k
 105         method_OPTIONS :: repr k k
 106         method_PATCH   :: repr k k
 107         method_GET     = method HTTP.methodGet
 108         method_HEAD    = method HTTP.methodHead
 109         method_PUT     = method HTTP.methodPut
 110         method_POST    = method HTTP.methodPost
 111         method_DELETE  = method HTTP.methodDelete
 112         method_TRACE   = method HTTP.methodTrace
 113         method_CONNECT = method HTTP.methodConnect
 114         method_OPTIONS = method HTTP.methodOptions
 115         method_PATCH   = method HTTP.methodPatch
 116
 117 -- * Class 'HTTP_Header'
 118 class HTTP_Header repr where
 119         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
 120 type HeaderValue = BS.ByteString
 121
 122 -- * Class 'HTTP_Body'
 123 class HTTP_Body repr where
 124         type BodyArg repr :: * -> * -> *
 125         body' ::
 126          forall mt a k.
 127          MimeUnserialize mt a =>
 128          MimeSerialize mt a =>
 129          repr (BodyArg repr mt a -> k) k
 130
 131 -- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
 132 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
 133 body ::
 134  forall mt a k repr.
 135  HTTP_Body repr =>
 136  MimeUnserialize mt a =>
 137  MimeSerialize mt a =>
 138  repr (BodyArg repr mt a -> k) k
 139 body = body' @repr @mt
 140 {-# INLINE body #-}
 141
 142 -- * Class 'HTTP_Accept'
 143 class HTTP_Accept repr where
 144         accept :: MediaTypeable mt => Proxy mt -> repr k k
 145         {-
 146         acceptCase :: Functor repr => Alt repr => [AcceptResponse repr a] -> repr BSL.ByteString
 147         acceptCase [] = tina $> BSL.empty
 148         acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
 149         -}
 150 {-
 151 data AcceptResponse repr a =
 152  forall mt. MimeSerialize mt a =>
 153  AcceptResponse (Proxy mt, repr a)
 154 -}
 155 -- * Class 'HTTP_Content'
 156 class HTTP_ContentType repr where
 157         contentType :: MediaTypeable mt => Proxy mt -> repr k k
 158
 159 -- * Class 'HTTP_Query'
 160 class HTTP_Query repr where
 161         queryParams' ::
 162          Web.FromHttpApiData a =>
 163          Web.ToHttpApiData a =>
 164          QueryName -> repr ([a] -> k) k
 165         queryFlag :: QueryName -> repr (Bool -> k) k
 166         default queryFlag :: Pro repr => QueryName -> repr (Bool -> k) k
 167         queryFlag n = dimap and pure (queryParams' n)
 168 type QueryName   = BS.ByteString
 169 type QueryValue  = BS.ByteString
 170
 171 queryParams ::
 172  forall a k repr.
 173  HTTP_Query repr =>
 174  Web.FromHttpApiData a =>
 175  Web.ToHttpApiData a =>
 176  QueryName -> repr ([a] -> k) k
 177 queryParams = queryParams'
 178 {-# INLINE queryParams #-}
 179
 180 -- * Class 'HTTP_Version'
 181 class HTTP_Version repr where
 182         version :: HTTP.HttpVersion -> repr k k
 183
 184 -- * Class 'HTTP_Status'
 185 class HTTP_Status repr where
 186         status :: StatusIs -> repr (HTTP.Status -> k) k
 187
 188 -- ** Type 'StatusIs'
 189 data StatusIs
 190  =   StatusIsInformational
 191  |   StatusIsSuccessful
 192  |   StatusIsRedirection
 193  |   StatusIsClientError
 194  |   StatusIsServerError
 195  |   StatusIs HTTP.Status
 196  deriving (Eq, Ord, Show)
 197 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 198 statusIs = \case
 199  StatusIsInformational -> HTTP.statusIsInformational
 200  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 201  StatusIsRedirection   -> HTTP.statusIsRedirection
 202  StatusIsClientError   -> HTTP.statusIsClientError
 203  StatusIsServerError   -> HTTP.statusIsServerError
 204  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 205
 206 status200 :: HTTP.Status
 207 status200 = HTTP.mkStatus 200 "Success"
 208 status400 :: HTTP.Status
 209 status400 = HTTP.mkStatus 400 "Bad Request"
 210 status404 :: HTTP.Status
 211 status404 = HTTP.mkStatus 404 "Not Found"
 212 status405 :: HTTP.Status
 213 status405 = HTTP.mkStatus 405 "Method Not Allowed"
 214 status406 :: HTTP.Status
 215 status406 = HTTP.mkStatus 406 "Not Acceptable"
 216 status415 :: HTTP.Status
 217 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
 218
 219 -- * Class 'HTTP_Response'
 220 class HTTP_Response repr where
 221         type Response repr :: *
 222         type ResponseArg repr :: * -> * -> *
 223         response' ::
 224          MimeUnserialize mt a =>
 225          MimeSerialize mt a =>
 226          k ~ Response repr =>
 227          HTTP.Method ->
 228          repr (ResponseArg repr mt a -> k) k
 229
 230 -- | Like |response'| but with the type variables 'a' and 'mt' first instead or 'repr'
 231 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
 232 response ::
 233  forall mt a k repr.
 234  HTTP_Response repr =>
 235  MimeUnserialize mt a =>
 236  MimeSerialize mt a =>
 237  k ~ Response repr =>
 238  HTTP.Method ->
 239  repr (ResponseArg repr mt a -> k) k
 240 response = response'
 241 {-# INLINE response #-}