+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Preprocess
- ( preprocess -- Interaction -> STM ()
+ ( AugmentedRequest(..)
+ , RequestBodyLength(..)
+ , preprocess
)
where
-
-import Control.Concurrent.STM
-import Control.Monad
-import Data.Char
-import Data.Maybe
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
-import Network.URI
-
-{-
-
- * Expect: に問題があった場合は 417 Expectation Failed に設定。
- 100-continue 以外のものは全部 417 に。
-
- * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
- 体的には、identity でも chunked でもなければ 501 Not Implemented に
- する。
-
- * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
- 場合には 400 Bad Request にする。
-
- * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
- Not Implemented にする。
-
- * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
- Version Not Supported を返す。
-
- * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
- 411 Length Required にする。
-
- * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
- Request にする。
-
- * willDiscardBody その他の變數を設定する。
-
--}
-
-import GHC.Conc (unsafeIOToSTM)
-
-preprocess :: Interaction -> STM ()
-preprocess itr
- = do let req = fromJust $ itrRequest itr
- reqVer = reqVersion req
-
- if reqVer /= HttpVersion 1 0 &&
- reqVer /= HttpVersion 1 1 then
-
- do setStatus itr HttpVersionNotSupported
- writeTVar (itrWillClose itr) True
-
- else
- do if reqVer == HttpVersion 1 0 then
- -- HTTP/1.0 では Keep-Alive できない
- writeTVar (itrWillClose itr) True
- else
- -- URI または Host: ヘッダのどちらかにホストが無ければ
- -- ならない。
- when (uriAuthority (reqURI req) == Nothing &&
- getHeader req "Host" == Nothing)
- $ setStatus itr BadRequest
-
- case reqMethod req of
- GET -> return ()
- HEAD -> writeTVar (itrWillDiscardBody itr) True
- POST -> ensureHavingBody itr
- PUT -> ensureHavingBody itr
- _ -> setStatus itr NotImplemented
-
- mapM_ (preprocessHeader itr) (reqHeaders req)
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State.Strict
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import qualified Data.ByteString.Char8 as C8
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.Socket
+import Network.URI
+import Prelude.Unicode
+
+data AugmentedRequest
+ = AugmentedRequest {
+ arRequest ∷ !Request
+ , arInitialStatus ∷ !SomeStatusCode
+ , arWillChunkBody ∷ !Bool
+ , arWillDiscardBody ∷ !Bool
+ , arWillClose ∷ !Bool
+ , arExpectedContinue ∷ !Bool
+ , arReqBodyLength ∷ !(Maybe RequestBodyLength)
+ }
+
+data RequestBodyLength
+ = Fixed !Int
+ | Chunked
+ deriving (Eq, Show)
+
+preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})
+ = execState go initialAR
where
- ensureHavingBody itr
- = let req = fromJust $ itrRequest itr
- in
- if getHeader req "Content-Length" == Nothing &&
- getHeader req "Transfer-Encoding" == Nothing then
-
- setStatus itr LengthRequired
- else
- writeTVar (itrRequestHasBody itr) True
-
- setStatus itr status
- = writeTVar (itrResponse itr) (Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- })
-
- preprocessHeader itr (name, value)
- = case map toLower name of
-
- "expect"
- -> if value `noCaseEq` "100-continue" then
- writeTVar (itrExpectedContinue itr) True
- else
- setStatus itr ExpectationFailed
-
- "transfer-encoding"
- -> case map toLower value of
- "identity" -> return ()
- "chunked" -> writeTVar (itrRequestIsChunked itr) True
- _ -> setStatus itr NotImplemented
-
- "content-length"
- -> if all isDigit value then
- writeTVar (itrRequestBodyLength itr) (Just $ read value)
- else
- setStatus itr BadRequest
-
- "connection"
- -> case map toLower value of
- "close" -> writeTVar (itrWillClose itr) True
- _ -> return ()
-
- _ -> return ()
\ No newline at end of file
+ initialAR ∷ AugmentedRequest
+ initialAR = AugmentedRequest {
+ arRequest = req
+ , arInitialStatus = fromStatusCode OK
+ , arWillChunkBody = False
+ , arWillDiscardBody = False
+ , arWillClose = False
+ , arExpectedContinue = False
+ , arReqBodyLength = Nothing
+ }
+ go ∷ State AugmentedRequest ()
+ go = do examineHttpVersion
+ examineMethod
+ examineAuthority localHost localPort
+ examineHeaders
+ examineBodyLength
+
+setRequest ∷ Request → State AugmentedRequest ()
+setRequest req
+ = modify $ \ar → ar { arRequest = req }
+
+setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
+setStatus sc
+ = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
+
+setWillClose ∷ Bool → State AugmentedRequest ()
+setWillClose b
+ = modify $ \ar → ar { arWillClose = b }
+
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength len
+ = modify $ \ar → ar { arReqBodyLength = len }
+
+examineHttpVersion ∷ State AugmentedRequest ()
+examineHttpVersion
+ = do req ← gets arRequest
+ case reqVersion req of
+ -- HTTP/1.0 requests can't Keep-Alive.
+ HttpVersion 1 0
+ → setWillClose True
+ HttpVersion 1 1
+ → modify $ \ar → ar { arWillChunkBody = True }
+ _ → do setStatus HTTPVersionNotSupported
+ setWillClose True
+
+examineMethod ∷ State AugmentedRequest ()
+examineMethod
+ = do req ← gets arRequest
+ case reqMethod req of
+ GET → return ()
+ HEAD → modify $ \ar → ar { arWillDiscardBody = True }
+ POST → return ()
+ PUT → return ()
+ DELETE → return ()
+ _ → setStatus NotImplemented
+
+examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
+examineAuthority localHost localPort
+ = do req ← gets arRequest
+ when (isNothing $ uriAuthority $ reqURI req) $
+ case reqVersion req of
+ -- HTTP/1.0 requests have no Host header so complete it
+ -- with the configuration value.
+ HttpVersion 1 0
+ → let host = localHost
+ port = case localPort of
+ 80 → ""
+ n → A.unsafeFromString $ ':':show n
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ -- HTTP/1.1 requests MUST have a Host header.
+ HttpVersion 1 1
+ → case getHeader "Host" req of
+ Just str
+ → let (host, port)
+ = parseHost str
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ Nothing
+ → setStatus BadRequest
+ -- Should never reach here...
+ ver → fail ("internal error: unknown version: " ⧺ show ver)
+
+parseHost ∷ Ascii → (CI Text, Ascii)
+parseHost hp
+ = let (h, p) = C8.break (≡ ':') $ cs hp
+ -- FIXME: should decode punycode here.
+ hText = CI.mk $ T.decodeUtf8 h
+ pAscii = A.unsafeFromByteString p
+ in
+ (hText, pAscii)
+
+updateAuthority ∷ CI Text → Ascii → Request → Request
+updateAuthority host port req
+ = let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack $ CI.original host
+ , uriPort = cs port
+ }
+ }
+ in
+ req { reqURI = uri' }
+
+examineHeaders ∷ State AugmentedRequest ()
+examineHeaders
+ = do req ← gets arRequest
+
+ case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "100-continue"
+ → modify $ \ar → ar { arExpectedContinue = True }
+ | otherwise
+ → setStatus ExpectationFailed
+
+ case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "identity"
+ → return ()
+ | v ≡ "chunked"
+ → setBodyLength $ Just Chunked
+ | otherwise
+ → setStatus NotImplemented
+
+ case cs <$> getHeader "Content-Length" req of
+ Nothing → return ()
+ Just value → case C8.readInt value of
+ Just (len, garbage)
+ | C8.null garbage ∧ len ≥ 0
+ → setBodyLength $ Just $ Fixed len
+ _ → setStatus BadRequest
+
+ case getCIHeader "Connection" req of
+ Just v
+ | v ≡ "close"
+ → setWillClose True
+ _ → return ()
+
+examineBodyLength ∷ State AugmentedRequest ()
+examineBodyLength
+ = do req ← gets arRequest
+ len ← gets arReqBodyLength
+ if reqMustHaveBody req then
+ -- POST and PUT requests must have an entity body.
+ when (isNothing len)
+ $ setStatus LengthRequired
+ else
+ -- Other requests must NOT have an entity body.
+ when (isJust len)
+ $ setStatus BadRequest
projects / Lucu.git / blobdiff