@@ -26,7 +26,7 @@ import Data.Monoid (mempty)
2626#endif
2727import Data.Word8 (isUpper,_colon)
2828import Network.HPACK
29−import Network.HTTP.Types (RequestHeaders,hRange)
29+import Network.HTTP.Types (RequestHeaders)
3030import qualified Network.HTTP.Types as H
3131import Network.Socket (SockAddr)
3232import Network.Wai
@@ -39,17 +39,20 @@ import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoPar
3939import qualified Network.Wai.Handler.Warp.Timeout as Timeout
4040
4141data ValidHeaders = ValidHeaders {
42− vhMethod :: !ByteString
43− , vhPath :: !ByteString
44− , vhAuth :: !(Maybe ByteString)
45− , vhCL :: !(Maybe Int)
46− , vhHeader :: !RequestHeaders
42+ vhMethod :: !ByteString
43+ , vhPath :: !ByteString
44+ , vhAuth :: !(Maybe ByteString)
45+ , vhRange :: !(Maybe ByteString)
46+ , vhReferer :: !(Maybe ByteString)
47+ , vhUA :: !(Maybe ByteString)
48+ , vhCL :: !(Maybe Int)
49+ , vhHeader :: !RequestHeaders
4750 } deriving Show
4851
4952type MkReq = ValidHeaders -> IO ByteString -> Request
5053
5154mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq
52−mkRequest ii settings addr (ValidHeaders m p ma _ hdr) body = req
55+mkRequest ii settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body = req
5356 where
5457 (unparsedPath,query) = B8.break (=='?') p
5558 !path = H.extractPath unparsedPath
@@ -68,75 +71,86 @@ mkRequest ii settings addr (ValidHeaders m p ma _ hdr) body = req
6871 , requestBody = body
6972 , vault = vaultValue
7073 , requestBodyLength = ChunkedBody -- fixme
71− , requestHeaderHost = ma
72− , requestHeaderRange = lookup hRange hdr
74+ , requestHeaderHost = ma
75+ , requestHeaderRange = mrng
76+ , requestHeaderReferer = mrr
77+ , requestHeaderUserAgent = mua
7378 }
7479 !th = threadHandle ii
7580 !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
76− $ Vault.insert getFileInfoKey (fileInfo ii)
77− Vault.empty
81+ $ Vault.insert getFileInfoKey (fileInfo ii)
82+ Vault.empty
7883
7984----------------------------------------------------------------
8085
81−data Pseudo = Pseudo {
86+data Special = Special {
8287 colonMethod :: !(Maybe ByteString)
8388 , colonPath :: !(Maybe ByteString)
8489 , colonAuth :: !(Maybe ByteString)
90+ , sRange :: !(Maybe ByteString)
91+ , sReferer :: !(Maybe ByteString)
92+ , sUA :: !(Maybe ByteString)
8593 , contentLen :: !(Maybe ByteString)
8694 } deriving Show
8795
88−emptyPseudo :: Pseudo
89−emptyPseudo = Pseudo Nothing Nothing Nothing Nothing
96+emptySpecial :: Special
97+emptySpecial = Special Nothing Nothing Nothing Nothing Nothing Nothing Nothing
9098
9199-- |
92100--
93101-- >>> validateHeaders [(":method","GET"),(":path","path")]
94−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhCL = Nothing, vhHeader = []})
102+-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = []})
95103-- >>> validateHeaders [(":method","GET"),(":path","path"),(":authority","authority"),("accept-language","en")]
96−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Just "authority", vhCL = Nothing, vhHeader = [("accept-language","en")]})
104+-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Just "authority", vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en")]})
97105-- >>> validateHeaders [(":method","GET"),(":path","path"),("cookie","a=b"),("accept-language","en"),("cookie","c=d"),("cookie","e=f")]
98−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en"),("cookie","a=b; c=d; e=f")]})
106+-- 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")]})
99107validateHeaders :: HeaderList -> Maybe ValidHeaders
100−validateHeaders hs = case pseudo hs emptyPseudo of
101− Just (Pseudo (Just m) (Just p) ma mcl, !h)
102− -> Just $! ValidHeaders m p ma (readInt <$> mcl) h
108+validateHeaders hs = case pseudo hs emptySpecial of
109+ Just (Special (Just m) (Just p) ma mrng mrr mua mcl, !h)
110+ -> Just $! ValidHeaders m p ma mrng mrr mua (readInt <$> mcl) h
103111 _ -> Nothing
104112 where
105− pseudo [] !p = Just (p,[])
106− pseudo h@((k,v):kvs) !p
107− | k == ":method" = if isJust (colonMethod p) then
113+ pseudo [] !s = Just (s,[])
114+ pseudo h@((k,v):kvs) !s
115+ | k == ":method" = if isJust (colonMethod s) then
108116 Nothing
109117 else
110− pseudo kvs (p { colonMethod = Just v })
111− | k == ":path" = if isJust (colonPath p) then
118+ pseudo kvs (s { colonMethod = Just v })
119+ | k == ":path" = if isJust (colonPath s) then
112120 Nothing
113121 else
114− pseudo kvs (p { colonPath = Just v })
115− | k == ":authority" = if isJust (colonAuth p) then
122+ pseudo kvs (s { colonPath = Just v })
123+ | k == ":authority" = if isJust (colonAuth s) then
116124 Nothing
117125 else
118− pseudo kvs (p { colonAuth = Just v })
119− | k == ":scheme" = pseudo kvs p -- fixme: how to store :scheme?
126+ pseudo kvs (s { colonAuth = Just v })
127+ | k == ":scheme" = pseudo kvs s -- fixme: how to store :scheme?
120128 | isPseudo k = Nothing
121− | otherwise = normal h (p,id,id)
129+ | otherwise = normal h (s,id,id)
122130
123− normal [] (!p,b,c) = Just (p, mkH b c)
124− normal ((k,v):kvs) (!p,b,c)
131+ normal [] (!s,b,c) = Just (s, mkH b c)
132+ normal ((k,v):kvs) (!s,b,c)
125133 | isPseudo k = Nothing
126134 | k == "connection" = Nothing
127135 | k == "te" = if v == "trailers" then
128− normal kvs (p, b . ((mk k,v) :), c)
136+ normal kvs (s, b . ((mk k,v) :), c)
129137 else
130138 Nothing
139+ | k == "range"
140+ = normal kvs (s {sRange = Just v }, b . ((mk k,v) :), c)
141+ | k == "referer"
142+ = normal kvs (s { sReferer = Just v }, b . ((mk k,v) :), c)
143+ | k == "user-agent"
144+ = normal kvs (s { sUA = Just v }, b . ((mk k,v) :), c)
131145 | k == "content-length"
132− = normal kvs (p { contentLen = Just v }, b . ((mk k,v) :), c)
133− | k == "host" = if isJust (colonAuth p) then
134− normal kvs (p, b, c)
146+ = normal kvs (s { contentLen = Just v }, b . ((mk k,v) :), c)
147+ | k == "host" = if isJust (colonAuth s) then
148+ normal kvs (s, b, c)
135149 else
136− normal kvs (p { colonAuth = Just v }, b, c)
137− | k == "cookie" = normal kvs (p, b, c . (v:))
150+ normal kvs (s { colonAuth = Just v }, b, c)
151+ | k == "cookie" = normal kvs (s, b, c . (v:))
138152 | otherwise = case BS.find isUpper k of
139− Nothing -> normal kvs (p, b . ((mk k,v) :), c)
153+ Nothing -> normal kvs (s, b . ((mk k,v) :), c)
140154 Just _ -> Nothing
141155
142156 mkH b c = h