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