+{-# LANGUAGE
+ BangPatterns
+ #-}
module Network.HTTP.Lucu.Preprocess
- ( preprocess -- Interaction -> STM ()
+ ( preprocess
)
where
import Control.Concurrent.STM
import Control.Monad
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Char
import Data.Maybe
+import Network.HTTP.Lucu.Config
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
{-
+ * URI にホスト名が存在しない時、
+ [1] HTTP/1.0 ならば Config を使って補完
+ [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
+
* Expect: に問題があった場合は 417 Expectation Failed に設定。
100-continue 以外のものは全部 417 に。
体的には、identity でも chunked でもなければ 501 Not Implemented に
する。
- * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
- 場合には 400 Bad Request にする。
-
* メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
Not Implemented にする。
-}
-import GHC.Conc (unsafeIOToSTM)
-
preprocess :: Interaction -> STM ()
-preprocess itr
- = do let req = fromJust $ itrRequest itr
- reqVer = reqVersion req
+preprocess !itr
+ = do req <- readItr itr itrRequest fromJust
+
+ let reqVer = reqVersion req
if reqVer /= HttpVersion 1 0 &&
reqVer /= HttpVersion 1 1 then
- do setStatus itr HttpVersionNotSupported
+ do setStatus HttpVersionNotSupported
writeItr itr itrWillClose True
else
- do if reqVer == HttpVersion 1 0 then
- -- HTTP/1.0 では Keep-Alive できない
- writeItr itr itrWillClose True
- else
- -- URI または Host: ヘッダのどちらかにホストが無ければ
- -- ならない。
- when (uriAuthority (reqURI req) == Nothing &&
- getHeader "Host" req == Nothing)
- $ setStatus itr BadRequest
+ -- HTTP/1.0 では Keep-Alive できない
+ do when (reqVer == HttpVersion 1 0)
+ $ writeItr itr itrWillClose True
+
+ -- ホスト部の補完
+ completeAuthority req
case reqMethod req of
- GET -> return ()
- HEAD -> writeItr itr itrWillDiscardBody True
- POST -> ensureHavingBody itr
- PUT -> ensureHavingBody itr
- _ -> setStatus itr NotImplemented
+ GET -> return ()
+ HEAD -> writeItr itr itrWillDiscardBody True
+ POST -> writeItr itr itrRequestHasBody True
+ PUT -> writeItr itr itrRequestHasBody True
+ DELETE -> return ()
+ _ -> setStatus NotImplemented
- mapM_ (preprocessHeader itr) (reqHeaders req)
+ preprocessHeader req
where
- ensureHavingBody itr
- = let req = fromJust $ itrRequest itr
- in
- if getHeader "Content-Length" req == Nothing &&
- getHeader "Transfer-Encoding" req == Nothing then
-
- setStatus itr LengthRequired
+ setStatus :: StatusCode -> STM ()
+ setStatus !status
+ = updateItr itr itrResponse
+ $! \ res -> res {
+ resStatus = status
+ }
+
+ completeAuthority :: Request -> STM ()
+ completeAuthority !req
+ = when (uriAuthority (reqURI req) == Nothing)
+ $ if reqVersion req == HttpVersion 1 0 then
+ -- HTTP/1.0 なので Config から補完
+ do let conf = itrConfig itr
+ host = cnfServerHost conf
+ port = itrLocalPort itr
+ portStr
+ = case port of
+ 80 -> ""
+ n -> ':' : show n
+ updateAuthority host (C8.pack portStr)
else
- writeItr itr itrRequestHasBody True
-
- setStatus itr status
- = writeItr itr itrResponse $ 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
- writeItr itr itrExpectedContinue True
- else
- setStatus itr ExpectationFailed
-
- "transfer-encoding"
- -> case map toLower value of
- "identity" -> return ()
- "chunked" -> writeItr itr itrRequestIsChunked True
- _ -> setStatus itr NotImplemented
-
- "content-length"
- -> if all isDigit value then
- writeItr itr itrRequestBodyLength $ Just $ read value
- else
- setStatus itr BadRequest
-
- "connection"
- -> case map toLower value of
- "close" -> writeItr itr itrWillClose True
- _ -> return ()
-
- _ -> return ()
\ No newline at end of file
+ case getHeader (C8.pack "Host") req of
+ Just str -> let (host, portStr) = parseHost str
+ in updateAuthority host portStr
+ Nothing -> setStatus BadRequest
+
+
+ parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
+ parseHost = C8.break (== ':')
+
+
+ updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
+ updateAuthority !host !portStr
+ = updateItr itr itrRequest
+ $! \ (Just req) -> Just req {
+ reqURI = let uri = reqURI req
+ in uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = C8.unpack host
+ , uriPort = C8.unpack portStr
+ }
+ }
+ }
+
+
+ preprocessHeader :: Request -> STM ()
+ preprocessHeader !req
+ = do case getHeader (C8.pack "Expect") req of
+ Nothing -> return ()
+ Just value -> if value `noCaseEq` C8.pack "100-continue" then
+ writeItr itr itrExpectedContinue True
+ else
+ setStatus ExpectationFailed
+
+ case getHeader (C8.pack "Transfer-Encoding") req of
+ Nothing -> return ()
+ Just value -> unless (value `noCaseEq` C8.pack "identity")
+ $ if value `noCaseEq` C8.pack "chunked" then
+ writeItr itr itrRequestIsChunked True
+ else
+ setStatus NotImplemented
+
+ case getHeader (C8.pack "Content-Length") req of
+ Nothing -> return ()
+ Just value -> if C8.all isDigit value then
+ do let Just (len, _) = C8.readInt value
+ writeItr itr itrReqChunkLength $ Just len
+ writeItr itr itrReqChunkRemaining $ Just len
+ else
+ setStatus BadRequest
+
+ case getHeader (C8.pack "Connection") req of
+ Nothing -> return ()
+ Just value -> when (value `noCaseEq` C8.pack "close")
+ $ writeItr itr itrWillClose True
projects / Lucu.git / blobdiff