X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9321b6bc78e4570b0745334e9994866fcf0185f2;hb=2bb7a0b;hp=37b1a75ad997dbc7cfe14cf5fca0b91c5b4b287b;hpb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;p=Lucu.git diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 37b1a75..9321b6b 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,23 +1,36 @@ +{-# 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.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 -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 を使って補完 @@ -43,125 +56,107 @@ import Network.URI Request にする。 * willDiscardBody その他の變數を設定する。 - -} -preprocess :: Interaction -> STM () -preprocess itr - = itr `seq` - do req <- readItr itr itrRequest fromJust +preprocess ∷ Interaction → STM () +preprocess itr@(Interaction {..}) + = do req ← fromJust <$> readTVar itrRequest 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 HttpVersionNotSupported - writeItr itr itrWillClose True + do setStatus itr HttpVersionNotSupported + writeTVar itrWillClose True - else + else -- HTTP/1.0 では Keep-Alive できない - do when (reqVer == HttpVersion 1 0) - $ writeItr itr itrWillClose True + do when (reqVer ≡ HttpVersion 1 0) + $ writeTVar itrWillClose True -- ホスト部の補完 - completeAuthority req + 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 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 :: StatusCode -> STM () - setStatus status - = status `seq` - updateItr itr itrResponse - $! \ res -> res { - resStatus = status - } - - completeAuthority :: Request -> STM () - completeAuthority req - = req `seq` - 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 = case cnfServerPort conf of - PortNumber n -> Just $ fromIntegral n - _ -> Nothing - portStr - = case port of - Just 80 -> Just "" - Just n -> Just $ ":" ++ show n - Nothing -> Nothing - case portStr of - Just str -> updateAuthority host str - -- FIXME: このエラーの原因は、listen してゐるソ - -- ケットが INET でない故にポート番號が分からな - -- い事だが、その事をどうにかして通知した方が良 - -- いと思ふ。stderr？ - Nothing -> setStatus InternalServerError - else - do case getHeader "Host" req of - Just str -> let (host, portStr) = parseHost str - in updateAuthority host portStr - Nothing -> setStatus BadRequest - - - parseHost :: String -> (String, String) - parseHost = break (== ':') - - - updateAuthority :: String -> String -> STM () - updateAuthority host portStr - = host `seq` portStr `seq` - updateItr itr itrRequest - $! \ (Just req) -> Just req { - reqURI = let uri = reqURI req - in uri { - uriAuthority = Just URIAuth { - uriUserInfo = "" - , uriRegName = host - , uriPort = portStr - } - } - } - - - preprocessHeader :: Interaction -> (String, String) -> STM () - preprocessHeader itr (name, value) - = itr `seq` name `seq` value `seq` - case map toLower name of - - "expect" - -> if value `noCaseEq'` "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus ExpectationFailed - - "transfer-encoding" - -> case map toLower value of - "identity" -> return () - "chunked" -> writeItr itr itrRequestIsChunked True - _ -> setStatus 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 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