Language/Symantic/HTTP/API.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 {-# LANGUAGE TypeApplications #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.Symantic.HTTP.API
   6  ( module Language.Symantic.HTTP.API
   7  , Functor(..), (<$>), ($>)
   8  , Applicative(..)
   9  , Alternative(..)
  10  ) where
  11
  12 import Control.Applicative (Applicative(..), Alternative(..))
  13 import Data.Bool
  14 import Data.Eq (Eq(..))
  15 import Data.Functor (Functor(..), (<$>), ($>), (<$))
  16 import Data.Maybe (Maybe(..))
  17 import Data.Ord (Ord(..))
  18 import Data.Proxy (Proxy(..))
  19 import Data.String (String)
  20 import Text.Show (Show(..))
  21 import qualified Data.ByteString as BS
  22 import qualified Data.ByteString.Lazy as BSL
  23 import qualified Data.Text as T
  24 import qualified Network.HTTP.Types as HTTP
  25 import qualified Network.Wai as Wai
  26
  27 import Language.Symantic.HTTP.Media
  28
  29 -- * Class 'HTTP_API'
  30 class
  31  ( Applicative    repr
  32  , Altern         repr
  33  , HTTP_Path      repr
  34  , HTTP_Method    repr
  35  , HTTP_Header    repr
  36  , HTTP_Accept    repr
  37  , HTTP_Query     repr
  38  , HTTP_Version   repr
  39  , HTTP_Endpoint  repr
  40  ) => HTTP_API repr
  41
  42 -- * Class 'Altern'
  43 class Altern repr where
  44         -- | There Is No Alternative
  45         tina :: repr a
  46         (<+>) :: repr a -> repr a -> repr a; infixl 3 <+>
  47         try :: repr a -> repr a
  48         choice :: [repr a] -> repr a
  49         choice [] = tina
  50         choice (r:rs) = try r <+> choice rs
  51 -- * Class 'HTTP_Path'
  52 class HTTP_Path repr where
  53         segment    :: Segment -> repr ()
  54         capture    :: Name -> repr Segment
  55         captureAll :: repr [Segment]
  56 type Segment     = T.Text
  57 type Path        = [Segment]
  58 type Name        = String
  59 -- * Class 'HTTP_Method'
  60 class HTTP_Method repr where
  61         method         :: HTTP.Method -> repr HTTP.Method
  62         method_GET     :: repr HTTP.Method
  63         method_POST    :: repr HTTP.Method
  64         method_HEAD    :: repr HTTP.Method
  65         method_PUT     :: repr HTTP.Method
  66         method_DELETE  :: repr HTTP.Method
  67         method_TRACE   :: repr HTTP.Method
  68         method_CONNECT :: repr HTTP.Method
  69         method_OPTIONS :: repr HTTP.Method
  70         method_PATCH   :: repr HTTP.Method
  71         method_GET     = method HTTP.methodGet
  72         method_HEAD    = method HTTP.methodHead
  73         method_PUT     = method HTTP.methodPut
  74         method_POST    = method HTTP.methodPost
  75         method_DELETE  = method HTTP.methodDelete
  76         method_TRACE   = method HTTP.methodTrace
  77         method_CONNECT = method HTTP.methodConnect
  78         method_OPTIONS = method HTTP.methodOptions
  79         method_PATCH   = method HTTP.methodPatch
  80 -- * Class 'HTTP_Header'
  81 class HTTP_Header repr where
  82         header :: HTTP.HeaderName -> repr HeaderValue
  83 type HeaderValue = BS.ByteString
  84 -- * Class 'HTTP_Accept'
  85 class HTTP_Accept repr where
  86         accept :: ToMediaType mt a => Proxy mt -> repr (a -> BSL.ByteString)
  87         {-
  88         acceptCase :: Functor repr => Altern repr => [AcceptResponse repr a] -> repr BSL.ByteString
  89         acceptCase [] = tina $> BSL.empty
  90         acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
  91         -}
  92 {-
  93 data AcceptResponse repr a =
  94  forall mt. ToMediaType mt a =>
  95  AcceptResponse (Proxy mt, repr a)
  96 -}
  97 -- * Class 'HTTP_Query'
  98 class HTTP_Query repr where
  99         query     :: QueryName -> repr [Maybe QueryValue]
 100         queryFlag :: QueryName -> repr Bool
 101 type QueryName   = BS.ByteString
 102 type QueryValue  = BS.ByteString
 103 -- * Class 'HTTP_Version'
 104 class HTTP_Version repr where
 105         version :: HTTP.HttpVersion -> repr HTTP.HttpVersion
 106 -- * Class 'HTTP_Status'
 107 class HTTP_Status repr where
 108         status :: StatusIs -> repr HTTP.Status
 109 -- ** Type 'StatusIs'
 110 data StatusIs
 111  =   StatusIsInformational
 112  |   StatusIsSuccessful
 113  |   StatusIsRedirection
 114  |   StatusIsClientError
 115  |   StatusIsServerError
 116  |   StatusIs HTTP.Status
 117  deriving (Eq, Ord, Show)
 118 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 119 statusIs = \case
 120  StatusIsInformational -> HTTP.statusIsInformational
 121  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 122  StatusIsRedirection   -> HTTP.statusIsRedirection
 123  StatusIsClientError   -> HTTP.statusIsClientError
 124  StatusIsServerError   -> HTTP.statusIsServerError
 125  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 126 -- * Class 'HTTP_Response'
 127 class HTTP_Response repr where
 128         response ::
 129          ToMediaType mt a =>
 130          HTTP.Method ->
 131          Proxy mt ->
 132          repr (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
 133
 134 -- * Class 'HTTP_Endpoint'
 135 class HTTP_Endpoint repr where
 136         type Endpoint repr :: * -> *
 137         endpoint ::
 138          ToMediaType mt a =>
 139          HTTP.Method ->
 140          Proxy mt ->
 141          repr (Endpoint repr a)