git.iko.soy/typeable/wai
on master help sign in
RequestHeader and ResponseHeader
9f9a82aMichael Snoyman
Network/Wai.hs+97−2
compare with master
unifiedsplit
@@ -11,6 +11,14 @@ module Network.Wai
11 , HttpVersion (..)
11 , HttpVersion (..)
12 , httpVersionFromBS
12 , httpVersionFromBS
13 , httpVersionToBS
13 , httpVersionToBS
14+ -- ** Request header names
15+ , RequestHeader (..)
16+ , requestHeaderFromBS
17+ , requestHeaderToBS
18+ -- ** Response header names
19+ , ResponseHeader (..)
20+ , responseHeaderFromBS
21+ , responseHeaderToBS
14 -- ** Response status code
22 -- ** Response status code
15 , Status (..)
23 , Status (..)
16 , statusCode
24 , statusCode
@@ -73,6 +81,7 @@ data HttpVersion =
73 | Http10
81 | Http10
74 | Http11
82 | Http11
75 | HttpVersion B.ByteString
83 | HttpVersion B.ByteString
84+ deriving (Show, Eq)
76
85
77httpVersionFromBS :: B.ByteString -> HttpVersion
86httpVersionFromBS :: B.ByteString -> HttpVersion
78httpVersionFromBS bs
87httpVersionFromBS bs
@@ -89,6 +98,92 @@ httpVersionToBS Http10 = B8.pack "1.0"
89httpVersionToBS Http11 = B8.pack "1.1"
98httpVersionToBS Http11 = B8.pack "1.1"
90httpVersionToBS (HttpVersion bs) = bs
99httpVersionToBS (HttpVersion bs) = bs
91
100
101+data RequestHeader =
102+ Accept
103+ | AcceptCharset
104+ | AcceptEncoding
105+ | AcceptLanguage
106+ | Authorization
107+ | Cookie
108+ | ReqContentLength
109+ | ReqContentType
110+ | Host
111+ | Referer
112+ | RequestHeader B.ByteString
113+ deriving (Show)
114+
115+instance Eq RequestHeader where
116+ x == y = requestHeaderToBS x == requestHeaderToBS y
117+
118+requestHeaderFromBS :: B.ByteString -> RequestHeader
119+requestHeaderFromBS bs = case B8.unpack bs of
120+ "Accept" -> Accept
121+ "Accept-Charset" -> AcceptCharset
122+ "Accept-Encoding" -> AcceptEncoding
123+ "Accept-Language" -> AcceptLanguage
124+ "Authorization" -> Authorization
125+ "Cookie" -> Cookie
126+ "Content-Length" -> ReqContentLength
127+ "Content-Type" -> ReqContentType
128+ "Host" -> Host
129+ "Referer" -> Referer
130+ _ -> RequestHeader bs
131+
132+requestHeaderToBS :: RequestHeader -> B.ByteString
133+requestHeaderToBS Accept = B8.pack "Accept"
134+requestHeaderToBS AcceptCharset = B8.pack "Accept-Charset"
135+requestHeaderToBS AcceptEncoding = B8.pack "Accept-Encoding"
136+requestHeaderToBS AcceptLanguage = B8.pack "Accept-Language"
137+requestHeaderToBS Authorization = B8.pack "Authorization"
138+requestHeaderToBS Cookie = B8.pack "Cookie"
139+requestHeaderToBS ReqContentLength = B8.pack "Content-Length"
140+requestHeaderToBS ReqContentType = B8.pack "Content-Type"
141+requestHeaderToBS Host = B8.pack "Host"
142+requestHeaderToBS Referer = B8.pack "Referer"
143+requestHeaderToBS (RequestHeader bs) = bs
144+
145+data ResponseHeader =
146+ ContentEncoding
147+ | ContentLanguage
148+ | ContentLength
149+ | ContentDisposition
150+ | ContentType
151+ | Expires
152+ | Location
153+ | Server
154+ | SetCookie
155+ | ResponseHeader B.ByteString
156+ deriving (Show)
157+
158+instance Eq ResponseHeader where
159+ x == y = responseHeaderToBS x == responseHeaderToBS y
160+
161+
162+responseHeaderFromBS :: B.ByteString -> ResponseHeader
163+responseHeaderFromBS bs = case B8.unpack bs of
164+ "Content-Encoding" -> ContentEncoding
165+ "Content-Language" -> ContentLanguage
166+ "Content-Length" -> ContentLength
167+ "Content-Disposition" -> ContentDisposition
168+ "Content-Type" -> ContentType
169+ "Expires" -> Expires
170+ "Location" -> Location
171+ "Server" -> Server
172+ "Set-Cookie" -> SetCookie
173+ _ -> ResponseHeader bs
174+
175+responseHeaderToBS :: ResponseHeader -> B.ByteString
176+responseHeaderToBS ContentEncoding = B8.pack "Content-Encoding"
177+responseHeaderToBS ContentLanguage = B8.pack "Content-Language"
178+responseHeaderToBS ContentLength = B8.pack "Content-Length"
179+responseHeaderToBS ContentDisposition = B8.pack "Content-Disposition"
180+responseHeaderToBS ContentType = B8.pack "Content-Type"
181+responseHeaderToBS Expires = B8.pack "Expires"
182+responseHeaderToBS Location = B8.pack "Location"
183+responseHeaderToBS Server = B8.pack "Server"
184+responseHeaderToBS SetCookie = B8.pack "Set-Cookie"
185+responseHeaderToBS (ResponseHeader bs) = bs
186+
92-- | This attempts to provide the most common HTTP status codes, not all of
187-- | This attempts to provide the most common HTTP status codes, not all of
93-- them. Use the 'Status' constructor when you want to create a status code not
188-- them. Use the 'Status' constructor when you want to create a status code not
94-- provided.
189-- provided.
@@ -145,7 +240,7 @@ data Request = Request
145 , queryString :: B.ByteString
240 , queryString :: B.ByteString
146 , serverName :: B.ByteString
241 , serverName :: B.ByteString
147 , serverPort :: Int
242 , serverPort :: Int
148− , httpHeaders :: [(B.ByteString, B.ByteString)]
243+ , httpHeaders :: [(RequestHeader, B.ByteString)]
149 , urlScheme :: UrlScheme
244 , urlScheme :: UrlScheme
150 , requestBody :: IO (Maybe B.ByteString)
245 , requestBody :: IO (Maybe B.ByteString)
151 , errorHandler :: String -> IO ()
246 , errorHandler :: String -> IO ()
@@ -154,7 +249,7 @@ data Request = Request
154
249
155data Response = Response
250data Response = Response
156 { status :: Status
251 { status :: Status
157− , headers :: [(B.ByteString, B.ByteString)]
252+ , headers :: [(ResponseHeader, B.ByteString)]
158 , body :: Either FilePath ((B.ByteString -> IO ()) -> IO ())
253 , body :: Either FilePath ((B.ByteString -> IO ()) -> IO ())
159 }
254 }
160
255
Network/Wai/Handler/SimpleServer.hs+6−4
@@ -40,6 +40,7 @@ import qualified Web.Encodings.StringLike as SL
40
40
41import qualified Safe
41import qualified Safe
42import Network.Socket.SendFile
42import Network.Socket.SendFile
43+import Control.Arrow (first)
43
44
44run :: Port -> Application -> IO ()
45run :: Port -> Application -> IO ()
45run port = withSocketsDo .
46run port = withSocketsDo .
@@ -109,12 +110,13 @@ parseRequest port lines' handle remoteHost' = do
109 let rpath = '/' : case SL.unpack rpath' of
110 let rpath = '/' : case SL.unpack rpath' of
110 ('/':x) -> x
111 ('/':x) -> x
111 _ -> SL.unpack rpath'
112 _ -> SL.unpack rpath'
112− let heads = map parseHeaderNoAttr $ tail lines'
113+ let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)
114+ $ tail lines'
113− let host' = lookup (SL.pack "Host") heads
115+ let host' = lookup Host heads
114 unless (isJust host') $ failure HostNotIncluded
116 unless (isJust host') $ failure HostNotIncluded
115 let host = fromJust host'
117 let host = fromJust host'
116 let len = fromMaybe 0 $ do
118 let len = fromMaybe 0 $ do
117− bs <- lookup (SL.pack "Content-Length") heads
119+ bs <- lookup ReqContentLength heads
118 let str = SL.unpack bs
120 let str = SL.unpack bs
119 Safe.readMay str
121 Safe.readMay str
120 mlen <- newMVar len
122 mlen <- newMVar len
@@ -168,7 +170,7 @@ sendResponse h res = do
168 Right enum -> enum $ BS.hPut h
170 Right enum -> enum $ BS.hPut h
169 where
171 where
170 putHeader (x, y) = do
172 putHeader (x, y) = do
171− BS.hPut h x
173+ BS.hPut h $ responseHeaderToBS x
172 BS.hPut h $ SL.pack ": "
174 BS.hPut h $ SL.pack ": "
173 BS.hPut h y
175 BS.hPut h y
174 BS.hPut h $ SL.pack "\r\n"
176 BS.hPut h $ SL.pack "\r\n"
test.hs+2−2
@@ -14,14 +14,14 @@ app req = case B8.unpack $ pathInfo req of
14indexResponse :: IO Response
14indexResponse :: IO Response
15indexResponse = return Response
15indexResponse = return Response
16 { status = Status200
16 { status = Status200
17− , headers = [(B8.pack "Content-Type", B8.pack "text/html")]
17+ , headers = [(ContentType, B8.pack "text/html")]
18 , body = index
18 , body = index
19 }
19 }
20
20
21postResponse :: IO (Maybe B.ByteString) -> IO Response
21postResponse :: IO (Maybe B.ByteString) -> IO Response
22postResponse rb = return Response
22postResponse rb = return Response
23 { status = Status200
23 { status = Status200
24− , headers = [(B8.pack "Content-Type", B8.pack "text/plain")]
24+ , headers = [(ContentType, B8.pack "text/plain")]
25 , body = Right $ postBody rb
25 , body = Right $ postBody rb
26 }
26 }
27
27