Language/Symantic/HTTP/Sym.hs

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