1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE BangPatterns #-}
4
5module Network.Wai.Handler.Warp.RequestHeader (
6      parseHeaderLines
7    , parseByteRanges
8    ) where
9
10import Control.Exception (Exception, throwIO)
11import Control.Monad (when)
12import Data.Typeable (Typeable)
13import qualified Data.ByteString as S
14import qualified Data.ByteString.Char8 as B (unpack, readInteger)
15import Data.ByteString.Internal (ByteString(..), memchr)
16import qualified Data.CaseInsensitive as CI
17import Data.Word (Word8)
18import Foreign.ForeignPtr (withForeignPtr)
19import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
20import Foreign.Storable (peek)
21import qualified Network.HTTP.Types as H
22-- import Network.Wai.Handler.Warp.Types
23import qualified Network.HTTP.Types.Header as HH
24-- $setup
25-- >>> :set -XOverloadedStrings
26
27data InvalidRequest = NotEnoughLines [String]
28                    | BadFirstLine String
29                    | NonHttp
30                    | IncompleteHeaders
31                    | ConnectionClosedByPeer
32                    | OverLargeHeader
33                    deriving (Eq, Typeable, Show)
34
35instance Exception InvalidRequest
36
37----------------------------------------------------------------
38
39parseHeaderLines :: [ByteString]
40                 -> IO (H.Method
41                       ,ByteString  --  Path
42                       ,ByteString  --  Path, parsed
43                       ,ByteString  --  Query
44                       ,H.HttpVersion
45                       ,H.RequestHeaders
46                       )
47parseHeaderLines [] = throwIO $ NotEnoughLines []
48parseHeaderLines (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
66parseRequestLine :: ByteString
67                 -> IO (H.Method
68                       ,ByteString -- Path
69                       ,ByteString -- Query
70                       ,H.HttpVersion)
71parseRequestLine 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
140parseHeader :: ByteString -> H.Header
141parseHeader s =
142    let (k, rest) = S.break (== 58) s -- ':'
143        rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
144     in (CI.mk k, rest')
145
146parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges
147parseByteRanges 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
173