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