@@ -0,0 +1,172 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+module Network.Wai.Handler.Warp.RequestHeader (
6+ parseHeaderLines
7+ , parseByteRanges
8+ ) where
9+
10+import Control.Exception (Exception, throwIO)
11+import Control.Monad (when)
12+import Data.Typeable (Typeable)
13+import qualified Data.ByteString as S
14+import qualified Data.ByteString.Char8 as B (unpack, readInteger)
15+import Data.ByteString.Internal (ByteString(..), memchr)
16+import qualified Data.CaseInsensitive as CI
17+import Data.Word (Word8)
18+import Foreign.ForeignPtr (withForeignPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
20+import Foreign.Storable (peek)
21+import qualified Network.HTTP.Types as H
22+-- import Network.Wai.Handler.Warp.Types
23+import qualified Network.HTTP.Types.Header as HH
24+-- $setup
25+-- >>> :set -XOverloadedStrings
26+
27+data InvalidRequest = NotEnoughLines [String]
28+ | BadFirstLine String
29+ | NonHttp
30+ | IncompleteHeaders
31+ | ConnectionClosedByPeer
32+ | OverLargeHeader
33+ deriving (Eq, Typeable, Show)
34+
35+instance Exception InvalidRequest
36+
37+----------------------------------------------------------------
38+
39+parseHeaderLines :: [ByteString]
40+ -> IO (H.Method
41+ ,ByteString -- Path
42+ ,ByteString -- Path, parsed
43+ ,ByteString -- Query
44+ ,H.HttpVersion
45+ ,H.RequestHeaders
46+ )
47+parseHeaderLines [] = throwIO $ NotEnoughLines []
48+parseHeaderLines (firstLine:otherLines) = do
49+ (method, path', query, httpversion) <- parseRequestLine firstLine
50+ let path = H.extractPath path'
51+ hdr = map parseHeader otherLines
52+ return (method, path', path, query, httpversion, hdr)
53+
54+----------------------------------------------------------------
55+
56+-- |
57+--
58+-- >>> parseRequestLine "GET / HTTP/1.1"
59+-- ("GET","/","",HTTP/1.1)
60+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"
61+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
62+-- >>> parseRequestLine "GET "
63+-- *** Exception: Warp: Invalid first line of request: "GET "
64+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
65+-- *** Exception: Warp: Request line specified a non-HTTP request
66+parseRequestLine :: ByteString
67+ -> IO (H.Method
68+ ,ByteString -- Path
69+ ,ByteString -- Query
70+ ,H.HttpVersion)
71+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
72+ when (len < 14) $ throwIO baderr
73+ let methodptr = ptr `plusPtr` off
74+ limptr = methodptr `plusPtr` len
75+ lim0 = fromIntegral len
76+
77+ pathptr0 <- memchr methodptr 32 lim0 -- ' '
78+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
79+ throwIO baderr
80+ let pathptr = pathptr0 `plusPtr` 1
81+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)
82+
83+ httpptr0 <- memchr pathptr 32 lim1 -- ' '
84+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
85+ throwIO baderr
86+ let httpptr = httpptr0 `plusPtr` 1
87+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
88+
89+ checkHTTP httpptr
90+ !hv <- httpVersion httpptr
91+ queryptr <- memchr pathptr 63 lim2 -- '?'
92+
93+ let !method = bs ptr methodptr pathptr0
94+ !path
95+ | queryptr == nullPtr = bs ptr pathptr httpptr0
96+ | otherwise = bs ptr pathptr queryptr
97+ !query
98+ | queryptr == nullPtr = S.empty
99+ | otherwise = bs ptr queryptr httpptr0
100+
101+ return (method,path,query,hv)
102+ where
103+ baderr = BadFirstLine $ B.unpack requestLine
104+ check :: Ptr Word8 -> Int -> Word8 -> IO ()
105+ check p n w = do
106+ w0 <- peek $ p `plusPtr` n
107+ when (w0 /= w) $ throwIO NonHttp
108+ checkHTTP httpptr = do
109+ check httpptr 0 72 -- 'H'
110+ check httpptr 1 84 -- 'T'
111+ check httpptr 2 84 -- 'T'
112+ check httpptr 3 80 -- 'P'
113+ check httpptr 4 47 -- '/'
114+ check httpptr 6 46 -- '.'
115+ httpVersion httpptr = do
116+ major <- peek $ httpptr `plusPtr` 5
117+ minor <- peek $ httpptr `plusPtr` 7
118+ return $ if major == (49 :: Word8) && minor == (49 :: Word8) then
119+ H.http11
120+ else
121+ H.http10
122+ bs ptr p0 p1 = PS fptr o l
123+ where
124+ o = p0 `minusPtr` ptr
125+ l = p1 `minusPtr` p0
126+
127+----------------------------------------------------------------
128+
129+-- |
130+--
131+-- >>> parseHeader "Content-Length:47"
132+-- ("Content-Length","47")
133+-- >>> parseHeader "Accept-Ranges: bytes"
134+-- ("Accept-Ranges","bytes")
135+-- >>> parseHeader "Host: example.com:8080"
136+-- ("Host","example.com:8080")
137+-- >>> parseHeader "NoSemiColon"
138+-- ("NoSemiColon","")
139+
140+parseHeader :: ByteString -> H.Header
141+parseHeader s =
142+ let (k, rest) = S.breakByte 58 s -- ':'
143+ rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
144+ in (CI.mk k, rest')
145+
146+parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges
147+parseByteRanges bs1 = do
148+ bs2 <- stripPrefix "bytes=" bs1
149+ (r, bs3) <- range bs2
150+ ranges (r:) bs3
151+ where
152+ range bs2 =
153+ case stripPrefix "-" bs2 of
154+ Just bs3 -> do
155+ (i, bs4) <- B.readInteger bs3
156+ Just (HH.ByteRangeSuffix i, bs4)
157+ Nothing -> do
158+ (i, bs3) <- B.readInteger bs2
159+ bs4 <- stripPrefix "-" bs3
160+ case B.readInteger bs4 of
161+ Nothing -> Just (HH.ByteRangeFrom i, bs4)
162+ Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)
163+ ranges front bs3 =
164+ case stripPrefix "," bs3 of
165+ Nothing -> Just (front [])
166+ Just bs4 -> do
167+ (r, bs5) <- range bs4
168+ ranges (front . (r:)) bs5
169+
170+ stripPrefix x y
171+ | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)
172+ | otherwise = Nothing