From 15aa04a569fb13fb0793389f78f52b0255083cef Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 6 Oct 2007 13:26:52 +0900 Subject: [PATCH] Optimization darcs-hash:20071006042652-62b54-27eecc2bc5a40307ae62ee99050030ce1db2d050.gz --- Network/HTTP/Lucu/Abortion.hs | 13 ++- Network/HTTP/Lucu/Config.hs | 10 +- Network/HTTP/Lucu/DefaultPage.hs | 13 ++- Network/HTTP/Lucu/Headers.hs | 141 +++++++++++++++++----- Network/HTTP/Lucu/Interaction.hs | 20 ++-- Network/HTTP/Lucu/Postprocess.hs | 71 +++++++---- Network/HTTP/Lucu/Preprocess.hs | 85 +++++++------- Network/HTTP/Lucu/RFC1123DateTime.hs | 5 +- Network/HTTP/Lucu/Resource.hs | 168 ++++++++++++++------------- Network/HTTP/Lucu/Resource/Tree.hs | 16 +-- Network/HTTP/Lucu/ResponseWriter.hs | 3 +- Network/HTTP/Lucu/Utils.hs | 18 --- 12 files changed, 338 insertions(+), 225 deletions(-) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 9ff629d..0a5ed07 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -16,8 +16,9 @@ import Control.Arrow.ArrowIO import Control.Concurrent.STM import Control.Exception import Control.Monad.Trans -import GHC.Conc (unsafeIOToSTM) +import Data.ByteString.Base (ByteString) import Data.Dynamic +import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers @@ -60,24 +61,24 @@ data Abortion = Abortion { -- > abort MovedPermanently -- > [("Location", "http://example.net/")] -- > (Just "It has been moved to example.net") -abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a +abort :: MonadIO m => StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> m a abort status headers msg = status `seq` headers `seq` msg `seq` - let abo = Abortion status headers msg + let abo = Abortion status (toHeaders headers) msg exc = DynException (toDyn abo) in liftIO $ throwIO exc -- |Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a 'Control.Monad.STM.STM' monad. -abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a +abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> STM a abortSTM 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 'Control.Arrow.ArrowIO.ArrowIO'. -abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c +abortA :: ArrowIO a => a (StatusCode, ([ (ByteString, ByteString) ], Maybe String)) c abortA = arrIO3 abort @@ -99,7 +100,7 @@ abortPage conf reqM res abo Nothing -> let res' = res { resStatus = aboStatus abo } res'' = foldl (.) id [setHeader name value - | (name, value) <- aboHeaders abo] + | (name, value) <- fromHeaders $ aboHeaders abo] $ res' in getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 3d256ed..0784384 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -5,6 +5,8 @@ module Network.HTTP.Lucu.Config ) where +import Data.ByteString.Base (ByteString) +import qualified Data.ByteString.Char8 as C8 import Network import Network.BSD import Network.HTTP.Lucu.MIMEType.Guess @@ -15,10 +17,10 @@ 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 :: !ByteString -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: !HostName + , cnfServerHost :: !ByteString -- |A port ID to listen to HTTP clients. , cnfServerPort :: !PortID -- |The maximum number of requests to accept in one connection @@ -59,8 +61,8 @@ data Config = Config { -- 'cnfServerPort'. defaultConfig :: Config defaultConfig = Config { - cnfServerSoftware = "Lucu/1.0" - , cnfServerHost = unsafePerformIO getHostName + cnfServerSoftware = C8.pack "Lucu/1.0" + , cnfServerHost = C8.pack (unsafePerformIO getHostName) , cnfServerPort = Service "http" , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index b4413ce..f53501f 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -9,7 +9,8 @@ import Control.Arrow import Control.Arrow.ArrowList import Control.Concurrent.STM import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Maybe import Network import Network.HTTP.Lucu.Config @@ -47,11 +48,11 @@ writeDefaultPage itr -- Content-Type が正しくなければ補完できない。 res <- readItr itr itrResponse id - when (getHeader "Content-Type" res == Just defaultPageContentType) + when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) $ do reqM <- readItr itr itrRequest id let conf = itrConfig itr - page = B.pack $ getDefaultPage conf reqM res + page = L8.pack $ getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) $ page @@ -61,9 +62,9 @@ mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlT mkDefaultPage conf status msgA = conf `seq` status `seq` msgA `seq` let (# sCode, sMsg #) = statusCode status - sig = cnfServerSoftware conf + sig = C8.unpack (cnfServerSoftware conf) ++ " at " - ++ cnfServerHost conf + ++ C8.unpack (cnfServerHost conf) ++ ( case cnfServerPort conf of Service serv -> ", service " ++ serv PortNumber num -> ", port " ++ show num @@ -164,6 +165,6 @@ getMsg req res uriPath uri loc :: String - loc = fromJust $! getHeader "Location" res + loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 65a4940..c97c93c 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,51 +1,139 @@ module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) + + , noCaseCmp + , noCaseEq + , emptyHeaders + , toHeaders + , fromHeaders + , headersP , hPutHeaders ) where +import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO) +import qualified Data.ByteString.Char8 as C8 import Data.Char import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Word +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import System.IO -type Headers = [ (String, String) ] +type Headers = Map NCBS ByteString +newtype NCBS = NCBS ByteString + +toNCBS :: ByteString -> NCBS +toNCBS = NCBS +{-# INLINE toNCBS #-} + +fromNCBS :: NCBS -> ByteString +fromNCBS (NCBS x) = x +{-# INLINE fromNCBS #-} + +instance Eq NCBS where + (NCBS a) == (NCBS b) = a == b + +instance Ord NCBS where + (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b + +instance Show NCBS where + show (NCBS x) = show x + +noCaseCmp :: ByteString -> ByteString -> Ordering +noCaseCmp a b = toForeignPtr a `cmp` toForeignPtr b + where + cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering + cmp (x1, s1, l1) (x2, s2, l2) + | l1 == 0 && l2 == 0 = EQ + | x1 == x2 && s1 == s2 && l1 == l2 = EQ + | otherwise + = inlinePerformIO $ + withForeignPtr x1 $ \ p1 -> + withForeignPtr x2 $ \ p2 -> + noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2 +{-# INLINE noCaseCmp #-} + +-- もし先頭の文字列が等しければ、短い方が小さい。 +noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering +noCaseCmp' p1 l1 p2 l2 + | l1 == 0 && l2 == 0 = return EQ + | l1 == 0 && l1 /= 0 = return LT + | l1 /= 0 && l2 == 0 = return GT + | otherwise + = do c1 <- peek p1 + c2 <- peek p2 + case toLower (w2c c1) `compare` toLower (w2c c2) of + EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) + x -> return x + + +noCaseEq :: ByteString -> ByteString -> Bool +noCaseEq a b = toForeignPtr a `cmp` toForeignPtr b + where + cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool + cmp (x1, s1, l1) (x2, s2, l2) + | l1 /= l2 = False + | l1 == 0 && l2 == 0 = True + | x1 == x2 && s1 == s2 && l1 == l2 = True + | otherwise + = inlinePerformIO $ + withForeignPtr x1 $ \ p1 -> + withForeignPtr x2 $ \ p2 -> + noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1 + + +noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +noCaseEq' p1 p2 l + | l == 0 = return True + | otherwise + = do c1 <- peek p1 + c2 <- peek p2 + if toLower (w2c c1) == toLower (w2c c2) then + noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1) + else + return False + class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a - getHeader :: String -> a -> Maybe String + getHeader :: ByteString -> a -> Maybe ByteString getHeader key a = key `seq` a `seq` - fmap snd $ find (noCaseEq' key . fst) (getHeaders a) + M.lookup (toNCBS key) (getHeaders a) - deleteHeader :: String -> a -> a + deleteHeader :: ByteString -> a -> a deleteHeader key a = key `seq` a `seq` - setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a) - - addHeader :: String -> String -> a -> a - addHeader key val a - = key `seq` val `seq` a `seq` - setHeaders a $ (getHeaders a) ++ [(key, val)] + setHeaders a $ M.delete (toNCBS key) (getHeaders a) - setHeader :: String -> String -> a -> a + setHeader :: ByteString -> ByteString -> a -> a setHeader key val a = 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 + setHeaders a $ M.insert (toNCBS key) val (getHeaders a) + emptyHeaders :: Headers -emptyHeaders = [] +emptyHeaders = M.empty + + +toHeaders :: [(ByteString, ByteString)] -> Headers +toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs] + + +fromHeaders :: Headers -> [(ByteString, ByteString)] +fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] {- @@ -62,9 +150,9 @@ emptyHeaders = [] headersP :: Parser Headers headersP = do xs <- many header crlf - return xs + return (M.fromList xs) where - header :: Parser (String, String) + header :: Parser (NCBS, ByteString) header = do name <- token char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 @@ -76,7 +164,8 @@ headersP = do xs <- many header contents <- many (lws <|> many1 text) crlf let value = foldr (++) "" contents - return (name, normalize value) + norm = normalize value + return (toNCBS $ C8.pack name, C8.pack norm) normalize :: String -> String normalize = trimBody . trim isWhiteSpace @@ -95,12 +184,12 @@ headersP = do xs <- many header hPutHeaders :: Handle -> Headers -> IO () hPutHeaders h hds = h `seq` hds `seq` - mapM_ putH hds >> hPutStr h "\r\n" + mapM_ putH (M.toList hds) >> hPutStr h "\r\n" where - putH :: (String, String) -> IO () + putH :: (NCBS, ByteString) -> IO () putH (name, value) = name `seq` value `seq` - do hPutStr h name - hPutStr h ": " - hPutStr h value - hPutStr h "\r\n" + do C8.hPutStr h (fromNCBS name) + C8.hPutStr h (C8.pack ": ") + C8.hPutStr h value + C8.hPutStr h (C8.pack "\r\n") diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 91979c9..3445219 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -15,12 +15,14 @@ module Network.HTTP.Lucu.Interaction where import Control.Concurrent.STM -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Data.ByteString.Base (ByteString, LazyByteString) +import Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Sequence as S import Data.Sequence (Seq) import Network.Socket import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response @@ -43,14 +45,14 @@ data Interaction = Interaction { , itrReqChunkIsOver :: !(TVar Bool) , itrReqBodyWanted :: !(TVar (Maybe Int)) , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される + , itrReceivedBody :: !(TVar LazyByteString) -- Resource が受領した部分は削除される , itrWillReceiveBody :: !(TVar Bool) , itrWillChunkBody :: !(TVar Bool) , itrWillDiscardBody :: !(TVar Bool) , itrWillClose :: !(TVar Bool) - , itrBodyToSend :: !(TVar ByteString) + , itrBodyToSend :: !(TVar LazyByteString) , itrBodyIsNull :: !(TVar Bool) , itrState :: !(TVar InteractionState) @@ -75,8 +77,8 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty -defaultPageContentType :: String -defaultPageContentType = "application/xhtml+xml" +defaultPageContentType :: ByteString +defaultPageContentType = C8.pack "application/xhtml+xml" newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction @@ -86,7 +88,7 @@ newInteraction conf addr req responce <- newTVarIO $ Response { resVersion = HttpVersion 1 1 , resStatus = Ok - , resHeaders = [("Content-Type", defaultPageContentType)] + , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)] } requestHasBody <- newTVarIO False @@ -98,14 +100,14 @@ newInteraction conf addr req reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - receivedBody <- newTVarIO B.empty + receivedBody <- newTVarIO L8.empty willReceiveBody <- newTVarIO False willChunkBody <- newTVarIO False willDiscardBody <- newTVarIO False willClose <- newTVarIO False - bodyToSend <- newTVarIO B.empty + bodyToSend <- newTVarIO L8.empty bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False state <- newTVarIO ExaminingRequest diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 062a3bf..6e8a5e6 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -6,7 +6,9 @@ module Network.HTTP.Lucu.Postprocess import Control.Concurrent.STM import Control.Monad -import Data.Char +import Data.ByteString.Base (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.IORef import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion @@ -18,6 +20,7 @@ import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import System.Time +import System.IO.Unsafe {- @@ -64,11 +67,11 @@ postprocess itr $ Just ("The status code is not good for a final status: " ++ show sc) - when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) + when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing) $ abortSTM InternalServerError [] $ Just ("The status was " ++ show sc ++ " but no Allow header.") - when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) + when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing) $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") @@ -97,37 +100,40 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $! deleteHeader "Content-Length" - updateRes itr $! deleteHeader "Transfer-Encoding" + updateRes itr $! deleteHeader (C8.pack "Content-Length") + updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding") - cType <- readHeader itr "Content-Type" + cType <- readHeader itr (C8.pack "Content-Type") when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" defaultPageContentType + $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType if canHaveBody then when (reqVer == HttpVersion 1 1) - $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked" + $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "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" - - conn <- readHeader itr "Connection" - case fmap (map toLower) conn of - Just "close" -> writeItr itr itrWillClose True - _ -> return () + $ do updateRes itr $! deleteHeader (C8.pack "Content-Type") + updateRes itr $! deleteHeader (C8.pack "Etag") + updateRes itr $! deleteHeader (C8.pack "Last-Modified") + + conn <- readHeader itr (C8.pack "Connection") + case conn of + Nothing -> return () + Just value -> if value `noCaseEq` C8.pack "close" then + writeItr itr itrWillClose True + else + return () willClose <- readItr itr itrWillClose id when willClose - $ updateRes itr $! setHeader "Connection" "close" + $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close") when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Interaction -> String -> STM (Maybe String) + readHeader :: Interaction -> ByteString -> STM (Maybe ByteString) readHeader itr name = itr `seq` name `seq` readItr itr itrResponse $ getHeader name @@ -144,12 +150,29 @@ completeUnconditionalHeaders conf res return res >>= compServer >>= compDate >>= return where compServer res - = case getHeader "Server" res of - Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res + = case getHeader (C8.pack "Server") res of + Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res Just _ -> return res compDate res - = case getHeader "Date" res of - Nothing -> do time <- getClockTime - return $ addHeader "Date" (formatHTTPDateTime time) res - Just _ -> return res \ No newline at end of file + = case getHeader (C8.pack "Date") res of + Nothing -> do date <- getCurrentDate + return $ setHeader (C8.pack "Date") date res + Just _ -> return res + + +cache :: IORef (ClockTime, ByteString) +cache = unsafePerformIO $ + newIORef (TOD 0 0, undefined) +{-# NOINLINE cache #-} + +getCurrentDate :: IO ByteString +getCurrentDate = do now@(TOD curSec _) <- getClockTime + (TOD cachedSec _, cachedStr) <- readIORef cache + + if curSec == cachedSec then + return cachedStr + else + do let dateStr = C8.pack $ formatHTTPDateTime now + writeIORef cache (now, dateStr) + return dateStr \ No newline at end of file diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 37b1a75..ef66898 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -5,6 +5,8 @@ module Network.HTTP.Lucu.Preprocess import Control.Concurrent.STM import Control.Monad +import Data.ByteString.Base (ByteString) +import qualified Data.ByteString.Char8 as C8 import Data.Char import Data.Maybe import Network.HTTP.Lucu.Config @@ -13,7 +15,6 @@ import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils import Network import Network.URI @@ -74,7 +75,7 @@ preprocess itr PUT -> writeItr itr itrRequestHasBody True _ -> setStatus NotImplemented - mapM_ (preprocessHeader itr) (reqHeaders req) + preprocessHeader itr req where setStatus :: StatusCode -> STM () setStatus status @@ -101,24 +102,24 @@ preprocess itr 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 :: ByteString -> (ByteString, ByteString) + parseHost = C8.break (== ':') - updateAuthority :: String -> String -> STM () + updateAuthority :: ByteString -> ByteString -> STM () updateAuthority host portStr = host `seq` portStr `seq` updateItr itr itrRequest @@ -127,41 +128,45 @@ preprocess itr in uri { uriAuthority = Just URIAuth { uriUserInfo = "" - , uriRegName = host - , uriPort = portStr + , uriRegName = C8.unpack host + , uriPort = C8.unpack portStr } } } - preprocessHeader :: Interaction -> (String, String) -> STM () - preprocessHeader itr (name, value) - = itr `seq` name `seq` value `seq` - case map toLower name of - - "expect" - -> if value `noCaseEq'` "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus ExpectationFailed - - "transfer-encoding" - -> case map toLower value of - "identity" -> return () - "chunked" -> writeItr itr itrRequestIsChunked True - _ -> setStatus NotImplemented - - "content-length" - -> if all isDigit value then - do let len = read value - writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - else - setStatus BadRequest - - "connection" - -> case map toLower value of - "close" -> writeItr itr itrWillClose True - _ -> return () - - _ -> return () \ No newline at end of file + preprocessHeader :: Interaction -> Request -> STM () + preprocessHeader itr req + = itr `seq` 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 () diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index e9300a5..4606baf 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -9,6 +9,7 @@ module Network.HTTP.Lucu.RFC1123DateTime where import Control.Monad +import Data.ByteString.Base (LazyByteString) import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Parser import System.Time @@ -63,9 +64,9 @@ formatHTTPDateTime time -- ...but currently this function only supports the RFC 1123 -- format. This is a violation of RFC 2616 so this should be fixed -- later. What a bother! -parseHTTPDateTime :: String -> Maybe ClockTime +parseHTTPDateTime :: LazyByteString -> Maybe ClockTime parseHTTPDateTime src - = case parseStr httpDateTime src of + = case parse httpDateTime src of (# Success ct, _ #) -> Just ct (# _ , _ #) -> Nothing diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 44db0dc..bf75de8 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -134,8 +134,9 @@ module Network.HTTP.Lucu.Resource import Control.Concurrent.STM import Control.Monad.Reader import Data.Bits -import Data.ByteString.Base (LazyByteString) -import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Base (ByteString, LazyByteString(..)) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion @@ -291,7 +292,7 @@ getQueryForm = do reqURI <- getRequestURI -- 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 :: ByteString -> Resource (Maybe ByteString) getHeader name = name `seq` do req <- getRequest return $! H.getHeader name req @@ -299,22 +300,22 @@ getHeader name = name `seq` -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". getAccept :: Resource [MIMEType] -getAccept = do acceptM <- getHeader "Accept" +getAccept = do acceptM <- getHeader (C8.pack "Accept") case acceptM of Nothing -> return [] Just accept - -> case parseStr mimeTypeListP accept of + -> case parse mimeTypeListP (LPS [accept]) of (# Success xs, _ #) -> return xs (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ accept) + (Just $ "Unparsable Accept: " ++ C8.unpack accept) -- |Get a list of @(contentCoding, qvalue)@ enumerated on header -- \"Accept-Encoding\". The list is sorted in descending order by -- qvalue. getAcceptEncoding :: Resource [(String, Maybe Double)] getAcceptEncoding - = do accEncM <- getHeader "Accept-Encoding" + = do accEncM <- getHeader (C8.pack "Accept-Encoding") case accEncM of Nothing -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い @@ -325,36 +326,37 @@ getAcceptEncoding case ver of HttpVersion 1 0 -> return [("identity", Nothing)] HttpVersion 1 1 -> return [("*" , Nothing)] - Just "" - -- identity のみが許される。 - -> return [("identity", Nothing)] - Just accEnc - -> case parseStr acceptEncodingListP accEnc of - (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ accEnc) + Just value + -> if C8.null value then + -- identity のみが許される。 + return [("identity", Nothing)] + else + case parse acceptEncodingListP (LPS [value]) of + (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) -- |Check whether a given content-coding is acceptable. isEncodingAcceptable :: String -> Resource Bool isEncodingAcceptable coding = do accList <- getAcceptEncoding return (flip any accList $ \ (c, q) -> - (c == "*" || c `noCaseEq` coding) && q /= Just 0) + (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0) -- |Get the header \"Content-Type\" as -- 'Network.HTTP.Lucu.MIMEType.MIMEType'. getContentType :: Resource (Maybe MIMEType) getContentType - = do cTypeM <- getHeader "Content-Type" + = do cTypeM <- getHeader (C8.pack "Content-Type") case cTypeM of Nothing -> return Nothing Just cType - -> case parseStr mimeTypeP cType of + -> case parse mimeTypeP (LPS [cType]) of (# Success t, _ #) -> return $ Just t (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ cType) + (Just $ "Unparsable Content-Type: " ++ C8.unpack cType) {- ExaminingRequest 時に使用するアクション群 -} @@ -380,7 +382,7 @@ foundEntity tag timeStamp method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp + $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp) when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundEntity for POST request.") @@ -402,25 +404,27 @@ foundETag tag method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "ETag" $! show tag + $ setHeader' (C8.pack "ETag") (C8.pack $ show tag) when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundETag for POST request.") -- If-Match があればそれを見る。 - ifMatch <- getHeader "If-Match" + ifMatch <- getHeader (C8.pack "If-Match") case ifMatch of - Nothing -> return () - Just "*" -> return () - Just list -> case parseStr eTagListP list of - (# Success tags, _ #) - -- tags の中に一致するものが無ければ - -- PreconditionFailed で終了。 - -> when (not $ any (== tag) tags) - $ abort PreconditionFailed [] - $! Just ("The entity tag doesn't match: " ++ list) - (# _, _ #) - -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) + Nothing -> return () + Just value -> if value == C8.pack "*" then + return () + else + case parse eTagListP (LPS [value]) of + (# Success tags, _ #) + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + -> when (not $ any (== tag) tags) + $ abort PreconditionFailed [] + $! Just ("The entity tag doesn't match: " ++ C8.unpack value) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value) let statusForNoneMatch = if method == GET || method == HEAD then NotModified @@ -428,16 +432,18 @@ foundETag tag PreconditionFailed -- If-None-Match があればそれを見る。 - ifNoneMatch <- getHeader "If-None-Match" + ifNoneMatch <- getHeader (C8.pack "If-None-Match") case ifNoneMatch of - Nothing -> return () - 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) + Nothing -> return () + Just value -> if value == C8.pack "*" then + abort statusForNoneMatch [] $! Just ("The entity tag matches: *") + else + case parse eTagListP (LPS [value]) of + (# Success tags, _ #) + -> when (any (== tag) tags) + $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value) driftTo GettingBody @@ -458,7 +464,7 @@ foundTimeStamp timeStamp method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp + $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp) when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") @@ -469,25 +475,25 @@ foundTimeStamp timeStamp PreconditionFailed -- If-Modified-Since があればそれを見る。 - ifModSince <- getHeader "If-Modified-Since" + ifModSince <- getHeader (C8.pack "If-Modified-Since") case ifModSince of - Just str -> case parseHTTPDateTime str of + Just str -> case parseHTTPDateTime (LPS [str]) of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] - $! Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ C8.unpack str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () -- If-Unmodified-Since があればそれを見る。 - ifUnmodSince <- getHeader "If-Unmodified-Since" + ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") case ifUnmodSince of - Just str -> case parseHTTPDateTime str of + Just str -> case parseHTTPDateTime (LPS [str]) of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] - $! Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ C8.unpack str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -513,7 +519,7 @@ foundNoEntity msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader "If-Match" + ifMatch <- getHeader (C8.pack "If-Match") when (ifMatch /= Nothing) $ abort PreconditionFailed [] msgM @@ -538,7 +544,7 @@ foundNoEntity msgM -- use it whenever possible. input :: Int -> Resource String input limit = limit `seq` - inputLBS limit >>= return . B.unpack + inputLBS limit >>= return . L8.unpack -- | This is mostly the same as 'input' but is more @@ -558,7 +564,7 @@ inputLBS limit askForInput itr else do driftTo DecidingHeader - return B.empty + return L8.empty return chunk where askForInput :: Interaction -> Resource LazyByteString @@ -584,7 +590,7 @@ inputLBS limit chunk <- liftIO $! atomically $! do chunk <- readItr itr itrReceivedBody id chunkIsOver <- readItr itr itrReqChunkIsOver id - if B.length chunk < fromIntegral actualLimit then + if L8.length chunk < fromIntegral actualLimit then -- 要求された量に滿たなくて、まだ殘り -- があるなら再試行。 unless chunkIsOver @@ -597,7 +603,7 @@ inputLBS limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにす -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody B.empty + writeItr itr itrReceivedBody L8.empty return chunk driftTo DecidingHeader return chunk @@ -623,7 +629,7 @@ inputLBS limit -- should use it whenever possible. inputChunk :: Int -> Resource String inputChunk limit = limit `seq` - inputChunkLBS limit >>= return . B.unpack + inputChunkLBS limit >>= return . L8.unpack -- | This is mostly the same as 'inputChunk' but is more @@ -638,7 +644,7 @@ inputChunkLBS limit askForInput itr else do driftTo DecidingHeader - return B.empty + return L8.empty return chunk where askForInput :: Interaction -> Resource LazyByteString @@ -660,14 +666,14 @@ inputChunkLBS limit $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 - when (B.length chunk < fromIntegral actualLimit) + when (L8.length chunk < fromIntegral actualLimit) $ do chunkIsOver <- readItr itr itrReqChunkIsOver id unless chunkIsOver $ retry -- 成功 - writeItr itr itrReceivedBody B.empty + writeItr itr itrReceivedBody L8.empty return chunk - when (B.null chunk) + when (L8.null chunk) $ driftTo DecidingHeader return chunk @@ -740,13 +746,13 @@ setStatus code -- 20 bytes long. In this case the client shall only accept the first -- 10 bytes of response body and thinks that the residual 10 bytes is -- a part of header of the next response. -setHeader :: String -> String -> Resource () +setHeader :: ByteString -> ByteString -> Resource () setHeader name value = name `seq` value `seq` driftTo DecidingHeader >> setHeader' name value -setHeader' :: String -> String -> Resource () +setHeader' :: ByteString -> ByteString -> Resource () setHeader' name value = name `seq` value `seq` do itr <- getInteraction @@ -772,13 +778,13 @@ redirect code uri -- \"Content-Type\" to @mType@. setContentType :: MIMEType -> Resource () setContentType mType - = setHeader "Content-Type" $! show mType + = setHeader (C8.pack "Content-Type") (C8.pack $ show mType) -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. setLocation :: URI -> Resource () setLocation uri - = setHeader "Location" $ uriToString id uri $ "" + = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "") -- |Computation of @'setContentEncoding' codings@ sets the response -- header \"Content-Encoding\" to @codings@. @@ -788,7 +794,7 @@ setContentEncoding codings let tr = case ver of HttpVersion 1 0 -> unnormalizeCoding HttpVersion 1 1 -> id - setHeader "Content-Encoding" $ joinWith ", " $ map tr codings + setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings) {- DecidingBody 時に使用するアクション群 -} @@ -801,7 +807,7 @@ setContentEncoding codings -- Note that 'outputLBS' is more efficient than 'output' so you should -- use it whenever possible. output :: String -> Resource () -output str = outputLBS $! B.pack str +output str = outputLBS $! L8.pack str {-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. @@ -818,7 +824,7 @@ outputLBS str = do outputChunkLBS str -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so -- you should use it whenever possible. outputChunk :: String -> Resource () -outputChunk str = outputChunkLBS $! B.pack str +outputChunk str = outputChunkLBS $! L8.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. @@ -839,30 +845,30 @@ outputChunkLBS str unless (discardBody) $ sendChunks str limit - unless (B.null str) + unless (L8.null str) $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま + -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま -- ResponseWriter に渡したりすると大變な事が起こる。何故なら -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 -- く爲にチャンクの大きさを測る。 sendChunks :: LazyByteString -> Int -> Resource () sendChunks str limit - | B.null str = return () - | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str - itr <- getInteraction - liftIO $ atomically $ - do buf <- readItr itr itrBodyToSend id - if B.null buf then - -- バッファが消化された - writeItr itr itrBodyToSend chunk - else - -- 消化されるのを待つ - retry - -- 殘りのチャンクについて繰り返す - sendChunks remaining limit + | L8.null str = return () + | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str + itr <- getInteraction + liftIO $ atomically $ + do buf <- readItr itr itrBodyToSend id + if L8.null buf then + -- バッファが消化された + writeItr itr itrBodyToSend chunk + else + -- 消化されるのを待つ + retry + -- 殘りのチャンクについて繰り返す + sendChunks remaining limit {- diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 149fa9d..bb12dd0 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -15,6 +15,7 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad +import qualified Data.ByteString.Char8 as C8 import Data.Dynamic import Data.List import qualified Data.Map as M @@ -22,6 +23,7 @@ import Data.Map (Map) import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders) import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response @@ -195,7 +197,7 @@ runResource def itr notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ joinWith ", " allowedMethods + setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) allowedMethods :: [String] allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"] @@ -213,14 +215,14 @@ runResource def itr processException :: Exception -> IO () processException exc = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] $ Just msg - IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE + ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg + IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE DynException dynE -> case fromDynamic dynE of Just (abo :: Abortion) -> abo Nothing - -> Abortion InternalServerError [] + -> Abortion InternalServerError emptyHeaders $ Just $ show exc - _ -> Abortion InternalServerError [] $ Just $ show exc + _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr @@ -231,9 +233,7 @@ runResource def itr if state <= DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo + mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index be9f370..a676e15 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -12,6 +12,7 @@ import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Format +import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess @@ -106,7 +107,7 @@ responseWriter cnf h tQueue readerTID do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue - , resHeaders = [] + , resHeaders = emptyHeaders } cont' <- completeUnconditionalHeaders cnf cont hPutResponse h cont' diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 0c29836..b679a93 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -4,8 +4,6 @@ module Network.HTTP.Lucu.Utils ( splitBy , joinWith , trim - , noCaseEq - , noCaseEq' , isWhiteSpace , quoteStr , parseWWWFormURLEncoded @@ -40,22 +38,6 @@ trim p = p `seq` trimTail . trimHead trimHead = dropWhile p trimTail = reverse . trimHead . reverse --- |@'noCaseEq' a b@ is equivalent to @('Prelude.map' --- 'Data.Char.toLower' a) == ('Prelude.map' 'Data.Char.toLower' --- 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 'Prelude.True' iff c is one of SP, HT, CR -- and LF. isWhiteSpace :: Char -> Bool -- 2.40.0