]> Git — Sourcephile - haskell/symantic-http.git/blob - Language/Symantic/HTTP/Sym.hs
Rewrite the API builder with a composable sprintf/scanf design
[haskell/symantic-http.git] / 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