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 where
   8
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Ord (Ord(..))
  12 import Data.Proxy (Proxy(..))
  13 import Data.String (String)
  14 import Prelude (and, pure)
  15 import Text.Show (Show(..))
  16 import qualified Data.ByteString as BS
  17 import qualified Data.Text as T
  18 import qualified Network.HTTP.Types as HTTP
  19 import qualified Web.HttpApiData as Web
  20
  21 import Symantic.HTTP.Mime
  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_ContentType repr
  32  , HTTP_Query  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 data (:!:) a b = a:!:b
  54 infixl 3 :!:
  55
  56 -- * Class 'Pro'
  57 -- | Mainly useful to write a combinator which is a specialization of another,
  58 -- by calling it instead of rewriting its logic.
  59 -- Because 'a' is asked in a client but given in a server,
  60 -- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
  61 -- Hence the names 'Pro' and 'dimap'.
  62 class Pro repr where
  63         dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
  64
  65 -- * Class 'HTTP_Path'
  66 class HTTP_Path repr where
  67         segment :: Segment -> repr k k
  68         capture' ::
  69          Web.FromHttpApiData a =>
  70          Web.ToHttpApiData a =>
  71          Name -> repr (a -> k) k
  72         captureAll :: repr ([Segment] -> k) k
  73
  74 -- | Convenient wrapper of 'segment'.
  75 (</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
  76 (</>) n = (segment n <.>); infixr 5 </>
  77
  78 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  79 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  80 capture ::
  81  forall a k repr.
  82  HTTP_Path repr =>
  83  Web.FromHttpApiData a =>
  84  Web.ToHttpApiData a =>
  85  Name -> repr (a -> k) k
  86 capture = capture'
  87 {-# INLINE capture #-}
  88
  89 type Segment = T.Text
  90 type Path    = [Segment]
  91 type Name    = String
  92
  93 -- * Class 'HTTP_Header'
  94 class HTTP_Header repr where
  95         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
  96 type HeaderValue = BS.ByteString
  97
  98 -- * Class 'HTTP_Body'
  99 class HTTP_Body repr where
 100         type BodyArg repr :: * -> * -> *
 101         body' ::
 102          forall a mt k.
 103          MimeUnserialize a mt =>
 104          MimeSerialize a mt =>
 105          repr (BodyArg repr mt a -> k) k
 106
 107 -- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
 108 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
 109 body ::
 110  forall a mt k repr.
 111  HTTP_Body repr =>
 112  MimeUnserialize a mt =>
 113  MimeSerialize a mt =>
 114  repr (BodyArg repr mt a -> k) k
 115 body = body' @repr
 116 {-# INLINE body #-}
 117
 118 {-
 119 data AcceptResponse repr a =
 120  forall mt. MimeSerialize a mt =>
 121  AcceptResponse (Proxy mt, repr a)
 122 -}
 123 -- * Class 'HTTP_Content'
 124 class HTTP_ContentType repr where
 125         contentType :: MediaTypeable mt => Proxy mt -> repr k k
 126
 127 -- * Class 'HTTP_Query'
 128 class HTTP_Query repr where
 129         queryParams' ::
 130          Web.FromHttpApiData a =>
 131          Web.ToHttpApiData a =>
 132          QueryName -> repr ([a] -> k) k
 133         queryFlag :: QueryName -> repr (Bool -> k) k
 134         default queryFlag :: Pro repr => QueryName -> repr (Bool -> k) k
 135         queryFlag n = dimap and pure (queryParams' n)
 136 type QueryName   = BS.ByteString
 137 type QueryValue  = BS.ByteString
 138
 139 queryParams ::
 140  forall a k repr.
 141  HTTP_Query repr =>
 142  Web.FromHttpApiData a =>
 143  Web.ToHttpApiData a =>
 144  QueryName -> repr ([a] -> k) k
 145 queryParams = queryParams'
 146 {-# INLINE queryParams #-}
 147
 148 -- * Class 'HTTP_Version'
 149 class HTTP_Version repr where
 150         version :: HTTP.HttpVersion -> repr k k
 151
 152 -- * Class 'HTTP_Status'
 153 class HTTP_Status repr where
 154         status :: StatusIs -> repr (HTTP.Status -> k) k
 155
 156 -- ** Type 'StatusIs'
 157 data StatusIs
 158  =   StatusIsInformational
 159  |   StatusIsSuccessful
 160  |   StatusIsRedirection
 161  |   StatusIsClientError
 162  |   StatusIsServerError
 163  |   StatusIs HTTP.Status
 164  deriving (Eq, Ord, Show)
 165 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 166 statusIs = \case
 167  StatusIsInformational -> HTTP.statusIsInformational
 168  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 169  StatusIsRedirection   -> HTTP.statusIsRedirection
 170  StatusIsClientError   -> HTTP.statusIsClientError
 171  StatusIsServerError   -> HTTP.statusIsServerError
 172  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 173
 174 status200 :: HTTP.Status
 175 status200 = HTTP.mkStatus 200 "Success"
 176 status400 :: HTTP.Status
 177 status400 = HTTP.mkStatus 400 "Bad Request"
 178 status404 :: HTTP.Status
 179 status404 = HTTP.mkStatus 404 "Not Found"
 180 status405 :: HTTP.Status
 181 status405 = HTTP.mkStatus 405 "Method Not Allowed"
 182 status406 :: HTTP.Status
 183 status406 = HTTP.mkStatus 406 "Not Acceptable"
 184 status415 :: HTTP.Status
 185 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
 186
 187 -- * Class 'HTTP_Response'
 188 class HTTP_Response repr where
 189         type Response repr :: *
 190         type ResponseArg repr :: * -> * -> *
 191         response ::
 192          MimeUnserialize a mt =>
 193          MimeSerialize a mt =>
 194          k ~ Response repr =>
 195          HTTP.Method ->
 196          repr (ResponseArg repr mt a -> k) k
 197
 198 -- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
 199 -- and put the type variables 'a' then 'mt' first instead or 'repr'
 200 -- so they can be passed using 'TypeApplications'
 201 -- without adding a '@_' for 'repr'.
 202 get,head,put,post,delete,trace,connect,options,patch ::
 203  forall a mt k repr.
 204  HTTP_Response repr =>
 205  MimeUnserialize a mt =>
 206  MimeSerialize a mt =>
 207  k ~ Response repr =>
 208  repr (ResponseArg repr mt a -> k) k
 209 get     = response HTTP.methodGet
 210 head    = response HTTP.methodHead
 211 put     = response HTTP.methodPut
 212 post    = response HTTP.methodPost
 213 delete  = response HTTP.methodDelete
 214 trace   = response HTTP.methodTrace
 215 connect = response HTTP.methodConnect
 216 options = response HTTP.methodOptions
 217 patch   = response HTTP.methodPatch
 218 {-# INLINE get     #-}
 219 {-# INLINE head    #-}
 220 {-# INLINE put     #-}
 221 {-# INLINE post    #-}
 222 {-# INLINE delete  #-}
 223 {-# INLINE trace   #-}
 224 {-# INLINE connect #-}
 225 {-# INLINE options #-}
 226 {-# INLINE patch   #-}