--- #hide
module Network.HTTP.Lucu.Preprocess
( preprocess
)
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.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
import Network
import Network.URI
-}
-import GHC.Conc (unsafeIOToSTM)
-
preprocess :: Interaction -> STM ()
preprocess itr
- = do req <- readItr itr itrRequest fromJust
+ = itr `seq`
+ do req <- readItr itr itrRequest fromJust
let reqVer = reqVersion req
PUT -> writeItr itr itrRequestHasBody True
_ -> setStatus NotImplemented
- mapM_ (preprocessHeader itr) (reqHeaders req)
+ preprocessHeader req
where
setStatus :: StatusCode -> STM ()
setStatus status
- = updateItr itr itrResponse
- $ \ res -> res {
- resStatus = status
- }
+ = status `seq`
+ updateItr itr itrResponse
+ $! \ res -> res {
+ resStatus = status
+ }
completeAuthority :: Request -> STM ()
completeAuthority req
- = when (uriAuthority (reqURI req) == Nothing)
+ = 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
+ PortNumber n -> Just (fromIntegral n :: Int)
_ -> Nothing
portStr
= case port of
Just n -> Just $ ":" ++ show n
Nothing -> Nothing
case portStr of
- Just str -> updateAuthority host str
+ Just str -> updateAuthority host (C8.pack str)
-- FIXME: このエラーの原因は、listen してゐるソ
-- ケットが INET でない故にポート番號が分からな
-- い事だが、その事をどうにかして通知した方が良
-- いと思ふ。stderr?
Nothing -> setStatus InternalServerError
else
- do case getHeader "Host" req of
+ do case getHeader (C8.pack "Host") req of
Just str -> let (host, portStr) = parseHost str
in updateAuthority host portStr
Nothing -> setStatus BadRequest
- parseHost :: String -> (String, String)
- parseHost = break (== ':')
+ parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
+ parseHost = C8.break (== ':')
- updateAuthority :: String -> String -> STM ()
+ 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 = host
- , uriPort = portStr
- }
- }
- }
+ = host `seq` portStr `seq`
+ 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 itr (name, value)
- = 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 :: Request -> STM ()
+ preprocessHeader req
+ = req `seq`
+ 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 -> if value `noCaseEq` C8.pack "identity" then
+ return ()
+ else
+ 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 -> if value `noCaseEq` C8.pack "close" then
+ writeItr itr itrWillClose True
+ else
+ return ()