git.iko.soy/typeable/wai
on master help sign in
RequestHeader and ResponseHeader
commit9f9a82a442479fb4ddc5175688a68f8e64d4029c authorMichael Snoyman <michael@snoyman.com> dateFri 29 Jan 2010, 13:34 (17 years ago) parentd63940c
3 files changed+105−8
compare with master
unifiedsplit
Network/Wai.hs+97−2 Network/Wai/Handler/SimpleServer.hs+6−4 test.hs+2−2
Network/Wai.hs+97−2
@@ -11,6 +11,14 @@ module Network.Wai
1111 , HttpVersion (..)
1212 , httpVersionFromBS
1313 , httpVersionToBS
14+ -- ** Request header names
15+ , RequestHeader (..)
16+ , requestHeaderFromBS
17+ , requestHeaderToBS
18+ -- ** Response header names
19+ , ResponseHeader (..)
20+ , responseHeaderFromBS
21+ , responseHeaderToBS
1422 -- ** Response status code
1523 , Status (..)
1624 , statusCode
@@ -73,6 +81,7 @@ data HttpVersion =
7381 | Http10
7482 | Http11
7583 | HttpVersion B.ByteString
84+ deriving (Show, Eq)
7685
7786httpVersionFromBS :: B.ByteString -> HttpVersion
7887httpVersionFromBS bs
@@ -89,6 +98,92 @@ httpVersionToBS Http10 = B8.pack "1.0"
8998httpVersionToBS Http11 = B8.pack "1.1"
9099httpVersionToBS (HttpVersion bs) = bs
91100
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+
92187-- | This attempts to provide the most common HTTP status codes, not all of
93188-- them. Use the 'Status' constructor when you want to create a status code not
94189-- provided.
@@ -145,7 +240,7 @@ data Request = Request
145240 , queryString :: B.ByteString
146241 , serverName :: B.ByteString
147242 , serverPort :: Int
148− , httpHeaders :: [(B.ByteString, B.ByteString)]
243+ , httpHeaders :: [(RequestHeader, B.ByteString)]
149244 , urlScheme :: UrlScheme
150245 , requestBody :: IO (Maybe B.ByteString)
151246 , errorHandler :: String -> IO ()
@@ -154,7 +249,7 @@ data Request = Request
154249
155250data Response = Response
156251 { status :: Status
157− , headers :: [(B.ByteString, B.ByteString)]
252+ , headers :: [(ResponseHeader, B.ByteString)]
158253 , body :: Either FilePath ((B.ByteString -> IO ()) -> IO ())
159254 }
160255
Network/Wai/Handler/SimpleServer.hs+6−4
@@ -40,6 +40,7 @@ import qualified Web.Encodings.StringLike as SL
4040
4141import qualified Safe
4242import Network.Socket.SendFile
43+import Control.Arrow (first)
4344
4445run :: Port -> Application -> IO ()
4546run port = withSocketsDo .
@@ -109,12 +110,13 @@ parseRequest port lines' handle remoteHost' = do
109110 let rpath = '/' : case SL.unpack rpath' of
110111 ('/':x) -> x
111112 _ -> SL.unpack rpath'
112− let heads = map parseHeaderNoAttr $ tail lines'
113− let host' = lookup (SL.pack "Host") heads
113+ let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)
114+ $ tail lines'
115+ let host' = lookup Host heads
114116 unless (isJust host') $ failure HostNotIncluded
115117 let host = fromJust host'
116118 let len = fromMaybe 0 $ do
117− bs <- lookup (SL.pack "Content-Length") heads
119+ bs <- lookup ReqContentLength heads
118120 let str = SL.unpack bs
119121 Safe.readMay str
120122 mlen <- newMVar len
@@ -168,7 +170,7 @@ sendResponse h res = do
168170 Right enum -> enum $ BS.hPut h
169171 where
170172 putHeader (x, y) = do
171− BS.hPut h x
173+ BS.hPut h $ responseHeaderToBS x
172174 BS.hPut h $ SL.pack ": "
173175 BS.hPut h y
174176 BS.hPut h $ SL.pack "\r\n"
test.hs+2−2
@@ -14,14 +14,14 @@ app req = case B8.unpack $ pathInfo req of
1414indexResponse :: IO Response
1515indexResponse = return Response
1616 { status = Status200
17− , headers = [(B8.pack "Content-Type", B8.pack "text/html")]
17+ , headers = [(ContentType, B8.pack "text/html")]
1818 , body = index
1919 }
2020
2121postResponse :: IO (Maybe B.ByteString) -> IO Response
2222postResponse rb = return Response
2323 { status = Status200
24− , headers = [(B8.pack "Content-Type", B8.pack "text/plain")]
24+ , headers = [(ContentType, B8.pack "text/plain")]
2525 , body = Right $ postBody rb
2626 }
2727