From: pho Date: Mon, 9 Jul 2007 02:09:29 +0000 (+0900) Subject: Optimized as possible as I can. X-Git-Tag: RELEASE-0_2_1~39 X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=858129cb755aa09da2b7bd758efb8519f2c89103 Optimized as possible as I can. darcs-hash:20070709020929-62b54-3e501a08725ab5b261a642884edbc00a68be2670.gz --- diff --git a/.boring b/.boring index 93f3d7a..3d85b5e 100644 --- a/.boring +++ b/.boring @@ -51,3 +51,5 @@ ^dist($|/) ^run\.sh$ ^Setup$ +^\.setup-config$ +^.installed-pkg-config$ diff --git a/Lucu.cabal b/Lucu.cabal index d2b3168..e7be5c7 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -15,7 +15,7 @@ Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/lucu/ Category: Network -Tested-With: GHC == 6.6 +Tested-With: GHC == 6.6.1 Build-Depends: base, mtl, network, stm, hxt, haskell-src, unix Exposed-Modules: @@ -25,6 +25,7 @@ Exposed-Modules: Network.HTTP.Lucu.Config Network.HTTP.Lucu.DefaultPage Network.HTTP.Lucu.ETag + Network.HTTP.Lucu.Format Network.HTTP.Lucu.Headers Network.HTTP.Lucu.HttpVersion Network.HTTP.Lucu.Httpd @@ -50,7 +51,7 @@ Extra-Source-Files: data/mime.types examples/HelloWorld.hs examples/Makefile -ghc-options: -fglasgow-exts -O3 +ghc-options: -fglasgow-exts -fwarn-missing-signatures -funbox-strict-fields -O3 --Executable: HelloWorld --Main-Is: HelloWorld.hs diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 0a42d71..4313df3 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -24,6 +24,7 @@ import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import {-# SOURCE #-} Network.HTTP.Lucu.Resource import System.IO.Unsafe import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow @@ -32,9 +33,9 @@ import Text.XML.HXT.DOM.XmlKeywords data Abortion = Abortion { - aboStatus :: StatusCode - , aboHeaders :: Headers - , aboMessage :: Maybe String + aboStatus :: !StatusCode + , aboHeaders :: !Headers + , aboMessage :: !(Maybe String) } deriving (Show, Typeable) -- | Computation of @'abort' status headers msg@ aborts the @@ -62,30 +63,34 @@ data Abortion = Abortion { -- > (Just "It has been moved to example.net") abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a abort status headers msg - = let abo = Abortion status headers msg + = status `seq` headers `seq` msg `seq` + let abo = Abortion status headers msg exc = DynException (toDyn abo) in liftIO $ throwIO exc +{-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-} -- | Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a STM monad. abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a abortSTM status headers msg - = unsafeIOToSTM $ abort status headers msg + = status `seq` headers `seq` msg `seq` + unsafeIOToSTM $! abort status headers msg -- | Computation of @'abortA' -< (status, (headers, msg))@ just -- computes 'abort' in an ArrowIO. abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c abortA = arrIO3 abort - +{-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-} -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String abortPage conf reqM res abo - = case aboMessage abo of + = conf `seq` reqM `seq` res `seq` abo `seq` + case aboMessage abo of Just msg -> let [html] = unsafePerformIO $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg) diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index 44f2ae4..9ad41f8 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -26,6 +26,7 @@ chunkHeaderP = do hexLen <- many1 hexDigit char '=' token <|> quotedStr return () +{-# SPECIALIZE chunkHeaderP :: Parser Int #-} chunkFooterP :: Parser () diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 17bf022..49622b2 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -18,31 +18,31 @@ import System.IO.Unsafe -- 'defaultConfig' or setup your own configuration to run the httpd. data Config = Config { -- |A string which will be sent to clients as \"Server\" field. - cnfServerSoftware :: String + cnfServerSoftware :: !String -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: HostName + , cnfServerHost :: !HostName -- |A port ID to listen to HTTP clients. - , cnfServerPort :: PortID + , cnfServerPort :: !PortID -- |The maximum number of requests to accept in one connection -- simultaneously. If a client exceeds this limitation, its last -- request won't be processed until a response for its earliest -- pending request is sent back to the client. - , cnfMaxPipelineDepth :: Int + , cnfMaxPipelineDepth :: !Int -- |The maximum length of request entity to accept in bytes. Note -- that this is nothing but the default value which is used when -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no -- guarantee that this value always constrains all the requests. - , cnfMaxEntityLength :: Int + , cnfMaxEntityLength :: !Int -- |The maximum length of chunk to output. This value is used by -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the -- chunk length so you can safely output an infinite string (like -- a lazy stream of \/dev\/random) using those actions. - , cnfMaxOutputChunkLength :: Int + , cnfMaxOutputChunkLength :: !Int -- | Whether to dump too late abortion to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. - , cnfDumpTooLateAbortionToStderr :: Bool + , cnfDumpTooLateAbortionToStderr :: !Bool -- |A mapping from extension to MIME Type. This value is used by -- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME -- Type of static files. Note that MIME Types are currently @@ -54,7 +54,7 @@ data Config = Config { -- a good idea to use GnomeVFS -- () -- instead of vanilla FS. - , cnfExtToMIMEType :: ExtMap + , cnfExtToMIMEType :: !ExtMap } -- |The default configuration. Generally you can use this value as-is, diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index bb4ba28..a79e47b 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -15,13 +15,13 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe import Network import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.URI import System.IO.Unsafe -import Text.Printf import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlIOStateArrow @@ -31,7 +31,8 @@ import Text.XML.HXT.DOM.XmlKeywords getDefaultPage :: Config -> Maybe Request -> Response -> String getDefaultPage conf req res - = let msgA = getMsg req res + = conf `seq` req `seq` res `seq` + let msgA = getMsg req res in unsafePerformIO $ do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA @@ -43,7 +44,8 @@ getDefaultPage conf req res writeDefaultPage :: Interaction -> STM () writeDefaultPage itr - = do wroteHeader <- readTVar (itrWroteHeader itr) + = itr `seq` + do wroteHeader <- readTVar (itrWroteHeader itr) -- Content-Type が正しくなければ補完できない。 res <- readItr itr itrResponse id @@ -59,7 +61,8 @@ writeDefaultPage itr mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree mkDefaultPage conf status msgA - = let (sCode, sMsg) = statusCode status + = conf `seq` status `seq` msgA `seq` + let (sCode, sMsg) = statusCode status sig = cnfServerSoftware conf ++ " at " ++ cnfServerHost conf @@ -73,7 +76,7 @@ mkDefaultPage conf status msgA += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (printf "%03d %s" sCode sMsg) + += txt (fmtDec 3 sCode ++ " " ++ sMsg) )) += ( eelem "body" += ( eelem "h1" @@ -82,17 +85,18 @@ mkDefaultPage conf status msgA += ( eelem "p" += msgA ) += eelem "hr" += ( eelem "address" += txt sig )))) - +{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree getMsg req res - = case resStatus res of + = req `seq` res `seq` + case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない -- 3xx MovedPermanently - -> txt (printf "The resource at %s has been moved to " path) + -> txt ("The resource at " ++ path ++ " has been moved to ") <+> eelem "a" += sattr "href" loc += txt loc @@ -100,7 +104,7 @@ getMsg req res txt " permanently." Found - -> txt (printf "The resource at %s is currently located at " path) + -> txt ("The resource at " ++ path ++ " is currently located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -108,7 +112,7 @@ getMsg req res txt ". This is not a permanent relocation." SeeOther - -> txt (printf "The resource at %s can be found at " path) + -> txt ("The resource at " ++ path ++ " can be found at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -116,7 +120,7 @@ getMsg req res txt "." TemporaryRedirect - -> txt (printf "The resource at %s is temporarily located at " path) + -> txt ("The resource at " ++ path ++ " is temporarily located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -128,26 +132,26 @@ getMsg req res -> txt "The server could not understand the request you sent." Unauthorized - -> txt (printf "You need a valid authentication to access %s" path) + -> txt ("You need a valid authentication to access " ++ path) Forbidden - -> txt (printf "You don't have permission to access %s" path) + -> txt ("You don't have permission to access " ++ path) NotFound - -> txt (printf "The requested URL %s was not found on this server." path) + -> txt ("The requested URL " ++ path ++ " was not found on this server.") Gone - -> txt (printf "The resource at %s was here in past times, but has gone permanently." path) + -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.") RequestEntityTooLarge - -> txt (printf "The request entity you sent for %s was too big to accept." path) + -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.") RequestURITooLarge -> txt "The request URI you sent was too big to accept." -- 5xx InternalServerError - -> txt (printf "An internal server error has occured during the process of your request to %s" path) + -> txt ("An internal server error has occured during the process of your request to " ++ path) ServiceUnavailable -> txt "The service is temporarily unavailable. Try later." @@ -157,9 +161,11 @@ getMsg req res where path :: String - path = let uri = reqURI $ fromJust req + path = let uri = reqURI $! fromJust req in uriPath uri loc :: String - loc = fromJust $ getHeader "Location" res + loc = fromJust $! getHeader "Location" res + +{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index cbbe461..c75394f 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -19,10 +19,10 @@ import Network.HTTP.Lucu.Utils data ETag = ETag { -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and -- strong tags are like \"blahblah\". - etagIsWeak :: Bool + etagIsWeak :: !Bool -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~) -- are allowed. - , etagToken :: String + , etagToken :: !String } deriving (Eq) instance Show ETag where @@ -52,7 +52,7 @@ eTagP = do isWeak <- option False (string "W/" >> return True) eTagListP :: Parser [ETag] eTagListP = allowEOF - $ do xs <- listOf eTagP - when (null xs) - $ fail "" - return xs + $! do xs <- listOf eTagP + when (null xs) + $ fail "" + return xs diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs new file mode 100644 index 0000000..26319b7 --- /dev/null +++ b/Network/HTTP/Lucu/Format.hs @@ -0,0 +1,128 @@ +-- #hide + +-- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの +-- で駄目だが、それ以外のモジュールを探しても見付からなかった。 + +module Network.HTTP.Lucu.Format + ( fmtInt + + , fmtDec + , fmtHex + ) + where + + +fmtInt :: Int -> Bool -> Int -> Char -> Bool -> Int -> String +fmtInt base upperCase minWidth pad forceSign n + = base `seq` minWidth `seq` pad `seq` forceSign `seq` n `seq` + let raw = reverse $! fmt' (abs n) + sign = if forceSign || n < 0 then + if n < 0 then "-" else "+" + else + "" + padded = padStr (minWidth - length sign) pad raw + in + sign ++ padded + where + fmt' :: Int -> String + fmt' n + | n < base = (intToChar upperCase n) : [] + | otherwise = (intToChar upperCase $! n `mod` base) : fmt' (n `div` base) + + +fmtDec :: Int -> Int -> String +fmtDec minWidth n + | minWidth == 2 = fmtDec2 n -- optimization + | minWidth == 3 = fmtDec3 n -- optimization + | minWidth == 4 = fmtDec4 n -- optimization + | otherwise = fmtInt 10 undefined minWidth '0' False n +{-# INLINE fmtDec #-} + + +fmtDec2 :: Int -> String +fmtDec2 n + | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback + | n < 10 = '0' + : intToChar undefined n + : [] + | otherwise = intToChar undefined (n `div` 10) + : intToChar undefined (n `mod` 10) + : [] + + +fmtDec3 :: Int -> String +fmtDec3 n + | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback + | n < 10 = '0' : '0' + : intToChar undefined n + : [] + | n < 100 = '0' + : intToChar undefined ((n `div` 10) `mod` 10) + : intToChar undefined ( n `mod` 10) + : [] + | otherwise = intToChar undefined ((n `div` 100) `mod` 10) + : intToChar undefined ((n `div` 10) `mod` 10) + : intToChar undefined ( n `mod` 10) + : [] + + +fmtDec4 :: Int -> String +fmtDec4 n + | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback + | n < 10 = '0' : '0' : '0' + : intToChar undefined n + : [] + | n < 100 = '0' : '0' + : intToChar undefined ((n `div` 10) `mod` 10) + : intToChar undefined ( n `mod` 10) + : [] + | n < 1000 = '0' + : intToChar undefined ((n `div` 100) `mod` 10) + : intToChar undefined ((n `div` 10) `mod` 10) + : intToChar undefined ( n `mod` 10) + : [] + | otherwise = intToChar undefined ((n `div` 1000) `mod` 10) + : intToChar undefined ((n `div` 100) `mod` 10) + : intToChar undefined ((n `div` 10) `mod` 10) + : intToChar undefined ( n `mod` 10) + : [] + + +fmtHex :: Bool -> Int -> Int -> String +fmtHex upperCase minWidth + = fmtInt 16 upperCase minWidth '0' False + + +padStr :: Int -> Char -> String -> String +padStr minWidth pad str + = let delta = minWidth - length str + in + if delta > 0 then + replicate delta pad ++ str + else + str + + +intToChar :: Bool -> Int -> Char +intToChar _ 0 = '0' +intToChar _ 1 = '1' +intToChar _ 2 = '2' +intToChar _ 3 = '3' +intToChar _ 4 = '4' +intToChar _ 5 = '5' +intToChar _ 6 = '6' +intToChar _ 7 = '7' +intToChar _ 8 = '8' +intToChar _ 9 = '9' +intToChar False 10 = 'a' +intToChar True 10 = 'A' +intToChar False 11 = 'b' +intToChar True 11 = 'B' +intToChar False 12 = 'c' +intToChar True 12 = 'C' +intToChar False 13 = 'd' +intToChar True 13 = 'D' +intToChar False 14 = 'e' +intToChar True 14 = 'E' +intToChar False 15 = 'f' +intToChar True 15 = 'F' \ No newline at end of file diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index fee6fad..a580883 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -23,20 +23,24 @@ class HasHeaders a where getHeader :: String -> a -> Maybe String getHeader key a - = fmap snd $ find (noCaseEq key . fst) (getHeaders a) + = key `seq` a `seq` + fmap snd $ find (noCaseEq' key . fst) (getHeaders a) deleteHeader :: String -> a -> a deleteHeader key a - = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a) + = key `seq` a `seq` + setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a) addHeader :: String -> String -> a -> a addHeader key val a - = setHeaders a $ (getHeaders a) ++ [(key, val)] + = key `seq` val `seq` a `seq` + setHeaders a $ (getHeaders a) ++ [(key, val)] setHeader :: String -> String -> a -> a setHeader key val a - = let list = getHeaders a - deleted = filter (not . noCaseEq key . fst) list + = key `seq` val `seq` a `seq` + let list = getHeaders a + deleted = filter (not . noCaseEq' key . fst) list added = deleted ++ [(key, val)] in setHeaders a added @@ -90,9 +94,14 @@ headersP = do xs <- many header hPutHeaders :: Handle -> Headers -> IO () -hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n" +hPutHeaders h hds + = h `seq` hds `seq` + mapM_ putH hds >> hPutStr h "\r\n" where - putH (name, value) = do hPutStr h name - hPutStr h ": " - hPutStr h value - hPutStr h "\r\n" + putH :: (String, String) -> IO () + putH (name, value) + = name `seq` value `seq` + do hPutStr h name + hPutStr h ": " + hPutStr h value + hPutStr h "\r\n" diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 38d0e5b..15ead36 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -14,7 +14,7 @@ import Network.HTTP.Lucu.Parser import System.IO -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\". -data HttpVersion = HttpVersion Int Int +data HttpVersion = HttpVersion !Int !Int deriving (Eq) instance Show HttpVersion where @@ -39,7 +39,8 @@ httpVersionP = do string "HTTP/" hPutHttpVersion :: Handle -> HttpVersion -> IO () hPutHttpVersion h (HttpVersion maj min) - = do hPutStr h "HTTP/" + = h `seq` + do hPutStr h "HTTP/" hPutStr h (show maj) hPutChar h '.' hPutStr h (show min) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index b8e1845..2b81de1 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -49,7 +49,8 @@ import System.Posix.Signals -- > } runHttpd :: Config -> ResTree -> IO () runHttpd cnf tree - = withSocketsDo $ + = cnf `seq` tree `seq` + withSocketsDo $ do installHandler sigPIPE Ignore Nothing so <- listenOn (cnfServerPort cnf) loop so @@ -58,7 +59,8 @@ runHttpd cnf tree loop so -- 本當は Network.accept を使ひたいが、このアクションは勝手に -- リモートのIPを逆引きするので、使へない。 - = do (h, addr) <- accept' so + = so `seq` + do (h, addr) <- accept' so tQueue <- newInteractionQueue readerTID <- forkIO $ requestReader cnf tree h addr tQueue writerTID <- forkIO $ responseWriter cnf h tQueue readerTID @@ -66,6 +68,7 @@ runHttpd cnf tree accept' :: Socket -> IO (Handle, So.SockAddr) accept' soSelf - = do (soPeer, addr) <- So.accept soSelf + = soSelf `seq` + do (soPeer, addr) <- So.accept soSelf hPeer <- So.socketToHandle soPeer ReadWriteMode return (hPeer, addr) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 29c944e..468ef11 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -27,39 +27,39 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response data Interaction = Interaction { - itrConfig :: Config - , itrRemoteAddr :: SockAddr - , itrResourcePath :: Maybe [String] - , itrRequest :: TVar (Maybe Request) - , itrResponse :: TVar Response + itrConfig :: !Config + , itrRemoteAddr :: !SockAddr + , itrResourcePath :: !(Maybe [String]) + , itrRequest :: !(TVar (Maybe Request)) + , itrResponse :: !(TVar Response) -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重 -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって -- からにすべき。 - , itrRequestHasBody :: TVar Bool - , itrRequestIsChunked :: TVar Bool - , itrExpectedContinue :: TVar Bool + , itrRequestHasBody :: !(TVar Bool) + , itrRequestIsChunked :: !(TVar Bool) + , itrExpectedContinue :: !(TVar Bool) - , itrReqChunkLength :: TVar (Maybe Int) - , itrReqChunkRemaining :: TVar (Maybe Int) - , itrReqChunkIsOver :: TVar Bool - , itrReqBodyWanted :: TVar (Maybe Int) - , itrReqBodyWasteAll :: TVar Bool - , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される + , itrReqChunkLength :: !(TVar (Maybe Int)) + , itrReqChunkRemaining :: !(TVar (Maybe Int)) + , itrReqChunkIsOver :: !(TVar Bool) + , itrReqBodyWanted :: !(TVar (Maybe Int)) + , itrReqBodyWasteAll :: !(TVar Bool) + , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される - , itrWillReceiveBody :: TVar Bool - , itrWillChunkBody :: TVar Bool - , itrWillDiscardBody :: TVar Bool - , itrWillClose :: TVar Bool + , itrWillReceiveBody :: !(TVar Bool) + , itrWillChunkBody :: !(TVar Bool) + , itrWillDiscardBody :: !(TVar Bool) + , itrWillClose :: !(TVar Bool) - , itrBodyToSend :: TVar ByteString - , itrBodyIsNull :: TVar Bool + , itrBodyToSend :: !(TVar ByteString) + , itrBodyIsNull :: !(TVar Bool) - , itrState :: TVar InteractionState + , itrState :: !(TVar InteractionState) - , itrWroteContinue :: TVar Bool - , itrWroteHeader :: TVar Bool + , itrWroteContinue :: !(TVar Bool) + , itrWroteHeader :: !(TVar Bool) } -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 @@ -84,7 +84,8 @@ defaultPageContentType = "application/xhtml+xml" newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction newInteraction conf addr req - = do request <- newTVarIO $ req + = conf `seq` addr `seq` req `seq` + do request <- newTVarIO $ req responce <- newTVarIO $ Response { resVersion = HttpVersion 1 1 , resStatus = Ok @@ -150,25 +151,32 @@ newInteraction conf addr req writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () writeItr itr accessor value - = writeTVar (accessor itr) value + = itr `seq` accessor `seq` value `seq` + writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b readItr itr accessor reader - = readTVar (accessor itr) >>= return . reader + = itr `seq` accessor `seq` reader `seq` + readTVar (accessor itr) >>= return . reader -readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) +readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) readItrF itr accessor reader - = readItr itr accessor (fmap reader) + = itr `seq` accessor `seq` reader `seq` + readItr itr accessor (fmap reader) +{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () updateItr itr accessor updator - = do old <- readItr itr accessor id + = itr `seq` accessor `seq` updator `seq` + do old <- readItr itr accessor id writeItr itr accessor (updator old) -updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () +updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () updateItrF itr accessor updator - = updateItr itr accessor (fmap updator) + = itr `seq` accessor `seq` updator `seq` + updateItr itr accessor (fmap updator) +{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index b41bbcd..9f65323 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -18,9 +18,9 @@ import Network.HTTP.Lucu.Utils -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@ -- represents \"major\/minor; name=value\". data MIMEType = MIMEType { - mtMajor :: String - , mtMinor :: String - , mtParams :: [ (String, String) ] + mtMajor :: !String + , mtMinor :: !String + , mtParams :: ![ (String, String) ] } deriving (Eq) @@ -52,7 +52,8 @@ maj min -- |This operator appends a @(name, value)@ pair to a MIME Type. (<:>) :: MIMEType -> (String, String) -> MIMEType mt@(MIMEType _ _ params) <:> pair - = mt { + = pair `seq` + mt { mtParams = mtParams mt ++ [pair] } @@ -67,7 +68,7 @@ name <=> value = (name, value) mimeTypeP :: Parser MIMEType -mimeTypeP = allowEOF $ +mimeTypeP = allowEOF $! do maj <- token char '/' min <- token @@ -84,4 +85,4 @@ mimeTypeP = allowEOF $ return (name, value) mimeTypeListP :: Parser [MIMEType] -mimeTypeListP = allowEOF $ listOf mimeTypeP +mimeTypeListP = allowEOF $! listOf mimeTypeP diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 93a1479..65bf3a6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -30,14 +30,16 @@ type ExtMap = Map String MIMEType -- |Guess the MIME Type of file. guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType guessTypeByFileName extMap fpath - = let ext = last $ splitBy (== '.') fpath + = extMap `seq` fpath `seq` + let ext = last $ splitBy (== '.') fpath in M.lookup ext extMap >>= return -- |Read an Apache mime.types and parse it. parseExtMapFile :: FilePath -> IO ExtMap parseExtMapFile fpath - = do file <- B.readFile fpath + = fpath `seq` + do file <- B.readFile fpath case parse (allowEOF extMapP) file of (Success xs, _) -> return $ compile xs (_, input') -> let near = B.unpack $ B.take 100 input' diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 4c44f0b..0033eb4 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -55,7 +55,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -- |@Parser a@ is obviously a parser which parses and returns @a@. -data Parser a = Parser { +newtype Parser a = Parser { runParser :: State ParserState (ParserResult a) } @@ -63,7 +63,7 @@ type ParserState = (ByteString, IsEOFFatal) type IsEOFFatal = Bool -data ParserResult a = Success a +data ParserResult a = Success !a | IllegalInput -- 受理出來ない入力があった | ReachedEOF -- 限界を越えて讀まうとした deriving (Eq, Show) @@ -71,72 +71,81 @@ data ParserResult a = Success a -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b instance Monad Parser where - p >>= f = Parser $ do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存 - result <- runParser p - case result of - Success a -> runParser (f a) - IllegalInput -> do put saved -- 状態を復歸 - return IllegalInput - ReachedEOF -> do unless isEOFFatal - $ put saved -- 状態を復歸 - return ReachedEOF - return = Parser . return . Success - fail _ = Parser $ return IllegalInput + p >>= f = Parser $! do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存 + result <- runParser p + case result of + Success a -> a `seq` runParser (f a) + IllegalInput -> do put saved -- 状態を復歸 + return IllegalInput + ReachedEOF -> do unless isEOFFatal + $ put saved -- 状態を復歸 + return ReachedEOF + return x = x `seq` Parser $! return $! Success x + fail _ = Parser $! return $! IllegalInput -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result, -- remaining)@. parse :: Parser a -> ByteString -> (ParserResult a, ByteString) -parse p input = let (result, (input', _)) = runState (runParser p) (input, True) - in - (result, input') +parse p input -- input は lazy である必要有り。 + = p `seq` + let (result, (input', _)) = runState (runParser p) (input, True) + in + result `seq` (result, input') -- input' も lazy である必要有り。 -- |@'parseStr' p str@ packs @str@ and parses it. parseStr :: Parser a -> String -> (ParserResult a, ByteString) -parseStr p input = parse p $ B.pack input +parseStr p input + = p `seq` -- input は lazy である必要有り。 + parse p $! B.pack input anyChar :: Parser Char -anyChar = Parser $ do (input, isEOFFatal) <- get - if B.null input then - return ReachedEOF - else - do let c = B.head input - put (B.tail input, isEOFFatal) - return (Success c) +anyChar = Parser $! + do (input, isEOFFatal) <- get + if B.null input then + return ReachedEOF + else + do let c = B.head input + put (B.tail input, isEOFFatal) + return (Success c) eof :: Parser () -eof = Parser $ do (input, _) <- get - if B.null input then - return $ Success () - else - return IllegalInput +eof = Parser $! + do (input, _) <- get + if B.null input then + return $ Success () + else + return IllegalInput -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. allowEOF :: Parser a -> Parser a -allowEOF f = Parser $ do (input, isEOFFatal) <- get - put (input, False) +allowEOF f = f `seq` + Parser $! do (input, isEOFFatal) <- get + put (input, False) - result <- runParser f + result <- runParser f - (input', _) <- get - put (input', isEOFFatal) + (input', _) <- get + put (input', isEOFFatal) - return result + return result satisfy :: (Char -> Bool) -> Parser Char -satisfy f = do c <- anyChar +satisfy f = f `seq` + do c <- anyChar unless (f c) (fail "") return c char :: Char -> Parser Char -char c = satisfy (== c) +char c = c `seq` satisfy (== c) string :: String -> Parser String -string str = do mapM_ char str +string str = str `seq` + do mapM_ char str return str @@ -145,17 +154,19 @@ infixr 0 <|> -- |This is the backtracking alternation. There is no non-backtracking -- equivalent. (<|>) :: Parser a -> Parser a -> Parser a -f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存 - result <- runParser f - case result of - Success a -> return $ Success a - IllegalInput -> do put saved -- 状態を復歸 - runParser g - ReachedEOF -> if isEOFFatal then - return ReachedEOF - else - do put saved - runParser g +f <|> g + = f `seq` g `seq` + Parser $! do saved@(_, isEOFFatal) <- get -- 状態を保存 + result <- runParser f + case result of + Success a -> return $ Success a + IllegalInput -> do put saved -- 状態を復歸 + runParser g + ReachedEOF -> if isEOFFatal then + return ReachedEOF + else + do put saved + runParser g oneOf :: [Char] -> Parser Char @@ -163,7 +174,8 @@ oneOf = foldl (<|>) (fail "") . map char notFollowedBy :: Parser a -> Parser () -notFollowedBy p = p >>= fail "" <|> return () +notFollowedBy p = p `seq` + p >>= fail "" <|> return () digit :: Parser Char @@ -185,7 +197,8 @@ hexDigit = do c <- anyChar many :: Parser a -> Parser [a] -many p = do x <- p +many p = p `seq` + do x <- p xs <- many p return (x:xs) <|> @@ -193,42 +206,51 @@ many p = do x <- p many1 :: Parser a -> Parser [a] -many1 p = do ret <- many p +many1 p = p `seq` + do ret <- many p case ret of [] -> fail "" xs -> return xs manyTill :: Parser a -> Parser end -> Parser [a] -manyTill p end = many $ do x <- p - end - return x +manyTill p end + = p `seq` end `seq` + many $! do x <- p + end + return x many1Till :: Parser a -> Parser end -> Parser [a] -many1Till p end = many1 $ do x <- p - end - return x +many1Till p end + = p `seq` end `seq` + many1 $! do x <- p + end + return x count :: Int -> Parser a -> Parser [a] count 0 _ = return [] -count n p = do x <- p +count n p = n `seq` p `seq` + do x <- p xs <- count (n-1) p return (x:xs) - +-- def may be a _|_ option :: a -> Parser a -> Parser a -option def p = p <|> return def +option def p = p `seq` + p <|> return def sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy p sep = sepBy1 p sep <|> return [] +sepBy p sep = p `seq` sep `seq` + sepBy1 p sep <|> return [] sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 p sep = do x <- p - xs <- many $ sep >> p +sepBy1 p sep = p `seq` sep `seq` + do x <- p + xs <- many $! sep >> p return (x:xs) diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index ae09522..015c189 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -26,11 +26,30 @@ isCtl :: Char -> Bool isCtl c | c < '\x1f' = True | c >= '\x7f' = True - | otherwise = False + | otherwise = False -- |@'isSeparator' c@ is True iff c is one of HTTP separators. isSeparator :: Char -> Bool -isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t" +isSeparator '(' = True +isSeparator ')' = True +isSeparator '<' = True +isSeparator '>' = True +isSeparator '@' = True +isSeparator ',' = True +isSeparator ';' = True +isSeparator ':' = True +isSeparator '\\' = True +isSeparator '"' = True +isSeparator '/' = True +isSeparator '[' = True +isSeparator ']' = True +isSeparator '?' = True +isSeparator '=' = True +isSeparator '{' = True +isSeparator '}' = True +isSeparator ' ' = True +isSeparator '\t' = True +isSeparator _ = False -- |@'isChar' c@ is True iff @c <= 0x7f@. isChar :: Char -> Bool @@ -41,21 +60,23 @@ isChar c -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator' -- c)@ isToken :: Char -> Bool -isToken c = not (isCtl c || isSeparator c) +isToken c = c `seq` + not (isCtl c || isSeparator c) -- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any -- occurrences of LWS before and after each tokens. listOf :: Parser a -> Parser [a] -listOf p = do many lws - sepBy p (do many lws - char ',' - many lws) +listOf p = p `seq` + do many lws + sepBy p $! do many lws + char ',' + many lws -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $ -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@ token :: Parser String -token = many1 $ satisfy isToken +token = many1 $! satisfy isToken -- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'? -- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@ diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 071ab56..cce46cd 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -56,7 +56,8 @@ import System.Time postprocess :: Interaction -> STM () postprocess itr - = do reqM <- readItr itr itrRequest id + = itr `seq` + do reqM <- readItr itr itrRequest id res <- readItr itr itrResponse id let sc = resStatus res @@ -85,7 +86,8 @@ postprocess itr where relyOnRequest :: Interaction -> STM () relyOnRequest itr - = do status <- readItr itr itrResponse resStatus + = itr `seq` + do status <- readItr itr itrResponse resStatus req <- readItr itr itrRequest fromJust let reqVer = reqVersion req @@ -97,8 +99,8 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $ deleteHeader "Content-Length" - updateRes itr $ deleteHeader "Transfer-Encoding" + updateRes itr $! deleteHeader "Content-Length" + updateRes itr $! deleteHeader "Transfer-Encoding" cType <- readHeader itr "Content-Type" when (cType == Nothing) @@ -106,14 +108,14 @@ postprocess itr if canHaveBody then when (reqVer == HttpVersion 1 1) - $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked" + $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked" writeItr itr itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す when (reqMethod req /= HEAD) - $ do updateRes itr $ deleteHeader "Content-Type" - updateRes itr $ deleteHeader "Etag" - updateRes itr $ deleteHeader "Last-Modified" + $ do updateRes itr $! deleteHeader "Content-Type" + updateRes itr $! deleteHeader "Etag" + updateRes itr $! deleteHeader "Last-Modified" conn <- readHeader itr "Connection" case fmap (map toLower) conn of @@ -122,23 +124,26 @@ postprocess itr willClose <- readItr itr itrWillClose id when willClose - $ updateRes itr $ setHeader "Connection" "close" + $ updateRes itr $! setHeader "Connection" "close" when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True readHeader :: Interaction -> String -> STM (Maybe String) readHeader itr name - = readItr itr itrResponse $ getHeader name + = itr `seq` name `seq` + readItr itr itrResponse $ getHeader name updateRes :: Interaction -> (Response -> Response) -> STM () updateRes itr updator - = updateItr itr itrResponse updator + = itr `seq` updator `seq` + updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response completeUnconditionalHeaders conf res - = return res >>= compServer >>= compDate >>= return + = conf `seq` res `seq` + return res >>= compServer >>= compDate >>= return where compServer res = case getHeader "Server" res of diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index c1f1a8b..5e1d095 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -51,7 +51,8 @@ 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 @@ -80,14 +81,16 @@ preprocess itr 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 @@ -120,24 +123,27 @@ preprocess itr updateAuthority :: String -> String -> 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 = host + , uriPort = portStr + } + } + } + preprocessHeader :: Interaction -> (String, String) -> STM () preprocessHeader itr (name, value) - = case map toLower name of + = itr `seq` name `seq` value `seq` + case map toLower name of "expect" - -> if value `noCaseEq` "100-continue" then + -> if value `noCaseEq'` "100-continue" then writeItr itr itrExpectedContinue True else setStatus ExpectationFailed diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index 354286f..3be2dd4 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -11,31 +11,45 @@ module Network.HTTP.Lucu.RFC1123DateTime import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Parser import System.Time import System.Locale -import Text.Printf -month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] -week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] +month :: [String] +month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] + +week :: [String] +week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] -- |Format a @CalendarTime@ to RFC 1123 Date and Time string. formatRFC1123DateTime :: CalendarTime -> String formatRFC1123DateTime time - = printf "%s, %02d %s %04d %02d:%02d:%02d %s" - (week !! fromEnum (ctWDay time)) - (ctDay time) - (month !! fromEnum (ctMonth time)) - (ctYear time) - (ctHour time) - (ctMin time) - (ctSec time) - (ctTZName time) + = time `seq` + + id (week !! fromEnum (ctWDay time)) + ++ ", " ++ + fmtDec 2 (ctDay time) + ++ " " ++ + id (month !! fromEnum (ctMonth time)) + ++ " " ++ + fmtDec 4 (ctYear time) + ++ " " ++ + fmtDec 2 (ctHour time) + ++ ":" ++ + fmtDec 2 (ctMin time) + ++ ":" ++ + fmtDec 2 (ctSec time) + ++ ":" ++ + id (ctTZName time) + -- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be -- always UTC but prints as GMT. formatHTTPDateTime :: ClockTime -> String -formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime +formatHTTPDateTime time + = time `seq` + formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time -- |Parse an HTTP Date and Time. -- diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 1645b5b..bc1c317 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -28,16 +28,16 @@ data Method = OPTIONS | DELETE | TRACE | CONNECT - | ExtensionMethod String + | ExtensionMethod !String deriving (Eq, Show) -- |This is the definition of HTTP reqest. data Request = Request { - reqMethod :: Method - , reqURI :: URI - , reqVersion :: HttpVersion - , reqHeaders :: Headers + reqMethod :: !Method + , reqURI :: !URI + , reqVersion :: !HttpVersion + , reqHeaders :: !Headers } deriving (Show, Eq) diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 57e0bdc..1cce2d6 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -33,7 +33,8 @@ import System.IO requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO () requestReader cnf tree h addr tQueue - = do catch (do input <- B.hGetContents h + = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq` + do catch (do input <- B.hGetContents h acceptRequest input) $ \ exc -> case exc of IOException _ -> return () 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 diff --git a/Network/HTTP/Lucu/Resource.hs-boot b/Network/HTTP/Lucu/Resource.hs-boot new file mode 100644 index 0000000..77fdfb9 --- /dev/null +++ b/Network/HTTP/Lucu/Resource.hs-boot @@ -0,0 +1,8 @@ +{- -*- haskell -*- -} +module Network.HTTP.Lucu.Resource + where + +import Control.Monad.Reader +import Network.HTTP.Lucu.Interaction + +type Resource a = ReaderT Interaction IO a \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index d468d2b..9af5fd5 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -45,7 +45,7 @@ data ResourceDef = ResourceDef { -- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a -- native thread (spawned using @forkOS@) or to run it on a user -- thread (spanwed using @forkIO@). Generally you don't - resUsesNativeThread :: Bool + resUsesNativeThread :: !Bool -- | Whether to be greedy or not. -- -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a @@ -53,7 +53,7 @@ data ResourceDef = ResourceDef { -- there is another resource at \/aaa\/bbb\/ccc. If the resource -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy -- resource is like a CGI script. - , resIsGreedy :: Bool + , resIsGreedy :: !Bool -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET -- request comes for the resource path. If 'resGet' is Nothing, -- the system responds \"405 Method Not Allowed\" for GET @@ -62,35 +62,35 @@ data ResourceDef = ResourceDef { -- It also runs for HEAD request if the 'resHead' is Nothing. In -- this case 'Network.HTTP.Lucu.Resource.output' and such like -- don't actually write a response body. - , resGet :: Maybe (Resource ()) + , resGet :: !(Maybe (Resource ())) -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD -- request comes for the resource path. If 'resHead' is Nothing, -- the system runs 'resGet' instead. If 'resGet' is also Nothing, -- the system responds \"405 Method Not Allowed\" for HEAD -- requests. - , resHead :: Maybe (Resource ()) + , resHead :: !(Maybe (Resource ())) -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST -- request comes for the resource path. If 'resPost' is Nothing, -- the system responds \"405 Method Not Allowed\" for POST -- requests. - , resPost :: Maybe (Resource ()) + , resPost :: !(Maybe (Resource ())) -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT -- request comes for the resource path. If 'resPut' is Nothing, -- the system responds \"405 Method Not Allowed\" for PUT -- requests. - , resPut :: Maybe (Resource ()) + , resPut :: !(Maybe (Resource ())) -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a -- DELETE request comes for the resource path. If 'resDelete' is -- Nothing, the system responds \"405 Method Not Allowed\" for -- DELETE requests. - , resDelete :: Maybe (Resource ()) + , resDelete :: !(Maybe (Resource ())) } -- | 'ResTree' is an opaque structure which is a map from resource -- path to 'ResourceDef'. type ResTree = ResNode -- root だから Map ではない type ResSubtree = Map String ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree +data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- @@ -100,7 +100,7 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list +mkResTree list = list `seq` processRoot list where processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list @@ -167,13 +167,14 @@ findResource (ResNode rootDefM subtree) uri runResource :: ResourceDef -> Interaction -> IO ThreadId runResource def itr - = fork - $ catch ( runReaderT ( do req <- getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr - ) - $ \ exc -> processException exc + = def `seq` itr `seq` + fork + $! catch ( runReaderT ( do req <- getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + ) itr + ) + $ \ exc -> processException exc where fork :: IO () -> IO ThreadId fork = if (resUsesNativeThread def) diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 9ca08be..913c491 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -16,10 +16,10 @@ module Network.HTTP.Lucu.Response where import Data.Dynamic +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import System.IO -import Text.Printf -- |This is the definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses @@ -80,13 +80,13 @@ data StatusCode = Continue instance Show StatusCode where show sc = let (num, msg) = statusCode sc in - printf "%03d %s" num msg + (fmtDec 3 num) ++ " " ++ msg data Response = Response { - resVersion :: HttpVersion - , resStatus :: StatusCode - , resHeaders :: Headers + resVersion :: !HttpVersion + , resStatus :: !StatusCode + , resHeaders :: !Headers } deriving (Show, Eq) @@ -96,16 +96,18 @@ instance HasHeaders Response where hPutResponse :: Handle -> Response -> IO () -hPutResponse h res = do hPutHttpVersion h (resVersion res) - hPutChar h ' ' - hPutStatus h (resStatus res) - hPutStr h "\r\n" - hPutHeaders h (resHeaders res) +hPutResponse h res + = h `seq` res `seq` + do hPutHttpVersion h (resVersion res) + hPutChar h ' ' + hPutStatus h (resStatus res) + hPutStr h "\r\n" + hPutHeaders h (resHeaders res) hPutStatus :: Handle -> StatusCode -> IO () -hPutStatus h sc = let (num, msg) = statusCode sc - in - hPrintf h "%03d %s" num msg +hPutStatus h sc + = h `seq` sc `seq` + hPutStr h (show sc) -- |@'isInformational' sc@ is True iff @sc < 200@. isInformational :: StatusCode -> Bool diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 6ccc286..00e6f46 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -13,13 +13,13 @@ import Data.Maybe import qualified Data.Sequence as S import Data.Sequence (Seq, ViewR(..)) import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude hiding (catch) import System.IO -import Text.Printf import Control.Concurrent import Debug.Trace @@ -28,7 +28,8 @@ import GHC.Conc (unsafeIOToSTM) responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () responseWriter cnf h tQueue readerTID - = catch awaitSomethingToWrite $ \ exc -> + = cnf `seq` h `seq` tQueue `seq` readerTID `seq` + catch awaitSomethingToWrite $ \ exc -> case exc of IOException _ -> return () AsyncException ThreadKilled -> return () @@ -38,30 +39,31 @@ responseWriter cnf h tQueue readerTID awaitSomethingToWrite :: IO () awaitSomethingToWrite = do action - <- atomically $ + <- atomically $! do -- キューが空でなくなるまで待つ queue <- readTVar tQueue when (S.null queue) retry - let _ :> itr = S.viewr queue - + -- GettingBody 状態にあり、Continue が期待され -- てゐて、それがまだ送信前なのであれば、 -- Continue を送信する。 - state <- readItr itr itrState id - - if state == GettingBody then - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry + case S.viewr queue of + _ :> itr -> do state <- readItr itr itrState id + + if state == GettingBody then + writeContinueIfNecessary itr + else + if state >= DecidingBody then + writeHeaderOrBodyIfNecessary itr + else + retry action writeContinueIfNecessary :: Interaction -> STM (IO ()) writeContinueIfNecessary itr - = do expectedContinue <- readItr itr itrExpectedContinue id + = itr `seq` + do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then do wroteContinue <- readItr itr itrWroteContinue id if wroteContinue then @@ -82,7 +84,8 @@ responseWriter cnf h tQueue readerTID -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 - = do wroteHeader <- readItr itr itrWroteHeader id + = itr `seq` + do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then return $ writeHeader itr @@ -93,15 +96,16 @@ responseWriter cnf h tQueue readerTID do state <- readItr itr itrState id if state == Done then - return $ finalize itr + return $! finalize itr else retry else - return $ writeBodyChunk itr + return $! writeBodyChunk itr writeContinue :: Interaction -> IO () writeContinue itr - = do let cont = Response { + = itr `seq` + do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue , resHeaders = [] @@ -109,27 +113,30 @@ responseWriter cnf h tQueue readerTID cont' <- completeUnconditionalHeaders cnf cont hPutResponse h cont' hFlush h - atomically $ writeItr itr itrWroteContinue True + atomically $! writeItr itr itrWroteContinue True awaitSomethingToWrite writeHeader :: Interaction -> IO () writeHeader itr - = do res <- atomically $ do writeItr itr itrWroteHeader True - readItr itr itrResponse id + = itr `seq` + do res <- atomically $! do writeItr itr itrWroteHeader True + readItr itr itrResponse id hPutResponse h res hFlush h awaitSomethingToWrite writeBodyChunk :: Interaction -> IO () writeBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id - chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id - writeItr itr itrBodyToSend B.empty - return chunk + = itr `seq` + do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id + willChunkBody <- atomically $! readItr itr itrWillChunkBody id + chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id + writeItr itr itrBodyToSend B.empty + return chunk unless willDiscardBody $ do if willChunkBody then - do hPrintf h "%x\r\n" (toInteger $ B.length chunk) + do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk) + hPutStr h "\r\n" B.hPut h chunk hPutStr h "\r\n" else @@ -139,20 +146,23 @@ responseWriter cnf h tQueue readerTID finishBodyChunk :: Interaction -> IO () finishBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id + = itr `seq` + do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id + willChunkBody <- atomically $! readItr itr itrWillChunkBody id when (not willDiscardBody && willChunkBody) $ hPutStr h "0\r\n\r\n" >> hFlush h finalize :: Interaction -> IO () finalize itr - = do finishBodyChunk itr - willClose <- atomically $ do queue <- readTVar tQueue + = itr `seq` + do finishBodyChunk itr + willClose <- atomically $! + do queue <- readTVar tQueue - let (remaining :> _) = S.viewr queue - writeTVar tQueue remaining + case S.viewr queue of + remaining :> _ -> writeTVar tQueue remaining - readItr itr itrWillClose id + readItr itr itrWillClose id if willClose then -- reader は恐らく hWaitForInput してゐる最中なので、 -- スレッドを豫め殺して置かないとをかしくなる。 diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index b84c9cb..a83f285 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -17,6 +17,7 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree @@ -24,7 +25,6 @@ import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils import System.Directory import System.Posix.Files -import Text.Printf -- | @'staticFile' fpath@ is a @@ -35,7 +35,7 @@ staticFile path = ResourceDef { resUsesNativeThread = False , resIsGreedy = False - , resGet = Just $ handleStaticFile path + , resGet = Just $! handleStaticFile path , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -53,7 +53,8 @@ staticFile path -- 'staticFile' instead of this. handleStaticFile :: FilePath -> Resource () handleStaticFile path - = do isFile <- liftIO $ doesFileExist path + = path `seq` + do isFile <- liftIO $ doesFileExist path if isFile then -- 存在はした。讀めるかどうかは知らない。 do readable <- liftIO $ fileAccess path True False False @@ -95,11 +96,17 @@ handleStaticFile path -- large (say, 1 TiB). generateETagFromFile :: FilePath -> IO ETag generateETagFromFile path - = do stat <- getFileStatus path - let inode = fromEnum $ fileID stat - size = fromEnum $ fileSize stat - lastmod = fromEnum $ modificationTime stat - return $ strongETag $ printf "%x-%x-%x" inode size lastmod + = path `seq` + do stat <- getFileStatus path + let inode = fromEnum $! fileID stat + size = fromEnum $! fileSize stat + lastMod = fromEnum $! modificationTime stat + tag = fmtHex False 0 inode + ++ "-" ++ + fmtHex False 0 size + ++ "-" ++ + fmtHex False 0 lastMod + return $! strongETag tag -- | @'staticDir' dir@ is a -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files @@ -110,7 +117,7 @@ staticDir path = ResourceDef { resUsesNativeThread = False , resIsGreedy = True - , resGet = Just $ handleStaticDir path + , resGet = Just $! handleStaticDir path , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -129,7 +136,8 @@ staticDir path -- 'staticDir' instead of this. handleStaticDir :: FilePath -> Resource () handleStaticDir basePath - = do extraPath <- getPathInfo + = basePath `seq` + do extraPath <- getPathInfo securityCheck extraPath let path = basePath ++ "/" ++ joinWith "/" extraPath @@ -137,5 +145,6 @@ handleStaticDir basePath where securityCheck :: Monad m => [String] -> m () securityCheck pathElems - = when (any (== "..") pathElems) $ fail ("security error: " + = pathElems `seq` + when (any (== "..") pathElems) $ fail ("security error: " ++ joinWith "/" pathElems) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 1619f36..b22780b 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -5,6 +5,7 @@ module Network.HTTP.Lucu.Utils , joinWith , trim , noCaseEq + , noCaseEq' , isWhiteSpace , quoteStr , parseWWWFormURLEncoded @@ -22,7 +23,8 @@ import Network.URI -- > ==> ["ab", "c", "def"] splitBy :: (a -> Bool) -> [a] -> [[a]] splitBy isSeparator src - = case break isSeparator src + = isSeparator `seq` + case break isSeparator src of (last , [] ) -> last : [] (first, sep:rest) -> first : splitBy isSeparator rest @@ -30,25 +32,40 @@ splitBy isSeparator src -- > ==> "ab:c:def" joinWith :: [a] -> [[a]] -> [a] joinWith separator xs - = foldr (++) [] $ intersperse separator xs + = separator `seq` xs `seq` + foldr (++) [] $! intersperse separator xs -- |> trim (== '_') "__ab_c__def___" -- > ==> "ab_c__def" trim :: (a -> Bool) -> [a] -> [a] -trim p = trimTail . trimHead +trim p = p `seq` trimTail . trimHead where trimHead = dropWhile p trimTail = reverse . trimHead . reverse -- |@'noCaseEq' a b@ is equivalent to @(map toLower a) == (map toLower --- b)@ +-- b)@. See 'noCaseEq''. noCaseEq :: String -> String -> Bool noCaseEq a b = (map toLower a) == (map toLower b) +{-# INLINE noCaseEq #-} + +-- |@'noCaseEq'' a b@ is a variant of 'noCaseEq' which first checks +-- the length of two strings to avoid possibly unnecessary comparison. +noCaseEq' :: String -> String -> Bool +noCaseEq' a b + | length a /= length b = False + | otherwise = noCaseEq a b +{-# INLINE noCaseEq' #-} -- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF. isWhiteSpace :: Char -> Bool -isWhiteSpace = flip elem " \t\r\n" +isWhiteSpace ' ' = True +isWhiteSpace '\t' = True +isWhiteSpace '\r' = True +isWhiteSpace '\n' = True +isWhiteSpace _ = False +{-# INLINE isWhiteSpace #-} -- |> quoteStr "abc" -- > ==> "\"abc\"" @@ -56,7 +73,8 @@ isWhiteSpace = flip elem " \t\r\n" -- > quoteStr "ab\"c" -- > ==> "\"ab\\\"c\"" quoteStr :: String -> String -quoteStr str = foldr (++) "" (["\""] ++ map quote str ++ ["\""]) +quoteStr str = str `seq` + foldr (++) "" (["\""] ++ map quote str ++ ["\""]) where quote :: Char -> String quote '"' = "\\\""