Symantic/HTTP/API.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 {-# LANGUAGE TypeFamilies #-}
   4 {-# LANGUAGE TypeOperators #-}
   5 module Symantic.HTTP.API
   6  ( module Symantic.HTTP.API
   7  ) where
   8
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Ord (Ord(..))
  13 import Data.Proxy (Proxy(..))
  14 import Data.String (String)
  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.Media
  22 import Symantic.HTTP.Mime
  23
  24 -- * Class 'HTTP_API'
  25 class
  26  ( Cat            repr
  27  , Alt            repr
  28  , HTTP_Path      repr
  29  , HTTP_Method    repr
  30  , HTTP_Header    repr
  31  , HTTP_Accept    repr
  32  , HTTP_Query     repr
  33  , HTTP_Version   repr
  34  , HTTP_Endpoint  repr
  35  ) => HTTP_API (repr:: * -> * -> *)
  36
  37 -- * Class 'Cat'
  38 class Cat repr where
  39         (<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
  40         -- (.>)  :: repr x y -> repr a c -> repr a c; infixl 4  .>
  41
  42 -- * Class 'Alt'
  43 class Alt repr where
  44         {-
  45         type AltMerge repr :: * -> * -> *
  46         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
  47         -}
  48         (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
  49         try :: repr k k -> repr k k
  50         -- option :: k -> repr k k -> repr k k
  51
  52 -- ** Type ':!:'
  53 -- Like '(,)' but 'infixl'.
  54 data (:!:) a b = a:!:b
  55 infixl 3 :!:
  56
  57 -- * Class 'HTTP_Path'
  58 class HTTP_Path repr where
  59         segment  :: Segment -> repr k k
  60         capture' :: Web.FromHttpApiData a =>
  61                     Web.ToHttpApiData a =>
  62                     Name -> repr (a -> k) k
  63         captureAll :: repr ([Segment] -> k) k
  64
  65 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  66 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  67 capture ::
  68  forall a repr k.
  69  HTTP_Path repr =>
  70  Web.FromHttpApiData a =>
  71  Web.ToHttpApiData a =>
  72  Name -> repr (a -> k) k
  73 capture = capture'
  74 {-# INLINE capture #-}
  75
  76 type Segment     = T.Text
  77 type Path        = [Segment]
  78 type Name        = String
  79
  80 -- * Class 'HTTP_Method'
  81 class HTTP_Method repr where
  82         method         :: HTTP.Method -> repr k k
  83         method_GET     :: repr k k
  84         method_POST    :: repr k k
  85         method_HEAD    :: repr k k
  86         method_PUT     :: repr k k
  87         method_DELETE  :: repr k k
  88         method_TRACE   :: repr k k
  89         method_CONNECT :: repr k k
  90         method_OPTIONS :: repr k k
  91         method_PATCH   :: repr k k
  92         method_GET     = method HTTP.methodGet
  93         method_HEAD    = method HTTP.methodHead
  94         method_PUT     = method HTTP.methodPut
  95         method_POST    = method HTTP.methodPost
  96         method_DELETE  = method HTTP.methodDelete
  97         method_TRACE   = method HTTP.methodTrace
  98         method_CONNECT = method HTTP.methodConnect
  99         method_OPTIONS = method HTTP.methodOptions
 100         method_PATCH   = method HTTP.methodPatch
 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_Accept'
 108 class HTTP_Accept repr where
 109         accept :: MediaTypeable mt => Proxy mt -> repr k k
 110         {-
 111         acceptCase :: Functor repr => Alt repr => [AcceptResponse repr a] -> repr BSL.ByteString
 112         acceptCase [] = tina $> BSL.empty
 113         acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
 114         -}
 115 {-
 116 data AcceptResponse repr a =
 117  forall mt. MimeSerialize mt a =>
 118  AcceptResponse (Proxy mt, repr a)
 119 -}
 120
 121 -- * Class 'HTTP_Query'
 122 class HTTP_Query repr where
 123         query' ::
 124          Web.FromHttpApiData a =>
 125          Web.ToHttpApiData a =>
 126          QueryName -> repr ([Maybe a] -> k) k
 127         queryFlag :: QueryName -> repr (Bool -> k) k
 128 type QueryName   = BS.ByteString
 129 type QueryValue  = BS.ByteString
 130
 131 query ::
 132  forall a repr k.
 133  HTTP_Query repr =>
 134  Web.FromHttpApiData a =>
 135  Web.ToHttpApiData a =>
 136  QueryName -> repr ([Maybe a] -> k) k
 137 query = query'
 138 {-# INLINE query #-}
 139
 140 -- * Class 'HTTP_Version'
 141 class HTTP_Version repr where
 142         version :: HTTP.HttpVersion -> repr k k
 143
 144 -- * Class 'HTTP_Status'
 145 class HTTP_Status repr where
 146         status :: StatusIs -> repr (HTTP.Status -> k) k
 147
 148 -- ** Type 'StatusIs'
 149 data StatusIs
 150  =   StatusIsInformational
 151  |   StatusIsSuccessful
 152  |   StatusIsRedirection
 153  |   StatusIsClientError
 154  |   StatusIsServerError
 155  |   StatusIs HTTP.Status
 156  deriving (Eq, Ord, Show)
 157 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 158 statusIs = \case
 159  StatusIsInformational -> HTTP.statusIsInformational
 160  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 161  StatusIsRedirection   -> HTTP.statusIsRedirection
 162  StatusIsClientError   -> HTTP.statusIsClientError
 163  StatusIsServerError   -> HTTP.statusIsServerError
 164  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 165
 166 status200 :: HTTP.Status
 167 status200 = HTTP.mkStatus 200 "Success"
 168 status404 :: HTTP.Status
 169 status404 = HTTP.mkStatus 404 "Not Found"
 170 status405 :: HTTP.Status
 171 status405 = HTTP.mkStatus 405 "Method Not Allowed"
 172 status406 :: HTTP.Status
 173 status406 = HTTP.mkStatus 406 "Not Acceptable"
 174
 175 -- * Class 'HTTP_Endpoint'
 176 class HTTP_Endpoint repr where
 177         type Endpoint repr :: *
 178         type EndpointArg repr :: * -> * -> *
 179         endpoint' ::
 180          MimeSerialize mt a =>
 181          MimeUnserialize mt a =>
 182          k ~ Endpoint repr =>
 183          HTTP.Method ->
 184          repr (EndpointArg repr mt a -> k) k
 185
 186 -- | Like |capture'| but with the type variables 'a' and 'mt' first instead or 'repr'
 187 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
 188 endpoint ::
 189  forall a mt repr k.
 190  HTTP_Endpoint repr =>
 191  MimeSerialize mt a =>
 192  MimeUnserialize mt a =>
 193  k ~ Endpoint repr =>
 194  HTTP.Method ->
 195  repr (EndpointArg repr mt a -> k) k
 196 endpoint = endpoint'
 197 {-# INLINE endpoint #-}