--- #hide
+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Preprocess
( 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
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as C8
+import Data.Char
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+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.URI
+import Prelude.Unicode
{-
+ TODO: Tanslate this memo into English. It doesn't make sense to
+ non-Japanese speakers.
+
+ * 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 にする。
Request にする。
* willDiscardBody その他の變數を設定する。
-
-}
-import GHC.Conc (unsafeIOToSTM)
+preprocess ∷ Interaction → STM ()
+preprocess itr@(Interaction {..})
+ = do req ← fromJust <$> readTVar itrRequest
-preprocess :: Interaction -> STM ()
-preprocess itr
- = do let req = fromJust $ itrRequest itr
- reqVer = reqVersion req
+ let reqVer = reqVersion req
- if reqVer /= HttpVersion 1 0 &&
- reqVer /= HttpVersion 1 1 then
+ if reqVer ≢ HttpVersion 1 0 ∧
+ reqVer ≢ HttpVersion 1 1 then
do setStatus itr 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
+ writeTVar itrWillClose True
+
+ else
+ -- HTTP/1.0 では Keep-Alive できない
+ do when (reqVer ≡ HttpVersion 1 0)
+ $ writeTVar itrWillClose True
+
+ -- ホスト部の補完
+ completeAuthority itr req
case reqMethod req of
- GET -> return ()
- HEAD -> writeItr itr itrWillDiscardBody True
- POST -> writeItr itr itrRequestHasBody True
- PUT -> writeItr itr itrRequestHasBody True
- _ -> setStatus itr NotImplemented
+ GET → return ()
+ HEAD → writeTVar itrWillDiscardBody True
+ POST → writeTVar itrRequestHasBody True
+ PUT → writeTVar itrRequestHasBody True
+ DELETE → return ()
+ _ → setStatus itr NotImplemented
- mapM_ (preprocessHeader itr) (reqHeaders req)
- where
- setStatus itr status
- = updateItr itr itrResponse
- $ \ res -> res {
- resStatus = status
- }
-
- 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
- do let len = read value
- writeItr itr itrReqChunkLength $ Just len
- writeItr itr itrReqChunkRemaining $ Just len
- else
- setStatus itr BadRequest
-
- "connection"
- -> case map toLower value of
- "close" -> writeItr itr itrWillClose True
- _ -> return ()
-
- _ -> return ()
\ No newline at end of file
+ preprocessHeader itr req
+
+setStatus ∷ Interaction → StatusCode → STM ()
+setStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar itrResponse res'
+
+completeAuthority ∷ Interaction → Request → STM ()
+completeAuthority itr@(Interaction {..}) req
+ = when (isNothing $ uriAuthority $ reqURI req)
+ $ if reqVersion req == HttpVersion 1 0 then
+ -- HTTP/1.0 なので Config から補完
+ do let host = cnfServerHost itrConfig
+ portStr = case itrLocalPort of
+ 80 → ""
+ n → ':' : show n
+ updateAuthority host $ A.unsafeFromString portStr
+ else
+ case getHeader "Host" req of
+ Just str → let (host, portStr) = parseHost str
+ in
+ updateAuthority host portStr
+ Nothing → setStatus itr BadRequest
+
+parseHost ∷ Ascii → (Text, Ascii)
+parseHost = C8.break (≡ ':')
+
+updateAuthority ∷ Text → Ascii → STM ()
+updateAuthority host portStr
+ = do Just req ← readTVar itrRequest
+ let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack host
+ , uriPort = A.toString portStr
+ }
+ }
+ req' = req { reqURI = uri' }
+ writeTVar itrRequest $ Just req'
+
+preprocessHeader ∷ Interaction → Request → STM ()
+preprocessHeader (Interaction {..}) req
+ = do case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just value → if value ≡ "100-continue" then
+ writeTVar itrExpectedContinue True
+ else
+ setStatus ExpectationFailed
+
+ case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just value → unless (value ≡ "identity")
+ $ if value ≡ "chunked" then
+ writeTVar itrRequestIsChunked True
+ else
+ setStatus NotImplemented
+
+ case getHeader "Content-Length" req of
+ Nothing → return ()
+ Just value → if C8.all isDigit value then
+ do let Just (len, _) = C8.readInt value
+ writeTVar itrReqChunkLength $ Just len
+ writeTVar itrReqChunkRemaining $ Just len
+ else
+ setStatus BadRequest
+
+ case getCIHeader "Connection" req of
+ Nothing → return ()
+ Just value → when (value ≡ "close")
+ $ writeTVar itrWillClose True
projects / Lucu.git / blobdiff