@@ -4,163 +4,69 @@
44module Network.Wai.Handler.Warp.HTTP2.Request (
55 mkRequest
66 , MkReq
7− , ValidHeaders(..)
8− , validateHeaders
97 ) where
108
11−#if __GLASGOW_HASKELL__ < 709
12−import Control.Applicative ((<$>))
13−#endif
9+import Control.Applicative ((<|>))
10+import Control.Arrow (first)
1411import Data.ByteString (ByteString)
15−import qualified Data.ByteString as BS
1612import qualified Data.ByteString.Char8 as B8
17−import Data.CaseInsensitive (mk)
18−import Data.Maybe (isJust)
13+import Data.Maybe (fromJust)
1914import qualified Data.Vault.Lazy as Vault
20−#if __GLASGOW_HASKELL__ < 709
21−import Data.Monoid (mempty)
22−#endif
23−import Data.Word8 (isUpper,_colon)
2415import Network.HPACK
25−import Network.HTTP.Types (RequestHeaders)
16+import Network.HPACK.Token
2617import qualified Network.HTTP.Types as H
2718import Network.Socket (SockAddr)
2819import Network.Wai
2920import Network.Wai.Handler.Warp.HTTP2.Types
3021import Network.Wai.Handler.Warp.HashMap (hashByteString)
31−import Network.Wai.Handler.Warp.ReadInt
3222import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)
33−import Network.Wai.Handler.Warp.Types
34−import Network.Wai.Internal (Request(..))
3523import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
3624import qualified Network.Wai.Handler.Warp.Timeout as Timeout
25+import Network.Wai.Handler.Warp.Types
26+import Network.Wai.Internal (Request(..))
3727
38−data ValidHeaders = ValidHeaders {
39− vhMethod :: !ByteString
40− , vhPath :: !ByteString
41− , vhAuth :: !(Maybe ByteString)
42− , vhRange :: !(Maybe ByteString)
43− , vhReferer :: !(Maybe ByteString)
44− , vhUA :: !(Maybe ByteString)
45− , vhCL :: !(Maybe Int)
46− , vhHeader :: !RequestHeaders
47− } deriving Show
48−
49−type MkReq = ValidHeaders -> IO ByteString -> (Request,InternalInfo)
28+type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> (Request,InternalInfo)
5029
5130mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq
52−mkRequest ii1 settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body =
53− (req,ii)
31+mkRequest ii1 settings addr (reqths,reqvt) body = (req,ii)
5432 where
55− (unparsedPath,query) = B8.break (=='?') p
56− !path = H.extractPath unparsedPath
57− !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
58− !h = hashByteString rawPath
5933 !req = Request {
60− requestMethod = m
34+ requestMethod = colonMethod
6135 , httpVersion = http2ver
6236 , rawPathInfo = rawPath
6337 , pathInfo = H.decodePathSegments path
6438 , rawQueryString = query
6539 , queryString = H.parseQuery query
66− , requestHeaders = case ma of
67− Nothing -> hdr
68− Just hv -> (mk "host", hv) : hdr
40+ , requestHeaders = headers
6941 , isSecure = True
7042 , remoteHost = addr
7143 , requestBody = body
7244 , vault = vaultValue
7345 , requestBodyLength = ChunkedBody -- fixme
74− , requestHeaderHost = ma
75− , requestHeaderRange = mrng
76− , requestHeaderReferer = mrr
77− , requestHeaderUserAgent = mua
46+ , requestHeaderHost = mHost
47+ , requestHeaderRange = mRange
48+ , requestHeaderReferer = mReferer
49+ , requestHeaderUserAgent = mUserAgent
7850 }
51+ headers = map (first tokenKey) ths
52+ where
53+ ths = case mHost of
54+ Nothing -> (tokenHost, colonAuth) : reqths
55+ Just _ -> reqths
56+ !colonPath = fromJust $ getHeaderValue tokenPath reqvt
57+ !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt
58+ !mAuth = getHeaderValue tokenAuthority reqvt
59+ !colonAuth = fromJust $ mAuth
60+ !mHost = getHeaderValue tokenHost reqvt <|> mAuth
61+ !mRange = getHeaderValue tokenRange reqvt
62+ !mReferer = getHeaderValue tokenReferer reqvt
63+ !mUserAgent = getHeaderValue tokenUserAgent reqvt
64+ (unparsedPath,query) = B8.break (=='?') colonPath
65+ !path = H.extractPath unparsedPath
66+ !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
67+ !h = hashByteString rawPath
7968 !ii = toInternalInfo ii1 h
8069 !th = threadHandle ii
8170 !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
8271 $ Vault.insert getFileInfoKey (getFileInfo ii)
8372 Vault.empty
84−
85−----------------------------------------------------------------
86−
87−data Special = Special {
88− colonMethod :: !(Maybe ByteString)
89− , colonPath :: !(Maybe ByteString)
90− , colonAuth :: !(Maybe ByteString)
91− , sRange :: !(Maybe ByteString)
92− , sReferer :: !(Maybe ByteString)
93− , sUA :: !(Maybe ByteString)
94− , contentLen :: !(Maybe ByteString)
95− } deriving Show
96−
97−emptySpecial :: Special
98−emptySpecial = Special Nothing Nothing Nothing Nothing Nothing Nothing Nothing
99−
100−-- |
101−--
102−-- >>> validateHeaders [(":method","GET"),(":path","path")]
103−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = []})
104−-- >>> validateHeaders [(":method","GET"),(":path","path"),(":authority","authority"),("accept-language","en")]
105−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Just "authority", vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en")]})
106−-- >>> validateHeaders [(":method","GET"),(":path","path"),("cookie","a=b"),("accept-language","en"),("cookie","c=d"),("cookie","e=f")]
107−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en"),("cookie","a=b; c=d; e=f")]})
108−validateHeaders :: HeaderList -> Maybe ValidHeaders
109−validateHeaders hs = case pseudo hs emptySpecial of
110− Just (Special (Just m) (Just p) ma mrng mrr mua mcl, !h)
111− -> Just $! ValidHeaders m p ma mrng mrr mua (readInt <$> mcl) h
112− _ -> Nothing
113− where
114− pseudo [] !s = Just (s,[])
115− pseudo h@((k,v):kvs) !s
116− | k == ":method" = if isJust (colonMethod s) then
117− Nothing
118− else
119− pseudo kvs (s { colonMethod = Just v })
120− | k == ":path" = if isJust (colonPath s) then
121− Nothing
122− else
123− pseudo kvs (s { colonPath = Just v })
124− | k == ":authority" = if isJust (colonAuth s) then
125− Nothing
126− else
127− pseudo kvs (s { colonAuth = Just v })
128− | k == ":scheme" = pseudo kvs s -- fixme: how to store :scheme?
129− | isPseudo k = Nothing
130− | otherwise = normal h (s,id,id)
131−
132− normal [] (!s,b,c) = Just (s, mkH b c)
133− normal ((k,v):kvs) (!s,b,c)
134− | isPseudo k = Nothing
135− | k == "connection" = Nothing
136− | k == "te" = if v == "trailers" then
137− normal kvs (s, b . ((mk k,v) :), c)
138− else
139− Nothing
140− | k == "range"
141− = normal kvs (s {sRange = Just v }, b . ((mk k,v) :), c)
142− | k == "referer"
143− = normal kvs (s { sReferer = Just v }, b . ((mk k,v) :), c)
144− | k == "user-agent"
145− = normal kvs (s { sUA = Just v }, b . ((mk k,v) :), c)
146− | k == "content-length"
147− = normal kvs (s { contentLen = Just v }, b . ((mk k,v) :), c)
148− | k == "host" = if isJust (colonAuth s) then
149− normal kvs (s, b, c)
150− else
151− normal kvs (s { colonAuth = Just v }, b, c)
152− | k == "cookie" = normal kvs (s, b, c . (v:))
153− | otherwise = case BS.find isUpper k of
154− Nothing -> normal kvs (s, b . ((mk k,v) :), c)
155− Just _ -> Nothing
156−
157− mkH b c = h
158− where
159− !h = b anchor
160− !cookieList = c []
161− !anchor
162− | null cookieList = []
163− | otherwise = let !v = BS.intercalate "; " cookieList
164− in [("cookie",v)]
165− isPseudo "" = False
166− isPseudo k = BS.head k == _colon