From a9e9f50818285bf66cd64e5a248175eecb8e1fea Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 30 Mar 2007 02:07:37 +0900 Subject: [PATCH] Many improvements darcs-hash:20070329170737-62b54-579f6ccd572071a80b261e371878ce60c402b9b7.gz --- Lucu.cabal | 2 +- Makefile | 22 ++++++++ Network/HTTP/Lucu/DefaultPage.hs | 88 +++++++++++++++++++++++++++++ Network/HTTP/Lucu/Headers.hs | 16 +++--- Network/HTTP/Lucu/Interaction.hs | 32 +++++++++++ Network/HTTP/Lucu/Postprocess.hs | 83 +++++++++++++++------------ Network/HTTP/Lucu/Preprocess.hs | 32 +++++------ Network/HTTP/Lucu/RequestReader.hs | 28 +++++---- Network/HTTP/Lucu/Response.hs | 1 + Network/HTTP/Lucu/ResponseWriter.hs | 37 +++++++----- 10 files changed, 254 insertions(+), 87 deletions(-) create mode 100644 Makefile create mode 100644 Network/HTTP/Lucu/DefaultPage.hs diff --git a/Lucu.cabal b/Lucu.cabal index 121740b..0667795 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, stm, parsec + base, mtl, network, stm, parsec, hxt Exposed-Modules: Network.HTTP.Lucu.Config Network.HTTP.Lucu.Headers diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..80beeeb --- /dev/null +++ b/Makefile @@ -0,0 +1,22 @@ +CABAL_FILE = Lucu.cabal +GHC = ghc +WHAT_TO_RUN = ./dist/build/HelloWorld/HelloWorld + +run: build + @echo ".:.:. Let's go .:.:." + $(WHAT_TO_RUN) + +build: .setup-config Setup + ./Setup build + +.setup-config: $(CABAL_FILE) Setup + ./Setup configure + +Setup: Setup.hs + $(GHC) --make Setup + +clean: + rm -rf dist Setup Setup.o Setup.hi .setup-config + find . -name '*~' -exec rm -f {} \; + +.PHONY: run build clean \ No newline at end of file diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs new file mode 100644 index 0000000..8c30315 --- /dev/null +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -0,0 +1,88 @@ +module Network.HTTP.Lucu.DefaultPage + ( getDefaultPage -- Maybe Request -> Response -> String + , writeDefaultPage -- Interaction -> STM () + ) + where + +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Concurrent.STM +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Maybe +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +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 +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.DOM.XmlKeywords + + +getDefaultPage :: Maybe Request -> Response -> String +getDefaultPage req res + = let msgA = getMsg req res + in + unsafePerformIO $ + do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA + >>> + writeDocumentToString [ (a_indent, v_1) ] + ) + return xmlStr + + +writeDefaultPage :: Interaction -> STM () +writeDefaultPage itr + = do wroteHeader <- readTVar (itrWroteHeader itr) + + -- ヘッダが出力濟だったら意味が無い。 + when wroteHeader + $ fail "writeDefaultPage: the header has already been written" + + resM <- readTVar (itrResponse itr) + + -- Response が不明ならばページ書込も不可 + when (resM == Nothing) + $ fail "writeDefaultPage: response was Nothing" + + let reqM = itrRequest itr + res = fromJust resM + page = B.pack $ getDefaultPage reqM res + + writeTVar (itrResponse itr) + $ Just $ setHeader "Content-Type" "application/xhtml+xml" res + + writeTVar (itrBodyToSend itr) + $ page + + +mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree +mkDefaultPage status msgA + = let (sCode, sMsg) = statusCode status + in ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt (printf "%03d %s" sCode sMsg) + )) + += ( eelem "body" + += ( eelem "h1" + += txt sMsg + ) + += ( msgA + >>> + eelem "p" += ( this + >>> + mkText + ))))) + + +getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String +getMsg req res + = constA "FIXME: NOT IMPL" diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 655252c..7936f04 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -20,20 +20,20 @@ class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a - getHeader :: a -> String -> Maybe String - getHeader a key + getHeader :: String -> a -> Maybe String + getHeader key a = fmap snd $ find (noCaseEq key . fst) (getHeaders a) - deleteHeader :: a -> String -> a - deleteHeader a key + deleteHeader :: String -> a -> a + deleteHeader key a = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a) - addHeader :: a -> String -> String -> a - addHeader a key val + addHeader :: String -> String -> a -> a + addHeader key val a = setHeaders a $ (getHeaders a) ++ [(key, val)] - setHeader :: a -> String -> String -> a - setHeader a key val + setHeader :: String -> String -> a -> a + setHeader key val a = let list = getHeaders a deleted = filter (not . noCaseEq key . fst) list added = deleted ++ [(key, val)] diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 44f4243..6b872ca 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -4,6 +4,12 @@ module Network.HTTP.Lucu.Interaction , InteractionQueue , newInteractionQueue -- IO InteractionQueue , newInteraction -- HostName -> Maybe Request -> IO Interaction + + , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM () + , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b + , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) + , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () + , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () ) where @@ -99,3 +105,29 @@ newInteraction host req , itrWroteContinue = wroteContinue , itrWroteHeader = wroteHeader } + + +writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () +writeItr itr accessor value + = writeTVar (accessor itr) value + + +readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b +readItr itr accessor reader + = readTVar (accessor itr) >>= return . reader + + +readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) +readItrF itr accessor reader + = readItr itr accessor (fmap reader) + + +updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () +updateItr itr accessor updator + = do old <- readItr itr accessor id + writeItr itr accessor (updator old) + + +updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () +updateItrF itr accessor updator + = updateItr itr accessor (fmap updator) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index b7b910f..929413c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -51,7 +51,7 @@ import System.Time postprocess :: Interaction -> STM () postprocess itr - = do res <- readTVar (itrResponse itr) + = do res <- readItr itr itrResponse id when (res == Nothing) $ setStatus itr InternalServerError @@ -59,59 +59,62 @@ postprocess itr when (itrRequest itr /= Nothing) $ relyOnRequest itr - do oldRes <- readTVar (itrResponse itr) + do oldRes <- readItr itr itrResponse id newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes - setRes itr newRes + writeItr itr itrResponse $ Just newRes where relyOnRequest itr - = do resM <- readTVar (itrResponse itr) + = do status <- readItr itr itrResponse (resStatus . fromJust) 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 + not (isInformational status || + status == NoContent || + status == ResetContent || + status == NotModified ) - setRes itr (deleteHeader res "Content-Length") + updateRes itr $ deleteHeader "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 + do teM <- readHeader itr "Transfer-Encoding" + if reqVer == HttpVersion 1 1 then + + do case teM of + Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked" + Just te -> let teList = [trim isWhiteSpace x + | x <- splitBy (== ',') (map toLower te)] + in + when (teList == [] || last teList /= "chunked") + $ setStatus itr InternalServerError + + writeItr itr itrWillChunkBody True else - case getHeader res "Transfer-Encoding" of + case fmap (map toLower) teM of Nothing -> return () Just "identity" -> return () _ -> setStatus itr InternalServerError - - when (getHeader res "Content-Type" == Nothing) - $ setRes itr (setHeader res "Content-Type" "application/octet-stream") + + cType <- readHeader itr "Content-Type" + when (cType == Nothing) + $ updateRes itr $ setHeader "Content-Type" "application/octet-stream" else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - do setRes itr (deleteHeader res "Transfer-Encoding") + do updateRes itr $ deleteHeader "Transfer-Encoding" when (reqMethod req /= HEAD) - $ setRes itr (deleteHeader res "Content-Type") + $ updateRes itr $ deleteHeader "Content-Type" - if fmap (map toLower) (getHeader res "Connection") == Just "close" then - writeTVar (itrWillClose itr) True - else - setRes itr (setHeader res "Connection" "close") + conn <- readHeader itr "Connection" + case fmap (map toLower) conn of + Just "close" -> writeItr itr itrWillClose True + _ -> updateRes itr $ setHeader "Connection" "close" when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True + setStatus :: Interaction -> StatusCode -> STM () setStatus itr status = writeTVar (itrResponse itr) (Just $ Response { resVersion = HttpVersion 1 1 @@ -119,8 +122,16 @@ postprocess itr , resHeaders = [] }) - setRes itr res - = writeTVar (itrResponse itr) (Just res) + readHeader :: Interaction -> String -> STM (Maybe String) + readHeader itr name + = do valueMM <- readItrF itr itrResponse $ getHeader name + case valueMM of + Just (Just val) -> return $ Just val + _ -> return Nothing + + updateRes :: Interaction -> (Response -> Response) -> STM () + updateRes itr updator + = updateItrF itr itrResponse updator completeUnconditionalHeaders :: Response -> IO Response @@ -128,12 +139,12 @@ completeUnconditionalHeaders res = return res >>= compServer >>= compDate >>= return where compServer res - = case getHeader res "Server" of - Nothing -> return $ addHeader res "Server" "Lucu/1.0" + = case getHeader "Server" res of + Nothing -> return $ addHeader "Server" "Lucu/1.0" res Just _ -> return res compDate res - = case getHeader res "Date" of + = case getHeader "Date" res of Nothing -> do time <- getClockTime - return $ addHeader res "Date" $ formatHTTPDateTime time + return $ addHeader "Date" (formatHTTPDateTime time) res Just _ -> return res \ No newline at end of file diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index e8fdfc6..3552e48 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -54,22 +54,22 @@ preprocess itr reqVer /= HttpVersion 1 1 then do setStatus itr HttpVersionNotSupported - writeTVar (itrWillClose itr) True + writeItr itr itrWillClose True else do if reqVer == HttpVersion 1 0 then -- HTTP/1.0 では Keep-Alive できない - writeTVar (itrWillClose itr) True + writeItr itr itrWillClose True else -- URI または Host: ヘッダのどちらかにホストが無ければ -- ならない。 when (uriAuthority (reqURI req) == Nothing && - getHeader req "Host" == Nothing) + getHeader "Host" req == Nothing) $ setStatus itr BadRequest case reqMethod req of GET -> return () - HEAD -> writeTVar (itrWillDiscardBody itr) True + HEAD -> writeItr itr itrWillDiscardBody True POST -> ensureHavingBody itr PUT -> ensureHavingBody itr _ -> setStatus itr NotImplemented @@ -79,44 +79,44 @@ preprocess itr ensureHavingBody itr = let req = fromJust $ itrRequest itr in - if getHeader req "Content-Length" == Nothing && - getHeader req "Transfer-Encoding" == Nothing then + if getHeader "Content-Length" req == Nothing && + getHeader "Transfer-Encoding" req == Nothing then setStatus itr LengthRequired else - writeTVar (itrRequestHasBody itr) True + writeItr itr itrRequestHasBody True setStatus itr status - = writeTVar (itrResponse itr) (Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - }) + = writeItr itr itrResponse $ 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 + writeItr itr itrExpectedContinue True else setStatus itr ExpectationFailed "transfer-encoding" -> case map toLower value of "identity" -> return () - "chunked" -> writeTVar (itrRequestIsChunked itr) True + "chunked" -> writeItr itr itrRequestIsChunked True _ -> setStatus itr NotImplemented "content-length" -> if all isDigit value then - writeTVar (itrRequestBodyLength itr) (Just $ read value) + writeItr itr itrRequestBodyLength $ Just $ read value else setStatus itr BadRequest "connection" -> case map toLower value of - "close" -> writeTVar (itrWillClose itr) True + "close" -> writeItr itr itrWillClose True _ -> return () _ -> return () \ No newline at end of file diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 4f63f28..12cad20 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -15,6 +15,7 @@ import qualified Data.Sequence as S import Data.Sequence (Seq, (<|), ViewR(..)) import Network import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser @@ -63,9 +64,10 @@ requestReader cnf tree h host tQueue , resStatus = BadRequest , resHeaders = [] } - atomically $ do writeTVar (itrResponse itr) $ Just res - writeTVar (itrWillClose itr) True - writeTVar (itrState itr) Done + atomically $ do writeItr itr itrResponse $ Just res + writeItr itr itrWillClose True + writeItr itr itrState Done + writeDefaultPage itr postprocess itr enqueue itr @@ -75,8 +77,8 @@ requestReader cnf tree h host tQueue action <- atomically $ do preprocess itr - res <- readTVar (itrResponse itr) - if fmap isError (fmap resStatus res) == Just True then + isErr <- readItrF itr itrResponse (isError . resStatus) + if isErr == Just True then acceptSemanticallyInvalidRequest itr input' else case findResource tree $ (reqURI . fromJust . itrRequest) itr of @@ -89,7 +91,8 @@ requestReader cnf tree h host tQueue acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input - = do writeTVar (itrState itr) Done + = do writeItr itr itrState Done + writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input @@ -101,18 +104,19 @@ requestReader cnf tree h host tQueue , resStatus = NotFound , resHeaders = [] } - writeTVar (itrResponse itr) $ Just res - writeTVar (itrState itr) Done + writeItr itr itrResponse $ Just res + writeItr itr itrState Done + writeDefaultPage itr 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) + = do requestHasBody <- readItr itr itrRequestHasBody id + writeItr itr itrState (if requestHasBody + then ExaminingHeader + else DecidingHeader) enqueue itr return $ do runResource rsrcDef itr if requestHasBody then diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 0e6fbe2..1c19da4 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -4,6 +4,7 @@ module Network.HTTP.Lucu.Response , hPutResponse -- Handle -> Response -> IO () , isInformational -- StatusCode -> Bool , isError -- StatusCode -> Bool + , statusCode -- StatusCode -> (Int, String) ) where diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index f874478..f47e1f0 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -21,10 +21,7 @@ import Debug.Trace responseWriter :: Handle -> InteractionQueue -> IO () responseWriter h tQueue - = catch awaitSomethingToWrite $ \ exc - -> case exc of - IOException _ -> return () - _ -> print exc + = awaitSomethingToWrite where awaitSomethingToWrite :: IO () awaitSomethingToWrite @@ -39,7 +36,7 @@ responseWriter h tQueue -- GettingBody 状態にあり、Continue が期待され -- てゐて、それがまだ送信前なのであれば、 -- Continue を送信する。 - state <- readTVar (itrState itr) + state <- readItr itr itrState id if state == GettingBody then writeContinueIfNecessary itr @@ -52,10 +49,10 @@ responseWriter h tQueue writeContinueIfNecessary :: Interaction -> STM (IO ()) writeContinueIfNecessary itr - = do expectedContinue <- readTVar (itrExpectedContinue itr) + = do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then - do wroteContinue <- readTVar $ itrWroteContinue itr + do wroteContinue <- readItr itr itrWroteContinue id if wroteContinue then -- 既に Continue を書込み濟 retry @@ -70,15 +67,15 @@ responseWriter h tQueue -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 - = do wroteHeader <- readTVar (itrWroteHeader itr) + = do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then return $ writeHeader itr else - do bodyToSend <- readTVar (itrBodyToSend itr) + do bodyToSend <- readItr itr itrBodyToSend id if B.null bodyToSend then - do state <- readTVar (itrState itr) + do state <- readItr itr itrState id if state == Done then return $ finalize itr @@ -92,14 +89,26 @@ responseWriter h tQueue writeHeader :: Interaction -> IO () writeHeader itr - = do res <- atomically $ do writeTVar (itrWroteHeader itr) True - readTVar (itrResponse itr) + = do res <- atomically $ do writeItr itr itrWroteHeader True + readItr itr itrResponse id hPutResponse h (fromJust res) hFlush h awaitSomethingToWrite writeBodyChunk :: Interaction -> IO () - writeBodyChunk itr = fail "FIXME: not implemented" + 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 + unless willDiscardBody + $ do if willChunkBody then + fail "FIXME: not implemented" + else + B.hPut h chunk + hFlush h + awaitSomethingToWrite finishBodyChunk :: Interaction -> IO () finishBodyChunk itr = return () -- FIXME: not implemented @@ -112,7 +121,7 @@ responseWriter h tQueue let (remaining :> _) = S.viewr queue writeTVar tQueue remaining - readTVar $ itrWillClose itr + readItr itr itrWillClose id if willClose then hClose h else -- 2.40.0