Language/Symantic/HTTP/Sym.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 module Language.Symantic.HTTP.Sym
   7  ( module Language.Symantic.HTTP.Sym
   8  , Functor(..), (<$>), ($>)
   9  , Applicative(..)
  10  , Alternative(..)
  11  ) where
  12
  13 import Control.Applicative (Applicative(..), Alternative(..))
  14 import Data.Bool
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (foldr)
  17 import Data.Function ((.))
  18 import Data.Functor (Functor(..), (<$>), ($>), (<$))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Proxy (Proxy(..))
  22 import Data.String (String)
  23 import Text.Show (Show(..))
  24 import qualified Data.ByteString as BS
  25 import qualified Data.ByteString.Lazy as BSL
  26 import qualified Data.Text as T
  27 -- import qualified Network.HTTP.Media as Media
  28 import qualified Network.HTTP.Types as HTTP
  29 import qualified Network.Wai as Wai
  30
  31 import Language.Symantic.HTTP.Media
  32
  33 -- * Class 'HTTP_Server'
  34 class
  35  ( Applicative    repr
  36  , Altern         repr
  37  , HTTP_Path      repr
  38  , HTTP_Method    repr
  39  , HTTP_Header    repr
  40  , HTTP_Accept    repr
  41  , HTTP_Response  repr
  42  , HTTP_Query     repr
  43  , HTTP_Version   repr
  44  ) => HTTP_Server repr
  45
  46 -- * Class 'Altern'
  47 class Altern repr where
  48         -- | There Is No Alternative
  49         tina :: repr a
  50         (<+>) :: repr a -> repr a -> repr a; infixl 3 <+>
  51         try :: repr a -> repr a
  52         choice :: [repr a] -> repr a
  53         choice = foldr ((<+>) . try) tina
  54 -- * Class 'HTTP_Path'
  55 class HTTP_Path repr where
  56         segment    :: Segment -> repr ()
  57         capture    :: Name -> repr Segment
  58         captureAll :: repr [Segment]
  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 -- * Class 'HTTP_Response'
  84 class HTTP_Response repr where
  85         response ::
  86          ToMediaType mt a =>
  87          HTTP.Method ->
  88          Proxy mt ->
  89          repr (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
  90 -- * Class 'HTTP_Accept'
  91 data AcceptResponse repr a =
  92  forall mt. ToMediaType mt a =>
  93  AcceptResponse (Proxy mt, repr a)
  94 class HTTP_Accept repr where
  95         accept :: ToMediaType mt a => Proxy mt -> repr (a -> BSL.ByteString)
  96         {-
  97         acceptCase :: Functor repr => Altern repr => [AcceptResponse repr a] -> repr BSL.ByteString
  98         acceptCase [] = tina $> BSL.empty
  99         acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
 100         -}
 101 -- * Class 'HTTP_Query'
 102 class HTTP_Query repr where
 103         query     :: QueryName -> repr [Maybe QueryValue]
 104         queryFlag :: QueryName -> repr Bool
 105 -- * Class 'HTTP_Version'
 106 class HTTP_Version repr where
 107         version :: HTTP.HttpVersion -> repr HTTP.HttpVersion
 108 -- * Class 'HTTP_Status'
 109 class HTTP_Status repr where
 110         status :: StatusIs -> repr HTTP.Status
 111 -- ** Type 'StatusIs'
 112 data StatusIs
 113  =   StatusIsInformational
 114  |   StatusIsSuccessful
 115  |   StatusIsRedirection
 116  |   StatusIsClientError
 117  |   StatusIsServerError
 118  |   StatusIs HTTP.Status
 119  deriving (Eq, Ord, Show)
 120 statusIs :: StatusIs -> (HTTP.Status -> Bool)
 121 statusIs = \case
 122  StatusIsInformational -> HTTP.statusIsInformational
 123  StatusIsSuccessful    -> HTTP.statusIsSuccessful
 124  StatusIsRedirection   -> HTTP.statusIsRedirection
 125  StatusIsClientError   -> HTTP.statusIsClientError
 126  StatusIsServerError   -> HTTP.statusIsServerError
 127  StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y
 128
 129 type Name        = String
 130 type Value       = String
 131 type Segment     = T.Text
 132 type Path        = [Segment]
 133 -- type Headers     = HM.HashMap HTTP.HeaderName [HeaderValue]
 134 type HeaderValue = BS.ByteString
 135 -- type Query       = HM.HashMap QueryName [QueryValue]
 136 type QueryName   = BS.ByteString
 137 type QueryValue  = BS.ByteString
 138 -- type MediaType   = Media.MediaType