From: pho Date: Sun, 25 Mar 2007 11:40:05 +0000 (+0900) Subject: Many improvements: still in early development X-Git-Tag: RELEASE-0_2_1~68 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git Many improvements: still in early development darcs-hash:20070325114005-62b54-2cf24fc0b33bbe817bc9ece8067c40da5e63a1c4.gz --- diff --git a/Lucu.cabal b/Lucu.cabal index b04dc16..121740b 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -6,7 +6,7 @@ Author: PHO Homepage: http://ccm.sherry.jp/ Category: Incomplete Build-Depends: - base, mtl, network + base, mtl, network, stm, parsec Exposed-Modules: Network.HTTP.Lucu.Config Network.HTTP.Lucu.Headers @@ -15,7 +15,9 @@ Exposed-Modules: Network.HTTP.Lucu.Response Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Request +ghc-options: -threaded Executable: HelloWorld Main-Is: HelloWorld.hs Hs-Source-Dirs: ., examples +ghc-options: -threaded \ No newline at end of file diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 919e134..2d37022 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -7,13 +7,15 @@ module Network.HTTP.Lucu.Config import Network data Config = Config { - cnfServerPort :: PortID - , cnfMaxEntityLength :: Integer - , cnfMaxURILength :: Int + cnfServerPort :: PortID + , cnfMaxPipelineDepth :: Int + , cnfMaxEntityLength :: Integer + , cnfMaxURILength :: Int } defaultConfig = Config { - cnfServerPort = Service "http" - , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB - , cnfMaxURILength = 4 * 1024 -- 4 KiB + cnfServerPort = Service "http" + , cnfMaxPipelineDepth = 100 + , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB + , cnfMaxURILength = 4 * 1024 -- 4 KiB } \ No newline at end of file diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index fbab856..655252c 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,34 +1,38 @@ module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - , emptyHeaders -- Headers + , emptyHeaders -- Headers + , headersP -- Parser Headers + , hPutHeaders -- Handle -> Headers -> IO () ) where -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) import Data.Char import Data.List +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import System.IO -type Headers = [ (ByteString, ByteString) ] +type Headers = [ (String, String) ] class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a - getHeader :: a -> ByteString -> Maybe ByteString + getHeader :: a -> String -> Maybe String getHeader a key = fmap snd $ find (noCaseEq key . fst) (getHeaders a) - deleteHeader :: a -> ByteString -> a + deleteHeader :: a -> String -> a deleteHeader a key = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a) - addHeader :: a -> ByteString -> ByteString -> a + addHeader :: a -> String -> String -> a addHeader a key val = setHeaders a $ (getHeaders a) ++ [(key, val)] - setHeader :: a -> ByteString -> ByteString -> a + setHeader :: a -> String -> String -> a setHeader a key val = let list = getHeaders a deleted = filter (not . noCaseEq key . fst) list @@ -36,10 +40,53 @@ class HasHeaders a where in setHeaders a added -noCaseEq :: ByteString -> ByteString -> Bool -noCaseEq a b - = (B.map toLower a) == (B.map toLower b) +emptyHeaders :: Headers +emptyHeaders = [] -emptyHeaders :: Headers -emptyHeaders = [] \ No newline at end of file +{- + message-header = field-name ":" [ field-value ] + field-name = token + field-value = *( field-content | LWS ) + field-content = + + field-value の先頭および末尾にある LWS は全て削除され、それ以外の + LWS は單一の SP に變換される。 +-} +headersP :: Parser Headers +headersP = do xs <- many header + crlf + return xs + where + header :: Parser (String, String) + header = do name <- token + char ':' + -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 + -- の記述はひどく曖昧であり、この動作が本當に間違って + -- ゐるのかどうかも良く分からない。例へば + -- quoted-string の内部にある空白は纏めていいのか惡い + -- のか？直勸的には駄目さうに思へるが、そんな記述は見 + -- 付からない。 + contents <- many (lws <|> many1 text) + crlf + let value = foldr (++) "" contents + return (name, normalize value) + + normalize :: String -> String + normalize = trimBody . trim isWhiteSpace + + trimBody = nubBy (\ a b -> a == ' ' && b == ' ') + . map (\ c -> if isWhiteSpace c + then ' ' + else c) + + +hPutHeaders :: Handle -> Headers -> IO () +hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n" + where + putH (name, value) = 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 88dc24e..9b955d3 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,15 +1,20 @@ module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) - , httpVersionP -- Parser HttpVersion + , httpVersionP -- Parser HttpVersion + , hPutHttpVersion -- Handle -> HttpVersion -> IO () ) where import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Network.HTTP.Lucu.Parser +import System.IO data HttpVersion = HttpVersion Int Int - deriving (Show, Eq) + deriving (Eq) + +instance Show HttpVersion where + show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min instance Ord HttpVersion where (HttpVersion majA minA) `compare` (HttpVersion majB minB) @@ -27,3 +32,10 @@ httpVersionP = do string "HTTP/" minor <- many1 digit return $ HttpVersion (read major) (read minor) + +hPutHttpVersion :: Handle -> HttpVersion -> IO () +hPutHttpVersion h (HttpVersion maj min) + = 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 70df377..8fc36ac 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,32 +1,22 @@ module Network.HTTP.Lucu.Httpd - ( ResourceTable - , mkResourceTable -- [ ([String], Resource ()) ] -> ResourceTable - , runHttpd -- Config -> ResourceTable -> IO () + ( runHttpd -- Config -> ResTree -> IO () ) where import Control.Concurrent +import Control.Concurrent.STM import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Map as M -import Data.Map (Map) import Network import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.RequestReader import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.ResponseWriter import System.IO -type ResourceTable = Map [String] (Resource ()) - - -mkResourceTable :: [ ([String], Resource ()) ] -> ResourceTable -mkResourceTable = M.fromList - - -runHttpd :: Config -> ResourceTable -> IO () +runHttpd :: Config -> ResTree -> IO () runHttpd cnf table = withSocketsDo $ do so <- listenOn (cnfServerPort cnf) @@ -34,19 +24,8 @@ runHttpd cnf table where loop :: Socket -> IO () loop so - = do (h, host, port) <- accept so - forkIO $ service h host port + = do (h, host, _) <- accept so + tQueue <- newInteractionQueue + forkIO $ requestReader cnf table h host tQueue + forkIO $ responseWriter h tQueue loop so - - -service :: Handle -> HostName -> PortNumber -> IO () -service h host port - = do input <- B.hGetContents h - loop input - where - loop :: ByteString -> IO () - loop input = case parse requestP input of - Nothing - -> fail "FIXME" - Just (req, input') - -> print req diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs new file mode 100644 index 0000000..44f4243 --- /dev/null +++ b/Network/HTTP/Lucu/Interaction.hs @@ -0,0 +1,101 @@ +module Network.HTTP.Lucu.Interaction + ( Interaction(..) + , InteractionState(..) + , InteractionQueue + , newInteractionQueue -- IO InteractionQueue + , newInteraction -- HostName -> Maybe Request -> IO Interaction + ) + where + +import Control.Concurrent.STM +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.Sequence as S +import Data.Sequence (Seq) +import Network +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response + +data Interaction = Interaction { + itrRemoteHost :: HostName + , itrRequest :: Maybe Request + , itrResponse :: TVar (Maybe Response) + + , itrRequestHasBody :: TVar Bool + , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明 + , itrRequestIsChunked :: TVar Bool + , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される + + , itrExpectedContinue :: TVar Bool + + , itrWillChunkBody :: TVar Bool + , itrWillDiscardBody :: TVar Bool + , itrWillClose :: TVar Bool + , itrBodyToSend :: TVar ByteString + + , itrState :: TVar InteractionState + + , itrWroteContinue :: TVar Bool + , itrWroteHeader :: TVar Bool + } + +-- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 +-- 状態は ExaminingHeader (リクエストボディが有る時) または +-- DecidingHeader (無い時)。終了状態は常に Done +data InteractionState = ExaminingHeader + | GettingBody + | DecidingHeader + | DecidingBody + | Done + deriving (Show, Eq, Ord) + +type InteractionQueue = TVar (Seq Interaction) + + +newInteractionQueue :: IO InteractionQueue +newInteractionQueue = newTVarIO S.empty + + +newInteraction :: HostName -> Maybe Request -> IO Interaction +newInteraction host req + = do responce <- newTVarIO Nothing + + requestHasBody <- newTVarIO False + requestBodyLength <- newTVarIO Nothing + requestIsChunked <- newTVarIO False + receivedBody <- newTVarIO B.empty + + expectedContinue <- newTVarIO False + + willChunkBody <- newTVarIO False + willDiscardBody <- newTVarIO False + willClose <- newTVarIO False + bodyToSend <- newTVarIO B.empty + + state <- newTVarIO undefined + + wroteContinue <- newTVarIO False + wroteHeader <- newTVarIO False + + return $ Interaction { + itrRemoteHost = host + , itrRequest = req + , itrResponse = responce + + , itrRequestHasBody = requestHasBody + , itrRequestBodyLength = requestBodyLength + , itrRequestIsChunked = requestIsChunked + , itrReceivedBody = receivedBody + + , itrExpectedContinue = expectedContinue + + , itrWillChunkBody = willChunkBody + , itrWillDiscardBody = willDiscardBody + , itrWillClose = willClose + , itrBodyToSend = bodyToSend + + , itrState = state + + , itrWroteContinue = wroteContinue + , itrWroteHeader = wroteHeader + } diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 7a51ddc..3fa4c15 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -13,7 +13,9 @@ module Network.HTTP.Lucu.Parser , many1 -- Parser a -> Parser [a] , manyTill -- Parser a -> Parser end -> Parser [a] , many1Till -- Parser a -> Parser end -> Parser [a] + , option -- a -> Parser a -> Parser a , sp -- Parser Char + , ht -- Parser Char , crlf -- Parser String ) where @@ -121,9 +123,17 @@ many1Till p end = many1 $ do x <- p return x +option :: a -> Parser a -> Parser a +option def p = p <|> return def + + sp :: Parser Char sp = char ' ' +ht :: Parser Char +ht = char '\t' + + crlf :: Parser String crlf = string "\x0d\x0a" diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index 021ced8..c1b30fc 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -1,7 +1,12 @@ module Network.HTTP.Lucu.Parser.Http ( isCtl -- Char -> Bool , isSeparator -- Char -> Bool - , token -- Parser Char + , isChar -- Char -> Bool + , token -- Parser String + , lws -- Parser String + , text -- Parser Char + , separator -- Parser Char + , quotedStr -- Parser String ) where @@ -21,5 +26,41 @@ isSeparator :: Char -> Bool isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t" -token :: Parser Char -token = satisfy (\ c -> not (isCtl c || isSeparator c)) +isChar :: Char -> Bool +isChar c + | c <= '\x7f' = True + | otherwise = False + + +token :: Parser String +token = many1 $ satisfy (\ c -> not (isCtl c || isSeparator c)) + + +lws :: Parser String +lws = do s <- option "" crlf + xs <- many1 (sp <|> ht) + return (s ++ xs) + + +text :: Parser Char +text = satisfy (\ c -> not (isCtl c)) + + +separator :: Parser Char +separator = satisfy isSeparator + + +quotedStr :: Parser String +quotedStr = do char '"' + xs <- many (qdtext <|> quotedPair) + char '"' + return $ foldr (++) "" (["\""] ++ xs ++ ["\""]) + where + qdtext = char '"' >> fail "" + <|> + do c <- text + return [c] + + quotedPair = do q <- char '\\' + c <- satisfy isChar + return [q, c] diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs new file mode 100644 index 0000000..b7b910f --- /dev/null +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -0,0 +1,139 @@ +module Network.HTTP.Lucu.Postprocess + ( postprocess -- Interaction -> STM () + , completeUnconditionalHeaders -- Response -> IO Response + ) + where + +import Control.Concurrent.STM +import Control.Monad +import Data.Char +import Data.Maybe +import GHC.Conc (unsafeIOToSTM) +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.RFC1123DateTime +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils +import System.Time + +{- + + * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。 + + * Content-Length があれば、それを削除する。 + + * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の + 最後の要素が chunked でなければ 500 Internal Error にする。 + Transfer-Encoding が未設定であれば、chunked に設定する。 + + * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server + Error にする。但し identity だけは許す。 + + * body を持つ事が出來る時、Content-Type が無ければ + application/octet-stream にする。出來ない時、HEAD でなければ + Content-Type を削除する。 + + * body を持つ事が出來ない時、body 破棄フラグを立てる。 + + * Connection: close が設定されてゐる時、切斷フラグを立てる。 + + * 切斷フラグが立ってゐる時、Connection: close を設定する。 + + * Server が無ければ設定。 + + * Date が無ければ設定。 + +-} + +{- Postprocess は body を補完した後で實行する事 -} + +postprocess :: Interaction -> STM () +postprocess itr + = do res <- readTVar (itrResponse itr) + + when (res == Nothing) + $ setStatus itr InternalServerError + + when (itrRequest itr /= Nothing) + $ relyOnRequest itr + + do oldRes <- readTVar (itrResponse itr) + newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes + setRes itr newRes + where + relyOnRequest itr + = do resM <- readTVar (itrResponse itr) + + let req = fromJust $ itrRequest itr + reqVer = reqVersion req + res = fromJust resM + status = resStatus res + canHaveBody = if reqMethod req == HEAD then + False + else + isInformational status || + status == NoContent || + status == ResetContent || + status == NotModified + + setRes itr (deleteHeader res "Content-Length") + + if canHaveBody then + do if reqVer == HttpVersion 1 1 then + + case getHeader res "Transfer-Encoding" of + Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked") + Just te -> let teList = [trim isWhiteSpace x + | x <- splitBy (== ',') (map toLower te)] + in + when (teList == [] || last teList /= "chunked") + $ setStatus itr InternalServerError + else + case getHeader res "Transfer-Encoding" of + Nothing -> return () + Just "identity" -> return () + _ -> setStatus itr InternalServerError + + when (getHeader res "Content-Type" == Nothing) + $ setRes itr (setHeader res "Content-Type" "application/octet-stream") + else + -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す + do setRes itr (deleteHeader res "Transfer-Encoding") + when (reqMethod req /= HEAD) + $ setRes itr (deleteHeader res "Content-Type") + + if fmap (map toLower) (getHeader res "Connection") == Just "close" then + writeTVar (itrWillClose itr) True + else + setRes itr (setHeader res "Connection" "close") + + when (reqMethod req == HEAD || not canHaveBody) + $ writeTVar (itrWillDiscardBody itr) True + + setStatus itr status + = writeTVar (itrResponse itr) (Just $ Response { + resVersion = HttpVersion 1 1 + , resStatus = status + , resHeaders = [] + }) + + setRes itr res + = writeTVar (itrResponse itr) (Just res) + + +completeUnconditionalHeaders :: Response -> IO Response +completeUnconditionalHeaders res + = return res >>= compServer >>= compDate >>= return + where + compServer res + = case getHeader res "Server" of + Nothing -> return $ addHeader res "Server" "Lucu/1.0" + Just _ -> return res + + compDate res + = case getHeader res "Date" of + Nothing -> do time <- getClockTime + return $ addHeader res "Date" $ formatHTTPDateTime time + Just _ -> return res \ No newline at end of file diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs new file mode 100644 index 0000000..e8fdfc6 --- /dev/null +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -0,0 +1,122 @@ +module Network.HTTP.Lucu.Preprocess + ( preprocess -- Interaction -> STM () + ) + where + +import Control.Concurrent.STM +import Control.Monad +import Data.Char +import Data.Maybe +import Network.HTTP.Lucu.Headers +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.URI + +{- + + * Expect: に問題があった場合は 417 Expectation Failed に設定。 + 100-continue 以外のものは全部 417 に。 + + * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具 + 体的には、identity でも chunked でもなければ 501 Not Implemented に + する。 + + * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い + 場合には 400 Bad Request にする。 + + * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501 + Not Implemented にする。 + + * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP + Version Not Supported を返す。 + + * POST または PUT に Content-Length も Transfer-Encoding も無い時は、 + 411 Length Required にする。 + + * Content-Length の値が數値でなかったり負だったりしたら 400 Bad + Request にする。 + + * willDiscardBody その他の變數を設定する。 + +-} + +import GHC.Conc (unsafeIOToSTM) + +preprocess :: Interaction -> STM () +preprocess itr + = do let req = fromJust $ itrRequest itr + reqVer = reqVersion req + + if reqVer /= HttpVersion 1 0 && + reqVer /= HttpVersion 1 1 then + + do setStatus itr HttpVersionNotSupported + writeTVar (itrWillClose itr) True + + else + do if reqVer == HttpVersion 1 0 then + -- HTTP/1.0 では Keep-Alive できない + writeTVar (itrWillClose itr) True + else + -- URI または Host: ヘッダのどちらかにホストが無ければ + -- ならない。 + when (uriAuthority (reqURI req) == Nothing && + getHeader req "Host" == Nothing) + $ setStatus itr BadRequest + + case reqMethod req of + GET -> return () + HEAD -> writeTVar (itrWillDiscardBody itr) True + POST -> ensureHavingBody itr + PUT -> ensureHavingBody itr + _ -> setStatus itr NotImplemented + + mapM_ (preprocessHeader itr) (reqHeaders req) + where + ensureHavingBody itr + = let req = fromJust $ itrRequest itr + in + if getHeader req "Content-Length" == Nothing && + getHeader req "Transfer-Encoding" == Nothing then + + setStatus itr LengthRequired + else + writeTVar (itrRequestHasBody itr) True + + setStatus itr status + = writeTVar (itrResponse itr) (Just $ Response { + resVersion = HttpVersion 1 1 + , resStatus = status + , resHeaders = [] + }) + + preprocessHeader itr (name, value) + = case map toLower name of + + "expect" + -> if value `noCaseEq` "100-continue" then + writeTVar (itrExpectedContinue itr) True + else + setStatus itr ExpectationFailed + + "transfer-encoding" + -> case map toLower value of + "identity" -> return () + "chunked" -> writeTVar (itrRequestIsChunked itr) True + _ -> setStatus itr NotImplemented + + "content-length" + -> if all isDigit value then + writeTVar (itrRequestBodyLength itr) (Just $ read value) + else + setStatus itr BadRequest + + "connection" + -> case map toLower value of + "close" -> writeTVar (itrWillClose itr) True + _ -> return () + + _ -> return () \ No newline at end of file diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs new file mode 100644 index 0000000..9c58e51 --- /dev/null +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -0,0 +1,75 @@ +module Network.HTTP.Lucu.RFC1123DateTime + ( formatRFC1123DateTime -- CalendarTime -> String + , formatHTTPDateTime -- ClockTime -> String + , parseHTTPDateTime -- String -> Maybe ClockTime + ) + where + +import Control.Monad +import System.Time +import System.Locale +import Text.ParserCombinators.Parsec +import Text.Printf + +month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] +week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] + +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) + + +formatHTTPDateTime :: ClockTime -> String +formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime + + +parseHTTPDateTime :: String -> Maybe ClockTime +parseHTTPDateTime src + = case parse httpDateTime "" src of + Right ct -> Just ct + Left err -> Nothing + +httpDateTime :: Parser ClockTime +httpDateTime = do foldl (<|>) (unexpected "") (map (try . string) week) + char ',' + char ' ' + day <- liftM read (count 2 digit) + char ' ' + mon <- foldl (<|>) (unexpected "") (map tryEqToFst (zip month [1..])) + char ' ' + year <- liftM read (count 4 digit) + char ' ' + hour <- liftM read (count 2 digit) + char ':' + min <- liftM read (count 2 digit) + char ':' + sec <- liftM read (count 2 digit) + char ' ' + string "GMT" + eof + return $ toClockTime $ CalendarTime { + ctYear = year + , ctMonth = toEnum (mon - 1) + , ctDay = day + , ctHour = hour + , ctMin = min + , ctSec = sec + , ctPicosec = 0 + , ctTZ = 0 + , ctWDay = undefined + , ctYDay = undefined + , ctTZName = undefined + , ctIsDST = undefined + } + where + tryEqToFst :: (String, a) -> Parser a + tryEqToFst (str, a) = try $ string str >> return a + \ No newline at end of file diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 3c235eb..f8b1c93 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,6 +1,6 @@ module Network.HTTP.Lucu.Request ( Method(..) - , Request + , Request(..) , requestP -- Parser Request ) where @@ -16,6 +16,7 @@ import Network.URI data Method = OPTIONS | GET | HEAD + | POST | PUT | DELETE | TRACE @@ -30,9 +31,8 @@ data Request , reqURI :: URI , reqVersion :: HttpVersion , reqHeaders :: Headers - , reqBody :: Maybe ByteString } - deriving (Show) + deriving (Show, Eq) instance HasHeaders Request where getHeaders = reqHeaders @@ -42,14 +42,13 @@ instance HasHeaders Request where requestP :: Parser Request requestP = do many crlf (method, uri, version) <- requestLineP - let req = Request { - reqMethod = method - , reqURI = uri - , reqVersion = version - , reqHeaders = emptyHeaders -- FIXME - , reqBody = Nothing -- FIXME - } - return req + headers <- headersP + return Request { + reqMethod = method + , reqURI = uri + , reqVersion = version + , reqHeaders = headers + } requestLineP :: Parser (Method, URI, HttpVersion) @@ -66,6 +65,7 @@ methodP :: Parser Method methodP = (let methods = [ ("OPTIONS", OPTIONS) , ("GET" , GET ) , ("HEAD" , HEAD ) + , ("POST" , POST ) , ("PUT" , PUT ) , ("DELETE" , DELETE ) , ("TRACE" , TRACE ) @@ -74,7 +74,7 @@ methodP = (let methods = [ ("OPTIONS", OPTIONS) in foldl (<|>) (fail "") $ map (\ (str, mth) -> string str >> return mth) methods) <|> - many1 token >>= return . ExtensionMethod + token >>= return . ExtensionMethod uriP :: Parser URI diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs new file mode 100644 index 0000000..4f63f28 --- /dev/null +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -0,0 +1,128 @@ +module Network.HTTP.Lucu.RequestReader + ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () + ) + where + +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Map as M +import Data.Map (Map) +import Data.Maybe +import qualified Data.Sequence as S +import Data.Sequence (Seq, (<|), ViewR(..)) +import Network +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Preprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Resource +import Prelude hiding (catch) +import System.IO + +import GHC.Conc (unsafeIOToSTM) + +requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () +requestReader cnf tree h host tQueue + = do input <- B.hGetContents h + catch (acceptRequest input) $ \ exc -> + case exc of + IOException _ -> return () + _ -> print exc + where + acceptRequest :: ByteString -> IO () + acceptRequest input + -- キューに最大パイプライン深度以上のリクエストが溜まってゐる + -- 時は、それが限度以下になるまで待つ。 + = do action + <- atomically $ + do queue <- readTVar tQueue + when (S.length queue >= cnfMaxPipelineDepth cnf) + retry + + -- リクエストを讀む。パースできない場合は直ち + -- に 400 Bad Request 應答を設定し、それを出力 + -- してから切斷するやうに ResponseWriter に通 + -- 知する。 + case parse requestP input of + Nothing -> return acceptNonparsableRequest + Just (req, input') -> return $ acceptParsableRequest req input' + action + + acceptNonparsableRequest :: IO () + acceptNonparsableRequest + = do itr <- newInteraction host Nothing + let res = Response { + resVersion = HttpVersion 1 1 + , resStatus = BadRequest + , resHeaders = [] + } + atomically $ do writeTVar (itrResponse itr) $ Just res + writeTVar (itrWillClose itr) True + writeTVar (itrState itr) Done + postprocess itr + enqueue itr + + acceptParsableRequest :: Request -> ByteString -> IO () + acceptParsableRequest req input' + = do itr <- newInteraction host (Just req) + action + <- atomically $ + do preprocess itr + res <- readTVar (itrResponse itr) + if fmap isError (fmap resStatus res) == Just True then + acceptSemanticallyInvalidRequest itr input' + else + case findResource tree $ (reqURI . fromJust . itrRequest) itr of + Nothing -- Resource が無かった + -> acceptRequestForNonexistentResource itr input' + + Just rsrcDef -- あった + -> acceptRequestForExistentResource itr input' rsrcDef + action + + acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) + acceptSemanticallyInvalidRequest itr input + = do writeTVar (itrState itr) Done + postprocess itr + enqueue itr + return $ acceptRequest input + + acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) + acceptRequestForNonexistentResource itr input + = do let res = Response { + resVersion = HttpVersion 1 1 + , resStatus = NotFound + , resHeaders = [] + } + writeTVar (itrResponse itr) $ Just res + writeTVar (itrState itr) Done + postprocess itr + enqueue itr + return $ acceptRequest input + + acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) + acceptRequestForExistentResource itr input rsrcDef + = do requestHasBody <- readTVar (itrRequestHasBody itr) + writeTVar (itrState itr) (if requestHasBody + then ExaminingHeader + else DecidingHeader) + enqueue itr + return $ do runResource rsrcDef itr + if requestHasBody then + observeRequest itr input + else + acceptRequest input + + observeRequest :: Interaction -> ByteString -> IO () + observeRequest itr input = fail "FIXME: Not Implemented" + + enqueue :: Interaction -> STM () + enqueue itr = do queue <- readTVar tQueue + writeTVar tQueue (itr <| queue) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index bc4bf33..2e4d46e 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,14 +1,109 @@ module Network.HTTP.Lucu.Resource - ( Resource + ( ResourceDef(..) + , Resource + , ResTree + , mkResTree -- [ ([String], ResourceDef) ] -> ResTree + , findResource -- ResTree -> URI -> Maybe ResourceDef + , runResource -- ResourceDef -> Interaction -> IO ThreadId ) where -import Control.Monad.State +import Control.Concurrent +import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) +import Data.List +import qualified Data.Map as M +import Data.Map (Map) +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Utils +import Network.URI -data ResState = ResState -- FIXME -type ResourceT m a = StateT ResState m a +type Resource a = ReaderT Interaction IO a -type Resource a = ResourceT IO a + +{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ + れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず + /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視 + される。 -} +data ResourceDef = ResourceDef { + resUsesNativeThread :: Bool + , resIsGreedy :: Bool + , resResource :: Resource () + } +type ResTree = ResNode -- root だから Map ではない +type ResSubtree = Map String ResNode +data ResNode = ResNode (Maybe ResourceDef) ResSubtree + + +mkResTree :: [ ([String], ResourceDef) ] -> ResTree +mkResTree list = processRoot list + where + processRoot :: [ ([String], ResourceDef) ] -> ResTree + processRoot list + = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list + children = processNonRoot nonRoots + in + if null roots then + -- / にリソースが定義されない。/foo とかにはあるかも。 + ResNode Nothing children + else + -- / がある。 + let (_, def) = last roots + in + ResNode (Just def) children + + processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree + processNonRoot list + = let subtree = M.fromList [(name, node name) + | name <- childNames] + childNames = [name | (name:_, _) <- list] + node name = let defs = [def | (path, def) <- list, path == [name]] + in + if null defs then + -- この位置にリソースが定義されない。 + -- もっと下にはあるかも。 + ResNode Nothing children + else + -- この位置にリソースがある。 + ResNode (Just $ last defs) children + children = processNonRoot [(path, def) + | (_:path, def) <- list, not (null path)] + in + subtree + + +findResource :: ResTree -> URI -> Maybe ResourceDef +findResource (ResNode rootDefM subtree) uri + = let pathStr = uriPath uri + path = [x | x <- splitBy (== '/') pathStr, x /= ""] + in + if null path then + rootDefM + else + walkTree subtree path + where + walkTree :: ResSubtree -> [String] -> Maybe ResourceDef + + walkTree subtree (name:[]) + = case M.lookup name subtree of + Nothing -> Nothing + Just (ResNode defM _) -> defM + + walkTree subtree (x:xs) + = case M.lookup x subtree of + Nothing -> Nothing + Just (ResNode defM children) -> case defM of + Just (ResourceDef { resIsGreedy = True }) + -> defM + _ -> walkTree children xs + + +runResource :: ResourceDef -> Interaction -> IO ThreadId +runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch + where + fork = if (resUsesNativeThread def) + then forkOS + else forkIO + rsrc = resResource def \ No newline at end of file diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index e61a6a5..0e6fbe2 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,13 +1,16 @@ module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) + , hPutResponse -- Handle -> Response -> IO () + , isInformational -- StatusCode -> Bool + , isError -- StatusCode -> Bool ) where -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion +import System.IO +import Text.Printf data StatusCode = Continue | SwitchingProtocols @@ -59,14 +62,96 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage + deriving (Eq) + +instance Show StatusCode where + show sc = let (num, msg) = statusCode sc + in + printf "%03d %s" num msg + data Response = Response { resVersion :: HttpVersion , resStatus :: StatusCode , resHeaders :: Headers - , resBody :: Maybe ByteString } + deriving (Show, Eq) instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } + + +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) + +hPutStatus :: Handle -> StatusCode -> IO () +hPutStatus h sc = let (num, msg) = statusCode sc + in + hPrintf h "%03d %s" num msg + + +isInformational :: StatusCode -> Bool +isInformational sc = let (num, _) = statusCode sc + in num < 200 + +isError :: StatusCode -> Bool +isError sc = let (num, _) = statusCode sc + in num >= 400 + + +statusCode :: StatusCode -> (Int, String) +statusCode Continue = (100, "Continue") +statusCode SwitchingProtocols = (101, "Switching Protocols") +statusCode Processing = (102, "Processing") +-- +statusCode Ok = (200, "OK") +statusCode Created = (201, "Created") +statusCode Accepted = (202, "Accepted") +statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information") +statusCode NoContent = (204, "No Content") +statusCode ResetContent = (205, "Reset Content") +statusCode PartialContent = (206, "Partial Content") +statusCode MultiStatus = (207, "Multi Status") +-- +statusCode MultipleChoices = (300, "Multiple Choices") +statusCode MovedPermanently = (301, "Moved Permanently") +statusCode Found = (302, "Found") +statusCode SeeOther = (303, "See Other") +statusCode NotModified = (304, "Not Modified") +statusCode UseProxy = (305, "Use Proxy") +statusCode TemporaryRedirect = (306, "Temporary Redirect") +-- +statusCode BadRequest = (400, "Bad Request") +statusCode Unauthorized = (401, "Unauthorized") +statusCode PaymentRequired = (402, "Payment Required") +statusCode Forbidden = (403, "Forbidden") +statusCode NotFound = (404, "Not Found") +statusCode MethodNotAllowed = (405, "Method Not Allowed") +statusCode NotAcceptable = (406, "Not Acceptable") +statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required") +statusCode RequestTimeout = (408, "Request Timeout") +statusCode Conflict = (409, "Conflict") +statusCode Gone = (410, "Gone") +statusCode LengthRequired = (411, "Length Required") +statusCode PreconditionFailed = (412, "Precondition Failed") +statusCode RequestEntityTooLarge = (413, "Request Entity Too Large") +statusCode RequestURITooLarge = (414, "Request URI Too Large") +statusCode UnsupportedMediaType = (415, "Unsupported Media Type") +statusCode RequestRangeNotSatisfiable = (416, "Request Range Not Satisfiable") +statusCode ExpectationFailed = (417, "Expectation Failed") +statusCode UnprocessableEntitiy = (422, "Unprocessable Entity") +statusCode Locked = (423, "Locked") +statusCode FailedDependency = (424, "Failed Dependency") +-- +statusCode InternalServerError = (500, "Internal Server Error") +statusCode NotImplemented = (501, "Not Implemented") +statusCode BadGateway = (502, "Bad Gateway") +statusCode ServiceUnavailable = (503, "Service Unavailable") +statusCode GatewayTimeout = (504, "Gateway Timeout") +statusCode HttpVersionNotSupported = (505, "HTTP Version Not Supported") +statusCode InsufficientStorage = (507, "Insufficient Storage") \ No newline at end of file diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs new file mode 100644 index 0000000..f874478 --- /dev/null +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -0,0 +1,119 @@ +module Network.HTTP.Lucu.ResponseWriter + ( responseWriter -- Handle -> InteractionQueue -> IO () + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.Maybe +import qualified Data.Sequence as S +import Data.Sequence (Seq, ViewR(..)) +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Response +import Prelude hiding (catch) +import System.IO + +import Debug.Trace + + +responseWriter :: Handle -> InteractionQueue -> IO () +responseWriter h tQueue + = catch awaitSomethingToWrite $ \ exc + -> case exc of + IOException _ -> return () + _ -> print exc + where + awaitSomethingToWrite :: IO () + awaitSomethingToWrite + = do action + <- atomically $ + do -- キューが空でなくなるまで待つ + queue <- readTVar tQueue + when (S.null queue) + retry + let _ :> itr = S.viewr queue + + -- GettingBody 状態にあり、Continue が期待され + -- てゐて、それがまだ送信前なのであれば、 + -- Continue を送信する。 + state <- readTVar (itrState itr) + + if state == GettingBody then + writeContinueIfNecessary itr + else + if state >= DecidingBody then + writeHeaderOrBodyIfNecessary itr + else + retry + action + + writeContinueIfNecessary :: Interaction -> STM (IO ()) + writeContinueIfNecessary itr + = do expectedContinue <- readTVar (itrExpectedContinue itr) + if expectedContinue then + + do wroteContinue <- readTVar $ itrWroteContinue itr + if wroteContinue then + -- 既に Continue を書込み濟 + retry + else + return $ writeContinue itr + else + retry + + writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) + writeHeaderOrBodyIfNecessary itr + -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ + -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が + -- 空でなければ、それを出力する。空である時は、もし状態が + -- Done であれば後処理をする。 + = do wroteHeader <- readTVar (itrWroteHeader itr) + + if not wroteHeader then + return $ writeHeader itr + else + do bodyToSend <- readTVar (itrBodyToSend itr) + + if B.null bodyToSend then + do state <- readTVar (itrState itr) + + if state == Done then + return $ finalize itr + else + retry + else + return $ writeBodyChunk itr + + writeContinue :: Interaction -> IO () + writeContinue itr = fail "FIXME: not implemented" + + writeHeader :: Interaction -> IO () + writeHeader itr + = do res <- atomically $ do writeTVar (itrWroteHeader itr) True + readTVar (itrResponse itr) + hPutResponse h (fromJust res) + hFlush h + awaitSomethingToWrite + + writeBodyChunk :: Interaction -> IO () + writeBodyChunk itr = fail "FIXME: not implemented" + + finishBodyChunk :: Interaction -> IO () + finishBodyChunk itr = return () -- FIXME: not implemented + + finalize :: Interaction -> IO () + finalize itr + = do finishBodyChunk itr + willClose <- atomically $ do queue <- readTVar tQueue + + let (remaining :> _) = S.viewr queue + writeTVar tQueue remaining + + readTVar $ itrWillClose itr + if willClose then + hClose h + else + awaitSomethingToWrite diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs new file mode 100644 index 0000000..7d6eeeb --- /dev/null +++ b/Network/HTTP/Lucu/Utils.hs @@ -0,0 +1,33 @@ +module Network.HTTP.Lucu.Utils + ( splitBy -- (a -> Bool) -> [a] -> [[a]] + , trim -- (a -> Bool) -> [a] -> [a] + , noCaseEq -- String -> String -> Bool + , isWhiteSpace -- Char -> Bool + ) + where + +import Data.Char +import Data.List + + +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy isSeparator src + = case break isSeparator src + of (last , [] ) -> last : [] + (first, sep:rest) -> first : splitBy isSeparator rest + + +trim :: (a -> Bool) -> [a] -> [a] +trim p = trimTail . trimHead + where + trimHead = dropWhile p + trimTail = reverse . trimHead . reverse + + +noCaseEq :: String -> String -> Bool +noCaseEq a b + = (map toLower a) == (map toLower b) + + +isWhiteSpace :: Char -> Bool +isWhiteSpace = flip elem " \t\r\n" diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 52ceceb..d5b8d70 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,9 +1,10 @@ import Network import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Httpd +import Network.HTTP.Lucu.Resource main :: IO () main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } - resources = mkResourceTable [] + resources = mkResTree [] in runHttpd config resources \ No newline at end of file