second-transfer-0.10.0.1: hs-src/SecondTransfer/Http1/Parse.hs
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module SecondTransfer.Http1.Parse(
newIncrementalHttp1Parser
,addBytes
-- Internal exports, used by the test suite
,locateCRLFs
,splitByColon
,stripBs
,headerListToHTTP1RequestText
,headerListToHTTP1ResponseText
,serializeHTTPResponse
,methodHasRequestBody
,methodHasResponseBody
,chunkParser
,transferEncodingIsChunked
,wrapChunk
,unwrapChunks
,IncrementalHttp1Parser
,Http1ParserCompletion(..)
,BodyStopCondition(..)
) where
import Control.Exception (throw)
-- import Control.Lens
import qualified Control.Lens as L
import Control.Applicative
--import Control.DeepSeq (deepseq)
import Numeric as Nm
import qualified Data.ByteString as B
import Data.List (foldl')
import qualified Data.ByteString.Builder as Bu
import Data.ByteString.Char8 (pack, unpack)
import qualified Data.ByteString.Char8 as Ch8
import qualified Data.ByteString.Lazy as Lb
import Data.Char (toLower)
import Data.Maybe (isJust, fromMaybe)
import qualified Data.Attoparsec.ByteString as Ap
import qualified Data.Attoparsec.ByteString.Char8 as Ap8
import Data.Foldable (find)
import Data.Word (Word8)
import qualified Data.Map as M
import Data.Conduit
import Text.Read (readEither)
import qualified Network.URI as U
import qualified SecondTransfer.Utils.HTTPHeaders as E
import qualified SecondTransfer.Utils.HTTPHeaders as He
import SecondTransfer.Exception
import SecondTransfer.MainLoop.CoherentWorker (Headers)
import SecondTransfer.Utils (subByteString)
import qualified SecondTransfer.ConstantsAndLimits as Constant
-- import Debug.Trace
data IncrementalHttp1Parser = IncrementalHttp1Parser {
_fullText :: Bu.Builder
,_stateParser :: HeaderParseClosure
}
type HeaderParseClosure = (B.ByteString -> ([Int], Int, Word8))
-- L.makeLenses ''IncrementalHttp1Parser
instance Show IncrementalHttp1Parser where
show (IncrementalHttp1Parser ft _sp ) = show $ Bu.toLazyByteString ft
newIncrementalHttp1Parser :: IncrementalHttp1Parser
newIncrementalHttp1Parser = IncrementalHttp1Parser {
_fullText = mempty
,_stateParser = locateCRLFs 0 [] 0
}
-- | Was the parser complete?
data Http1ParserCompletion =
-- | No, not even headers are done. Use the returned
-- value to continue
MustContinue_H1PC !IncrementalHttp1Parser
-- | Headers were completed. For some HTTP methods that's all
-- there is, and that's what this case represents. The second
-- argument is a left-overs string, that should be completed
-- with any other data required
|OnlyHeaders_H1PC !Headers !B.ByteString
-- | For requests with a body. The second argument is a condition
-- to stop receiving the body, the third is leftovers from
-- parsing the headers.
|HeadersAndBody_H1PC !Headers !BodyStopCondition !B.ByteString
-- | Some requests are ill-formed. We can check those cases
-- here.
|RequestIsMalformed_H1PC String
deriving Show
-- | Stop condition when parsing the body.
-- Tons and tons of messages in the internet go without a Content-Length
-- header, in those cases there is a long chain of conditions to determine the
-- message length, and at the end of those, there is CloseConnection
--
data BodyStopCondition =
UseBodyLength_BSC Int -- ^ There is a content-length header, and a length
| ConnectionClosedByPeer_BSC -- ^ We expect the connection to be closed by the peer when the stream finishes
| Chunked_BSC -- ^ It's a chunked transfer, use the corresponding parser
| SemanticAbort_BSC -- ^ Terrible things have happened, close the connection
deriving (Show, Eq)
data RequestOrResponseLine =
-- First argument is the URI, second the method
Request_RoRL B.ByteString B.ByteString
-- First argument is the status code
|Response_RoRL Int
deriving (Show, Eq)
addBytes :: IncrementalHttp1Parser -> B.ByteString -> Http1ParserCompletion
addBytes (IncrementalHttp1Parser full_text header_parse_closure) new_bytes =
let -- Just feed the bytes
(positions, length_so_far, last_char ) = header_parse_closure new_bytes
new_full_text = full_text `mappend` (Bu.byteString new_bytes)
could_finish = twoCRLFsAreConsecutive positions
total_length_now = B.length new_bytes + length_so_far
full_text_lbs = (Bu.toLazyByteString new_full_text)
-- This will only trigger for ill-formed heads, if the head is parsed successfully, this
-- flag will be ignored.
head_is_suspicious =
if total_length_now > 399 then
if total_length_now < Constant.maxUrlLength
then looksSuspicious full_text_lbs
else True
else False
in
case (could_finish, head_is_suspicious) of
(Just at_position, _) -> elaborateHeaders new_full_text positions at_position
(Nothing, True ) -> RequestIsMalformed_H1PC "Head is suspicious"
(Nothing, False) -> MustContinue_H1PC
$ IncrementalHttp1Parser
new_full_text
(locateCRLFs length_so_far positions last_char)
-- Look for suspicious patterns in the bs, like tab characters, or \r or \n
-- which are alone
looksSuspicious :: Lb.ByteString -> Bool
looksSuspicious bs =
let
have_weird_characters = isJust $ Lb.find (\w8 -> w8 < 32 && w8 /= 10 && w8 /= 13 ) bs
have_lone_n = let
ei = Lb.elemIndices 13 bs
eii = Lb.elemIndices 10 bs
zp = zip ei eii
f ((i,j):rest) | i+1 == j = f rest
| i == Lb.length bs - 1 = False
| otherwise = True
f [] = False
in f zp || abs ( length ei - length eii) > 1
result = have_lone_n || have_weird_characters
in result
-- This function takes care of retrieving headers....
elaborateHeaders :: Bu.Builder -> [Int] -> Int -> Http1ParserCompletion
elaborateHeaders full_text crlf_positions last_headers_position =
let
-- Start by getting a full byte-string representation of the headers,
-- no need to be silly with chunks.
full_headers_text = Lb.toStrict $ Bu.toLazyByteString full_text
-- Filter out CRLF pairs corresponding to multiline headers.
no_cont_positions_reverse =
filter
(\ pos -> if pos == last_headers_position then True else
if pos > last_headers_position then False else
not . isWsCh8 $
(Ch8.index
full_headers_text
(pos + 2)
)
)
crlf_positions
no_cont_positions = reverse no_cont_positions_reverse
-- Now get the headers as slices from the original string.
headers_pre :: [B.ByteString]
headers_pre = map
(\ (start, stop) ->
subByteString start stop full_headers_text
)
(zip
((:)
0
(map
( + 2 )
(init no_cont_positions)
)
)
no_cont_positions
)
no_empty_headers ::[B.ByteString]
no_empty_headers = filter (\x -> B.length x > 0) headers_pre
-- We remove the first "header" because it is actually the
-- initial HTTP request/response line
headers_0 = map splitByColon $ tail no_empty_headers
-- The first line is not actually a header, but contains the method, the version
-- and the URI
maybe_request_or_response = parseFirstLine (head headers_pre)
headers_1 = [
( (stripBsHName . bsToLower $ hn), stripBs hv ) | (hn, hv) <- headers_0
]
Just request_or_response = maybe_request_or_response
(headers_2, has_body) = case request_or_response of
Request_RoRL uri method ->
let
-- No lowercase, methods are case sensitive
-- lc_method = bsToLower method
--
-- TODO: There is a bug here, according to Section 3.3 of RFC 7230
has_body' = methodHasRequestBody method
in
-- TODO: We should probably add the "scheme" pseudo header here
( (":path", uri):(":method",method):headers_1, has_body' )
Response_RoRL status ->
let
status_str = pack . show $ status
excludes_body =
( (Ch8.head status_str) == '1')
||
( status == 204 || status == 304)
in
((":status", status_str): headers_1, not excludes_body)
-- Still we need to lower-case header names, and trim them
headers_3 = [
( (stripBsHName . bsToLower $ hn), stripBs hv ) | (hn, hv) <- headers_2
]
content_stop :: BodyStopCondition
content_stop =
let
cnt_length_header = find (\ x -> (fst x) == "content-length" ) headers_3
transfer_encoding = find (\ x -> (fst x) == "transfer-encoding" ) headers_3
in
case transfer_encoding of
Nothing ->
case cnt_length_header of
Just (_, hv) -> case readEither . unpack $ hv of
Left _ -> SemanticAbort_BSC
Right n -> UseBodyLength_BSC n
Nothing -> ConnectionClosedByPeer_BSC
Just (_, tre_value)
| transferEncodingIsChunked tre_value ->
Chunked_BSC
| otherwise ->
SemanticAbort_BSC
leftovers = B.drop (last_headers_position + 4) full_headers_text
all_headers_ok = all verifyHeaderSyntax headers_1
in
if isJust maybe_request_or_response then
(if all_headers_ok then
if has_body
then
HeadersAndBody_H1PC headers_3 content_stop leftovers
else
OnlyHeaders_H1PC headers_3 leftovers
else
RequestIsMalformed_H1PC "InvalidSyntaxOnHeaders")
else
RequestIsMalformed_H1PC "InvalidFirstLineOnRequest"
splitByColon :: B.ByteString -> (B.ByteString, B.ByteString)
splitByColon = L.over L._2 (B.tail) . Ch8.break (== ':')
transferEncodingIsChunked :: B.ByteString -> Bool
transferEncodingIsChunked x = x == "chunked"
verifyHeaderName :: B.ByteString -> Bool
verifyHeaderName =
B.all ( \ w8 ->
( ( w8 >= 48 && w8 <=57 ) || ( w8 >= 65 && w8 <= 90)
|| ( w8 >= 97 && w8 <= 122) )
|| ( w8 == 43 ) || ( w8 == 95) -- "extensions" for our local tooling
|| ( w8 == 45) -- Standard dash
)
verifyHeaderValue :: B.ByteString -> Bool
verifyHeaderValue = B.all ( \ w8 ->
w8 >= 32 && w8 < 127
)
verifyHeaderSyntax :: (B.ByteString, B.ByteString) -> Bool
verifyHeaderSyntax (a,b) = verifyHeaderName a && verifyHeaderValue b
parseFirstLine :: B.ByteString -> Maybe RequestOrResponseLine
parseFirstLine s =
let
either_error_or_rrl = Ap.parseOnly (httpFirstLine <* Ap.endOfInput ) s
in
case either_error_or_rrl of
Left _ -> Nothing
Right rrl -> Just rrl
bsToLower :: B.ByteString -> B.ByteString
bsToLower = Ch8.map toLower
-- This ought to be slow!
stripBs :: B.ByteString -> B.ByteString
stripBs s =
fst
.
last
$
takeWhile
( \ (_, ch) -> isWsCh8 ch )
$
iterate
( \ (bs, _) ->
case Ch8.unsnoc bs of
Just (newbs, w8) -> (newbs, w8)
Nothing -> ("", 'n')
)
(Ch8.dropWhile isWsCh8 s, ' ')
stripBsHName :: B.ByteString -> B.ByteString
stripBsHName s =
Ch8.dropWhile isWsCh8 s
locateCRLFs :: Int -> [Int] -> Word8 -> B.ByteString -> ([Int], Int, Word8)
locateCRLFs initial_offset other_positions prev_last_char next_chunk =
let
(last_char, positions_list, strlen) =
B.foldl
(\ (prev_char, lst, i) w8 ->
let
j = i + 1
in case (prev_char, w8) of
(13,10) -> (w8, (i-1):lst, j)
_ -> (w8, lst, j)
)
(prev_last_char, other_positions, initial_offset)
next_chunk
in (positions_list, strlen, last_char)
-- Parses the given list of positions, which is a reversed list. If
-- we find that the two latest positions of CRLF are consecutive,
-- then we are ok. and return it
twoCRLFsAreConsecutive :: [Int] -> Maybe Int
twoCRLFsAreConsecutive positions =
let
-- This function is moving from tail to head
go seen (p2:p1:r) | p2 - p1 == 2 = go (Just p1) (p1:r)
| otherwise = go seen (p1:r)
go seen _ = seen
in go Nothing positions
isWsCh8 :: Char -> Bool
isWsCh8 ch = isJust (Ch8.elemIndex
ch
" \t"
)
isWs :: Word8 -> Bool
isWs ch = (ch == 32) || (ch == 9)
http1Token :: Ap.Parser B.ByteString
http1Token = Ap.string "HTTP/1.1" <|> Ap.string "HTTP/1.0"
http1Method :: Ap.Parser B.ByteString
http1Method =
Ap.string "GET"
<|> Ap.string "POST"
<|> Ap.string "HEAD"
<|> Ap.string "PUT"
<|> Ap.string "OPTIONS"
<|> Ap.string "TRACE"
<|> Ap.string "CONNECT"
unspacedUri :: Ap.Parser B.ByteString
unspacedUri = Ap.takeWhile (not . isWs)
space :: Ap.Parser Word8
space = Ap.word8 32
requestLine :: Ap.Parser RequestOrResponseLine
requestLine =
flip Request_RoRL
<$>
http1Method
<* space
<*>
unspacedUri
<* space
<* http1Token
digit :: Ap.Parser Word8
digit = Ap.satisfy (Ap.inClass "0-9")
responseLine :: Ap.Parser RequestOrResponseLine
responseLine =
(pure Response_RoRL)
<*
http1Token
<*
space
<*>
( read . map (toEnum . fromIntegral ) <$> Ap.count 3 digit )
<*
space
<*
Ap.takeByteString
httpFirstLine :: Ap.Parser RequestOrResponseLine
httpFirstLine = requestLine <|> responseLine
-- A parser for chunked messages ....
chunkParser :: Ap.Parser B.ByteString
chunkParser = do
lng_bs <- Ap8.hexadecimal :: Ap.Parser Int
Ap.option () (
do
_ <- Ap.sepBy (Ap8.many1 $ Ap8.satisfy (Ap8.notInClass ";\r\n") ) (Ap8.char ';')
return ()
)
_ <- Ap8.char '\r'
_ <- Ap8.char '\n'
cnt <- Ap.take lng_bs
_ <- Ap8.char '\r'
_ <- Ap8.char '\n'
return cnt
wrapChunk :: B.ByteString -> Lb.ByteString
wrapChunk bs = let
lng = B.length bs
lng_str = showHex lng ""
a0 = Bu.byteString . pack $ lng_str
a1 = Bu.byteString bs
in Bu.toLazyByteString $ a0 `mappend` "\r\n" `mappend` a1 `mappend` "\r\n"
unwrapChunks :: Monad m => Conduit B.ByteString m B.ByteString
unwrapChunks =
do
input <- await
case input of
Nothing -> return ()
Just bs ->
let
parse_result = Ap.parse chunkParser bs
in onresult parse_result
where
onresult parse_result =
case parse_result of
Ap.Fail _ _ _ -> throw $ HTTP11SyntaxException "ChunkedParsingFailed"
Ap.Partial fn -> go fn
Ap.Done leftovers payload -> do
payload `seq` yield payload
if (B.length payload > 0)
then
restart leftovers
else
leftover leftovers
go fn = do
input <- await
case input of
Nothing -> throw $ HTTP11SyntaxException "ChunkedParsingLeftUnfinished"
Just bs ->
let
parse_result = fn bs
in onresult parse_result
restart leftovers =
let
parse_result = Ap.parse chunkParser leftovers
in onresult parse_result
-- This is a serialization function: it goes from content to string
-- It is not using during parse, but during the inverse process.
headerListToHTTP1ResponseText :: Headers -> Bu.Builder
headerListToHTTP1ResponseText headers =
case headers of
-- According to the specs, :status can be only
-- the first header
(hn,hv): rest | hn == ":status" ->
(
(first_line . read . unpack $ hv)
`mappend`
(go rest)
)
rest ->
(
(first_line 200)
`mappend`
(go rest)
)
where
go [] = mempty
go ((hn,hv):rest) =
(Bu.byteString hn) `mappend` ":" `mappend` " " `mappend` (Bu.byteString hv)
`mappend` "\r\n" `mappend` (go rest)
first_line :: Int -> Bu.Builder
first_line code = mconcat [
(Bu.byteString "HTTP/1.1"), " ",
(Bu.string7 . show $ code), " ",
(M.findWithDefault "OK" code httpStatusTable),
"\r\n"
]
-- | Converts a list of headers to a request head.
-- Invoke with the request data. Don't forget to clean the headers first.
-- NOTICE that this function doesn't add the \r\n extra-token for the empty
-- line at the end of headers.
headerListToHTTP1RequestText :: Headers -> Bu.Builder
headerListToHTTP1RequestText headers =
go1 Nothing Nothing mempty headers
where
go1 mb_method mb_local_uri assembled_body [] =
(fromMaybe "GET" mb_method) `mappend` " " `mappend` (fromMaybe "*" mb_local_uri) `mappend` " " `mappend` "HTTP/1.1" `mappend` "\r\n"
`mappend` assembled_body
go1 _ mb_local_uri assembled_body ((hn,hv): rest)
| hn == ":method" =
go1 (Just . Bu.byteString . validMethod $ hv) mb_local_uri assembled_body rest
go1 mb_method _mb_local_uri assembled_body ((hn,hv): rest)
| hn == ":path" =
go1 mb_method (Just . Bu.byteString . cleanupAbsoluteUri $ hv) assembled_body rest
-- Authority pseudo-header becomes a host header.
go1 mb_method _mb_local_uri assembled_body ((hn,hv): rest)
| hn == ":authority" =
go1 mb_method (Just . Bu.byteString . cleanupAbsoluteUri $ hv) (assembled_body `mappend` "host" `mappend` ":" `mappend` (Bu.byteString hv) `mappend` "\r\n") rest
go1 mb_method mb_local_uri assembled_body ((hn,hv):rest) -- Ignore any strange pseudo-headers
| He.headerIsPseudo hn = go1 mb_method mb_local_uri assembled_body rest
| otherwise = go1 mb_method mb_local_uri (assembled_body `mappend` (Bu.byteString hn) `mappend` ":" `mappend` (Bu.byteString hv) `mappend` "\r\n") rest
serializeHTTPResponse :: Headers -> [B.ByteString] -> Lb.ByteString
serializeHTTPResponse response_headers fragments =
let
-- So got some data in an answer. Now there are three ways to go about
-- the returned data: to force a chunked transfer-encoding, to read all
-- the data and add/set the Content-Length header, or to let the user
-- decide which one she prefers.
--
-- Right now I'm going for the second one, until somebody complains
-- This is equivalent to a lazy byte-string...but I just need the
-- length
-- I promised to minimize the number of interventions of the library,
-- so it could be a good idea to remove this one further down the
-- road.
h2 = E.lowercaseHeaders response_headers
data_size = foldl' (\ n bs -> n + B.length bs) 0 fragments
headers_editor = E.fromList h2
content_length_header_lens = E.headerLens "content-length"
he2 = L.set
content_length_header_lens
(Just (pack . show $ data_size))
headers_editor
h3 = E.toList he2
-- Next, I must serialize the headers....
headers_text_as_builder = headerListToHTTP1ResponseText h3
-- We dump the headers first... unfortunately when talking
-- HTTP/1.1 the most efficient way to write those bytes is
-- to create a big buffer and pass it on to OpenSSL.
-- However the Builder generating the headers above says
-- it generates fragments between 4k and 32 kb, I checked it
-- and it is true, so we can use it
-- Now we need to insert an extra \r\n, even it the response is
-- empty
-- And then we use the builder to re-format the fragments returned
-- by the coherent worker
-- TODO: This could be a good place to introduce chunked responses.
body_builder = mconcat $ map Bu.byteString fragments
in Bu.toLazyByteString $ headers_text_as_builder `mappend` "\r\n" `mappend`
body_builder
validMethod :: B.ByteString -> B.ByteString
validMethod mth | mth == "GET" = mth
| mth == "POST" = mth
| mth == "HEAD" = mth
| mth == "OPTIONS" = mth
| mth == "PUT" = mth
| mth == "DELETE" = mth
| mth == "TRACE" = mth
| otherwise = "GET"
methodHasRequestBody :: B.ByteString -> Bool
methodHasRequestBody mth | mth == "GET" = False
| mth == "POST" = True
| mth == "HEAD" = False
| mth == "OPTIONS" = False
| mth == "PUT" = True
| mth == "DELETE" = False
| mth == "TRACE" = False
| otherwise = False
-- These are most likely wrong TODO: fix
methodHasResponseBody :: B.ByteString -> Bool
methodHasResponseBody mth | mth == "GET" = True
| mth == "POST" = True
| mth == "HEAD" = False
| mth == "OPTIONS" = False
| mth == "PUT" = True
| mth == "DELETE" = False
| mth == "TRACE" = False
| otherwise = False
cleanupAbsoluteUri :: B.ByteString -> B.ByteString
-- Just trigger a 404 with an informative message (perhaps)
cleanupAbsoluteUri u
| B.length u == 0
= "/client-gives-invalid-uri/"
| B.head u /= 47
= "/client-gives-invalid-uri/"
| otherwise
=
let
str = unpack u
ok = U.isRelativeReference str
in if ok then u else "/client-gives-invalid-uri/"
httpStatusTable :: M.Map Int Bu.Builder
httpStatusTable = M.fromList
[
(100, "Continue"),
(101, "Switching Protocols"),
(200, "OK"),
(201, "Created"),
(202, "Accepted"),
(203, "Non-Authoritative Information"),
(204, "No Content"),
(205, "Reset Content"),
(206, "Partial Content"),
(300, "Multiple Choices"),
(301, "Moved Permanently"),
(302, "Found"),
(303, "See Other"),
(304, "Not Modified"),
(305, "Use Proxy"),
(307, "Temporary Redirect"),
(400, "Bad Request"),
(401, "Unauthorized"),
(402, "Payment Required"),
(403, "Forbidden"),
(404, "Not Found"),
(405, "Method Not Allowed"),
(406, "Not Acceptable"),
(407, "Proxy Authentication Required"),
(408, "Request Timeout"),
(409, "Conflict"),
(410, "Gone"),
(411, "Length Required"),
(412, "Precondition Failed"),
(413, "Request Entity Too Large"),
(414, "Request-URI Too Long"),
(415, "Unsupported Media Type"),
(416, "Requested Range Not Satisfiable"),
(417, "Expectation Failed"),
(500, "Internal Server Error"),
(501, "Not Implemented"),
(502, "Bad Gateway"),
(503, "Service Unavailable"),
(504, "Gateway Timeout"),
(505, "HTTP Version Not Supported")
]