Language/Symantic/HTTP/API.hs

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