X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=96863f044dad4c803bdd42360e27d67cac5b8105;hp=af8c16917e154dd12e0661b671659a5c462b7b71;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index af8c169..96863f0 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -160,14 +160,14 @@ type Resource a = ReaderT Interaction IO a -- the httpd. getConfig :: Resource Config getConfig = do itr <- ask - return $ itrConfig itr + return $! itrConfig itr -- |Get the SockAddr of the remote host. If you want a string -- representation instead of SockAddr, use 'getRemoteAddr''. getRemoteAddr :: Resource SockAddr getRemoteAddr = do itr <- ask - return $ itrRemoteAddr itr + return $! itrRemoteAddr itr -- |Get the string representation of the address of remote host. If @@ -191,18 +191,18 @@ getRemoteAddr' = do addr <- getRemoteAddr -- the request header. In general you don't have to use this action. getRequest :: Resource Request getRequest = do itr <- ask - req <- liftIO $ atomically $ readItr itr itrRequest fromJust + req <- liftIO $! atomically $! readItr itr itrRequest fromJust return req -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. getMethod :: Resource Method getMethod = do req <- getRequest - return $ reqMethod req + return $! reqMethod req -- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest - return $ reqURI req + return $! reqURI req -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the @@ -228,7 +228,7 @@ getRequestURI = do req <- getRequest -- > } getResourcePath :: Resource [String] getResourcePath = do itr <- ask - return $ fromJust $ itrResourcePath itr + return $! fromJust $! itrResourcePath itr -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if @@ -244,22 +244,23 @@ getPathInfo = do rsrcPath <- getResourcePath -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 - return $ drop (length rsrcPath) reqPath + return $! drop (length rsrcPath) reqPath -- | Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it. This action -- doesn't parse the request body. See 'inputForm'. getQueryForm :: Resource [(String, String)] getQueryForm = do reqURI <- getRequestURI - return $ parseWWWFormURLEncoded $ uriQuery reqURI + return $! parseWWWFormURLEncoded $ uriQuery reqURI -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used -- so frequently: there should be actions like 'getContentType' for -- every common headers. getHeader :: String -> Resource (Maybe String) -getHeader name = do req <- getRequest - return $ H.getHeader name req +getHeader name = name `seq` + do req <- getRequest + return $! H.getHeader name req -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". @@ -303,11 +304,12 @@ getContentType = do cType <- getHeader "Content-Type" -- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity :: ETag -> ClockTime -> Resource () foundEntity tag timeStamp - = do driftTo ExaminingRequest + = tag `seq` timeStamp `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundEntity for POST request.") @@ -324,11 +326,12 @@ foundEntity tag timeStamp -- possible. foundETag :: ETag -> Resource () foundETag tag - = do driftTo ExaminingRequest + = tag `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "ETag" $ show tag + $ setHeader' "ETag" $! show tag when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundETag for POST request.") @@ -344,8 +347,8 @@ foundETag tag -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) $ abort PreconditionFailed [] - $ Just ("The entity tag doesn't match: " ++ list) - _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch) + $! Just ("The entity tag doesn't match: " ++ list) + _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified @@ -356,12 +359,12 @@ foundETag tag ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () - Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") + Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of (Success tags, _) -> when (any (== tag) tags) - $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) + $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list) + _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody @@ -377,11 +380,12 @@ foundETag tag -- possible. foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp - = do driftTo ExaminingRequest + = timeStamp `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") @@ -398,7 +402,7 @@ foundTimeStamp timeStamp Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] - $ Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -410,7 +414,7 @@ foundTimeStamp timeStamp Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] - $ Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -427,7 +431,8 @@ foundTimeStamp timeStamp -- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM - = do driftTo ExaminingRequest + = msgM `seq` + do driftTo ExaminingRequest method <- getMethod when (method /= PUT) @@ -459,7 +464,8 @@ foundNoEntity msgM -- Note that 'inputBS' is more efficient than 'input' so you should -- use it whenever possible. input :: Int -> Resource String -input limit = inputBS limit >>= return . B.unpack +input limit = limit `seq` + inputBS limit >>= return . B.unpack -- | This is mostly the same as 'input' but is more @@ -469,9 +475,10 @@ input limit = inputBS limit >>= return . B.unpack -- goes for 'inputChunkBS'. inputBS :: Int -> Resource ByteString inputBS limit - = do driftTo GettingBody + = limit `seq` + do driftTo GettingBody itr <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id + hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else @@ -481,7 +488,8 @@ inputBS limit where askForInput :: Interaction -> Resource ByteString askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr + = itr `seq` + do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit <= 0 then defaultLimit else @@ -489,40 +497,41 @@ inputBS limit when (actualLimit <= 0) $ fail ("inputBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $ atomically - $ do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit + liftIO $! atomically + $! do chunkLen <- readItr itr itrReqChunkLength id + writeItr itr itrWillReceiveBody True + if fmap (> actualLimit) chunkLen == Just True then + -- 受信前から多過ぎる事が分かってゐる + tooLarge actualLimit + else + writeItr itr itrReqBodyWanted $ Just actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically - $ do chunk <- readItr itr itrReceivedBody id - chunkIsOver <- readItr itr itrReqChunkIsOver id - if B.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘り - -- があるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したの - -- にまだ殘ってゐるなら、それは多過ぎ - -- る。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにす - -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody B.empty - return chunk + chunk <- liftIO $! atomically + $! do chunk <- readItr itr itrReceivedBody id + chunkIsOver <- readItr itr itrReqChunkIsOver id + if B.length chunk < fromIntegral actualLimit then + -- 要求された量に滿たなくて、まだ殘り + -- があるなら再試行。 + unless chunkIsOver + $ retry + else + -- 制限値一杯まで讀むやうに指示したの + -- にまだ殘ってゐるなら、それは多過ぎ + -- る。 + unless chunkIsOver + $ tooLarge actualLimit + -- 成功。itr 内にチャンクを置いたままにす + -- るとメモリの無駄になるので除去。 + writeItr itr itrReceivedBody B.empty + return chunk driftTo DecidingHeader return chunk tooLarge :: Int -> STM () - tooLarge lim = abortSTM RequestEntityTooLarge [] - $ Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") + tooLarge lim = lim `seq` + abortSTM RequestEntityTooLarge [] + $! Just ("Request body must be smaller than " + ++ show lim ++ " bytes.") -- | Computation of @'inputChunk' limit@ attempts to read a part of -- request body up to @limit@ bytes. You can read any large request by @@ -538,14 +547,16 @@ inputBS limit -- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. inputChunk :: Int -> Resource String -inputChunk limit = inputChunkBS limit >>= return . B.unpack +inputChunk limit = limit `seq` + inputChunkBS limit >>= return . B.unpack -- | This is mostly the same as 'inputChunk' but is more -- efficient. See 'inputBS'. inputChunkBS :: Int -> Resource ByteString inputChunkBS limit - = do driftTo GettingBody + = limit `seq` + do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then @@ -557,7 +568,8 @@ inputChunkBS limit where askForInput :: Interaction -> Resource ByteString askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr + = itr `seq` + do let defaultLimit = cnfMaxEntityLength $! itrConfig itr actualLimit = if limit < 0 then defaultLimit else @@ -565,11 +577,11 @@ inputChunkBS limit when (actualLimit <= 0) $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $ atomically - $ do writeItr itr itrReqBodyWanted $ Just actualLimit - writeItr itr itrWillReceiveBody True + liftIO $! atomically + $! do writeItr itr itrReqBodyWanted $! Just actualLimit + writeItr itr itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically + chunk <- liftIO $! atomically $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 @@ -596,7 +608,8 @@ inputChunkBS limit -- it is not (yet) done. inputForm :: Int -> Resource [(String, String)] inputForm limit - = do cTypeM <- getContentType + = limit `seq` + do cTypeM <- getContentType case cTypeM of Nothing -> abort BadRequest [] (Just "Missing Content-Type") @@ -605,7 +618,7 @@ inputForm limit Just (MIMEType "multipart" "form-data" _) -> readMultipartFormData Just cType - -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " + -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " ++ show cType) where readWWWFormURLEncoded @@ -614,7 +627,7 @@ inputForm limit readMultipartFormData -- FIXME: 未對應 = abort UnsupportedMediaType [] - (Just $ "Sorry, inputForm does not currently support multipart/form-data.") + (Just $! "Sorry, inputForm does not currently support multipart/form-data.") -- | This is just a constant -1. It's better to say @'input' -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly @@ -630,12 +643,13 @@ defaultLimit = (-1) -- the status code will be defaulted to \"200 OK\". setStatus :: StatusCode -> Resource () setStatus code - = do driftTo DecidingHeader + = code `seq` + do driftTo DecidingHeader itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ res -> res { - resStatus = code - } + liftIO $! atomically $! updateItr itr itrResponse + $! \ res -> res { + resStatus = code + } -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -653,12 +667,14 @@ setStatus code -- a part of header of the next response. setHeader :: String -> String -> Resource () setHeader name value - = driftTo DecidingHeader >> setHeader' name value + = name `seq` value `seq` + driftTo DecidingHeader >> setHeader' name value -setHeader' :: String -> String -> Resource() +setHeader' :: String -> String -> Resource () setHeader' name value - = do itr <- ask + = name `seq` value `seq` + do itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ H.setHeader name value @@ -668,17 +684,20 @@ setHeader' name value -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. redirect :: StatusCode -> URI -> Resource () redirect code uri - = do when (code == NotModified || not (isRedirection code)) + = code `seq` uri `seq` + do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] - $ Just ("Attempted to redirect with status " ++ show code) + $! Just ("Attempted to redirect with status " ++ show code) setStatus code setLocation uri +{-# INLINE redirect #-} + -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType :: MIMEType -> Resource () setContentType mType - = setHeader "Content-Type" $ show mType + = setHeader "Content-Type" $! show mType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -697,12 +716,14 @@ setLocation uri -- Note that 'outputBS' is more efficient than 'output' so you should -- use it whenever possible. output :: String -> Resource () -output = outputBS . B.pack +output str = outputBS $! B.pack str +{-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done +{-# INLINE outputBS #-} -- | Computation of @'outputChunk' str@ writes @str@ as a part of -- response body. You can compute this action multiple times to write @@ -712,12 +733,14 @@ outputBS str = do outputChunkBS str -- Note that 'outputChunkBS' is more efficient than 'outputChunk' so -- you should use it whenever possible. outputChunk :: String -> Resource () -outputChunk = outputChunkBS . B.pack +outputChunk str = outputChunkBS $! B.pack str +{-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. outputChunkBS :: ByteString -> Resource () outputChunkBS str - = do driftTo DecidingBody + = str `seq` + do driftTo DecidingBody itr <- ask let limit = cnfMaxOutputChunkLength $ itrConfig itr @@ -778,7 +801,8 @@ outputChunkBS str driftTo :: InteractionState -> Resource () driftTo newState - = do itr <- ask + = newState `seq` + do itr <- ask liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState