Language/Symantic/HTTP/API.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 {-# LANGUAGE TypeFamilies #-}
   4 {-# LANGUAGE TypeOperators #-}
   5 module Language.Symantic.HTTP.API
   6  ( module Language.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 Language.Symantic.HTTP.Media
  22 import Language.Symantic.HTTP.Mime
  23
  24 -- * Class 'HTTP_API'
  25 class
  26  ( Appli          repr
  27  , Altern         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 'Appli'
  38 class Appli 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 -- * Class 'Altern'
  42 class Altern repr where
  43         {-
  44         type AlternMerge repr :: * -> * -> *
  45         (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AlternMerge 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 -- ** Type ':!:'
  51 -- Like '(,)' but 'infixl'.
  52 data (:!:) a b = a:!:b
  53 infixl 3 :!:
  54 -- * Class 'HTTP_Path'
  55 class HTTP_Path repr where
  56         segment  :: Segment -> repr k k
  57         capture' :: Web.FromHttpApiData a =>
  58                     Web.ToHttpApiData a =>
  59                     Name -> repr (a -> k) k
  60         captureAll :: repr ([Segment] -> k) k
  61
  62 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
  63 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
  64 capture ::
  65  forall a repr k.
  66  HTTP_Path repr =>
  67  Web.FromHttpApiData a =>
  68  Web.ToHttpApiData a =>
  69  Name -> repr (a -> k) k
  70 capture = capture'
  71 {-# INLINE capture #-}
  72
  73 type Segment     = T.Text
  74 type Path        = [Segment]
  75 type Name        = String
  76 -- * Class 'HTTP_Method'
  77 class HTTP_Method repr where
  78         method         :: HTTP.Method -> repr k k
  79         method_GET     :: repr k k
  80         method_POST    :: repr k k
  81         method_HEAD    :: repr k k
  82         method_PUT     :: repr k k
  83         method_DELETE  :: repr k k
  84         method_TRACE   :: repr k k
  85         method_CONNECT :: repr k k
  86         method_OPTIONS :: repr k k
  87         method_PATCH   :: repr k k
  88         method_GET     = method HTTP.methodGet
  89         method_HEAD    = method HTTP.methodHead
  90         method_PUT     = method HTTP.methodPut
  91         method_POST    = method HTTP.methodPost
  92         method_DELETE  = method HTTP.methodDelete
  93         method_TRACE   = method HTTP.methodTrace
  94         method_CONNECT = method HTTP.methodConnect
  95         method_OPTIONS = method HTTP.methodOptions
  96         method_PATCH   = method HTTP.methodPatch
  97 -- * Class 'HTTP_Header'
  98 class HTTP_Header repr where
  99         header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
 100 type HeaderValue = BS.ByteString
 101 -- * Class 'HTTP_Accept'
 102 class HTTP_Accept repr where
 103         accept :: MediaTypeable mt => Proxy mt -> repr k k
 104         {-
 105         acceptCase :: Functor repr => Altern repr => [AcceptResponse repr a] -> repr BSL.ByteString
 106         acceptCase [] = tina $> BSL.empty
 107         acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
 108         -}
 109 {-
 110 data AcceptResponse repr a =
 111  forall mt. MimeSerialize mt a =>
 112  AcceptResponse (Proxy mt, repr a)
 113 -}
 114 -- * Class 'HTTP_Query'
 115 class HTTP_Query repr where
 116         query     :: QueryName -> repr ([Maybe QueryValue] -> k) k
 117         queryFlag :: QueryName -> repr (Bool -> k) k
 118 type QueryName   = BS.ByteString
 119 type QueryValue  = BS.ByteString
 120 -- * Class 'HTTP_Version'
 121 class HTTP_Version repr where
 122         version :: HTTP.HttpVersion -> repr k k
 123 -- * Class 'HTTP_Status'
 124 class HTTP_Status repr where
 125         status :: StatusIs -> repr (HTTP.Status -> k) k
 126 -- ** Type 'StatusIs'
 127 data StatusIs
 128  =   StatusIsInformational
 129  |   StatusIsSuccessful
 130  |   StatusIsRedirection
 131  |   StatusIsClientError
 132  |   StatusIsServerError
 133  |   StatusIs HTTP.Status
 134  deriving (Eq, Ord, Show)
 135 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 136 statusIs = \case
 137  StatusIsInformational -> HTTP.statusIsInformational
 138  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 139  StatusIsRedirection   -> HTTP.statusIsRedirection
 140  StatusIsClientError   -> HTTP.statusIsClientError
 141  StatusIsServerError   -> HTTP.statusIsServerError
 142  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 143
 144 status200 :: HTTP.Status
 145 status200 = HTTP.mkStatus 200 "Success"
 146 status404 :: HTTP.Status
 147 status404 = HTTP.mkStatus 404 "Not Found"
 148 {-
 149 -- * Class 'HTTP_Response'
 150 class HTTP_Response repr where
 151         response ::
 152          MimeSerialize mt a =>
 153          HTTP.Method ->
 154          Proxy mt ->
 155          repr ((HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response) -> k) k
 156 -}
 157
 158 -- * Class 'HTTP_Endpoint'
 159 class HTTP_Endpoint repr where
 160         type Endpoint repr :: *
 161         type EndpointArg repr :: * -> * -> *
 162         endpoint' ::
 163          MimeSerialize mt a =>
 164          MimeUnserialize mt a =>
 165          k ~ Endpoint repr =>
 166          HTTP.Method ->
 167          repr (EndpointArg repr mt a -> k) k
 168
 169 endpoint ::
 170  forall a mt repr k.
 171  HTTP_Endpoint repr =>
 172  MimeSerialize mt a =>
 173  MimeUnserialize mt a =>
 174  k ~ Endpoint repr =>
 175  HTTP.Method ->
 176  repr (EndpointArg repr mt a -> k) k
 177 endpoint = endpoint'
 178 {-# INLINE endpoint #-}