From cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 5 Oct 2011 01:44:07 +0900 Subject: [PATCH] ResponseWriter now compiles. Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/DefaultPage.hs | 4 +- Network/HTTP/Lucu/HandleLike.hs | 10 +- Network/HTTP/Lucu/Interaction.hs | 9 +- Network/HTTP/Lucu/Postprocess.hs | 19 +- Network/HTTP/Lucu/Resource.hs | 28 +-- Network/HTTP/Lucu/Resource/Tree.hs | 6 +- Network/HTTP/Lucu/ResponseWriter.hs | 279 ++++++++++++++-------------- 7 files changed, 182 insertions(+), 173 deletions(-) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 360a268..1e5a7a6 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -47,9 +47,9 @@ getDefaultPage !conf !req !res writeDefaultPage ∷ Interaction → STM () writeDefaultPage !itr -- Content-Type が正しくなければ補完できない。 - = do res ← readItr itrResponse id itr + = do res ← readItr itrResponse itr when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do reqM ← readItr itrRequest id itr + $ do reqM ← readItr itrRequest itr let conf = itrConfig itr page = getDefaultPage conf reqM res diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs index f58264d..f38fa5b 100644 --- a/Network/HTTP/Lucu/HandleLike.hs +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -3,12 +3,16 @@ #-} module Network.HTTP.Lucu.HandleLike ( HandleLike(..) + , hPutBuilder ) where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as L import qualified OpenSSL.Session as SSL import OpenSSL.X509 +import Prelude.Unicode import qualified System.IO as I class HandleLike h where @@ -50,5 +54,9 @@ instance HandleLike SSL.SSL where else return Nothing - hFlush _ = return () -- unneeded + hFlush _ = return () -- No need to do anything. hClose s = SSL.shutdown s SSL.Bidirectional + +hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO () +{-# INLINE hPutBuilder #-} +hPutBuilder = BB.toByteStringIO ∘ hPutBS diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 46e32a1..1c2679c 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -17,7 +17,6 @@ module Network.HTTP.Lucu.Interaction ) where import Blaze.ByteString.Builder (Builder) -import Control.Applicative import Control.Concurrent.STM import Data.Ascii (Ascii) import qualified Data.ByteString as BS @@ -168,13 +167,13 @@ writeItr ∷ (Interaction → TVar a) → a → Interaction → STM () writeItr accessor a itr = writeTVar (accessor itr) a -readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b +readItr ∷ (Interaction → TVar a) → Interaction → STM a {-# INLINE readItr #-} -readItr accessor reader itr - = reader <$> readTVar (accessor itr) +readItr accessor itr + = readTVar (accessor itr) updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM () {-# INLINE updateItr #-} updateItr accessor updator itr - = do old ← readItr accessor id itr + = do old ← readItr accessor itr writeItr accessor (updator old) itr diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 0e089ca..1a00b00 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - BangPatterns - , DoAndIfThenElse + DoAndIfThenElse , OverloadedStrings , UnicodeSyntax #-} @@ -63,9 +62,9 @@ import Prelude.Unicode -} postprocess ∷ Interaction → STM () -postprocess !itr - = do reqM ← readItr itrRequest id itr - res ← readItr itrResponse id itr +postprocess itr + = do reqM ← readItr itrRequest itr + res ← readItr itrResponse itr let sc = resStatus res unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) @@ -98,15 +97,15 @@ postprocess !itr -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes ← readItr itrResponse id itr + do oldRes ← readItr itrResponse itr newRes ← unsafeIOToSTM $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itrResponse newRes itr where relyOnRequest ∷ STM () relyOnRequest - = do status ← readItr itrResponse resStatus itr - req ← readItr itrRequest fromJust itr + = do status ← resStatus <$> readItr itrResponse itr + req ← fromJust <$> readItr itrRequest itr let reqVer = reqVersion req canHaveBody = if reqMethod req ≡ HEAD then @@ -141,7 +140,7 @@ postprocess !itr Just value → when (A.toCIAscii value ≡ "close") $ writeItr itrWillClose True itr - willClose ← readItr itrWillClose id itr + willClose ← readItr itrWillClose itr when willClose $ updateRes $ setHeader "Connection" "close" @@ -150,7 +149,7 @@ postprocess !itr readHeader ∷ CIAscii → STM (Maybe Ascii) {-# INLINE readHeader #-} - readHeader k = readItr itrResponse (getHeader k) itr + readHeader k = getHeader k <$> readItr itrResponse itr updateRes ∷ (Response → Response) → STM () {-# INLINE updateRes #-} diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index c8ca45d..0dd73c9 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -239,7 +239,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction getRequest ∷ Resource Request getRequest = do itr ← getInteraction - liftIO $ atomically $ readItr itrRequest fromJust itr + liftIO $ atomically $ fromJust <$> readItr itrRequest itr -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -609,7 +609,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -628,7 +628,7 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength id itr + $ do chunkLen ← readItr itrReqChunkLength itr writeItr itrWillReceiveBody True itr if ((> actualLimit) <$> chunkLen) ≡ Just True then -- 受信前から多過ぎる事が分かってゐる @@ -637,8 +637,8 @@ input limit writeItr itrReqBodyWanted (Just actualLimit) itr -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr - chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkLen ← readItr itrReceivedBodyLen itr + chunkIsOver ← readItr itrReqChunkIsOver itr if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 @@ -651,7 +651,7 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - chunk ← readItr itrReceivedBody seqToLBS itr + chunk ← seqToLBS <$> readItr itrReceivedBody itr writeItr itrReceivedBody (∅) itr writeItr itrReceivedBodyLen 0 itr return chunk @@ -684,7 +684,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -707,15 +707,15 @@ inputChunk limit writeItr itrWillReceiveBody True itr -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr + $ do chunkLen ← readItr itrReceivedBodyLen itr -- 要求された量に滿たなくて、まだ殘りがある -- なら再試行。 when (chunkLen < actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkIsOver ← readItr itrReqChunkIsOver itr unless chunkIsOver $ retry -- 成功 - chunk ← readItr itrReceivedBody seqToLBS itr + chunk ← seqToLBS <$> readItr itrReceivedBody itr writeItr itrReceivedBody (∅) itr writeItr itrReceivedBodyLen 0 itr return chunk @@ -906,7 +906,7 @@ outputChunk wholeChunk (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody id itr + readItr itrWillDiscardBody itr unless (discardBody) $ sendChunks wholeChunk limit @@ -949,7 +949,7 @@ outputChunk wholeChunk driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState id itr + liftIO $ atomically $ do oldState ← readItr itrState itr if newState < oldState then throwStateError oldState newState else @@ -977,9 +977,9 @@ driftTo newState = postprocess itr drift itr _ Done - = do bodyIsNull ← readItr itrSentNoBody id itr + = do bodyIsNull ← readItr itrSentNoBody itr when bodyIsNull - $ writeDefaultPage itr + $ writeDefaultPage itr drift _ _ _ = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index b457072..d386bce 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -292,9 +292,9 @@ runResource def itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 - state ← atomically $ readItr itrState id itr - reqM ← atomically $ readItr itrRequest id itr - res ← atomically $ readItr itrResponse id itr + state ← atomically $ readItr itrState itr + reqM ← atomically $ readItr itrRequest itr + res ← atomically $ readItr itrResponse itr if state ≤ DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 9751a76..7382071 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,171 +1,174 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.ResponseWriter ( responseWriter ) where - -import qualified Data.ByteString.Lazy.Char8 as C8 +import qualified Blaze.ByteString.Builder.HTTP as BB +import qualified Data.Ascii as A import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude hiding (catch) -import System.IO (stderr) +import Prelude.Unicode +import System.IO (hPutStrLn, stderr) +data Context h + = Context { + cConfig ∷ !Config + , cHandle ∷ !h + , cQueue ∷ !InteractionQueue + , cReader ∷ !ThreadId + } -responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO () -responseWriter !cnf !h !tQueue !readerTID - = awaitSomethingToWrite +responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () +responseWriter cnf h tQueue readerTID + = awaitSomethingToWrite (Context cnf h tQueue readerTID) `catches` - [ Handler (( \ _ -> return () ) :: IOException -> IO ()) - , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) - , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + [ Handler $ \ (_ ∷ IOException) → return () + , Handler $ \ e → case e of + ThreadKilled → return () + _ → hPutStrLn stderr (show e) + , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely" + , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e) ] - where - awaitSomethingToWrite :: IO () - awaitSomethingToWrite - = {-# SCC "awaitSomethingToWrite" #-} - join $! - atomically $! - -- キューが空でなくなるまで待つ - do queue <- readTVar tQueue - -- GettingBody 状態にあり、Continue が期待されてゐ - -- て、それがまだ送信前なのであれば、Continue を送 - -- 信する。 - case S.viewr queue of - EmptyR -> retry - _ :> itr -> do state <- readItr itr itrState id - - if state == GettingBody then - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry - writeContinueIfNecessary :: Interaction -> STM (IO ()) - writeContinueIfNecessary !itr - = {-# SCC "writeContinueIfNecessary" #-} - do expectedContinue <- readItr itr itrExpectedContinue id - if expectedContinue then - do wroteContinue <- readItr itr itrWroteContinue id - if wroteContinue then - -- 既に Continue を書込み濟 - retry - else - do reqBodyWanted <- readItr itr itrReqBodyWanted id - if reqBodyWanted /= Nothing then - return $ writeContinue itr - else +awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () +awaitSomethingToWrite ctx@(Context {..}) + = join $ + atomically $ + -- キューが空でなくなるまで待つ + do queue ← readTVar cQueue + -- GettingBody 状態にあり、Continue が期待されてゐて、それがま + -- だ送信前なのであれば、Continue を送信する。 + case S.viewr queue of + EmptyR → retry + _ :> itr → do state ← readItr itrState itr + if state ≡ GettingBody then + writeContinueIfNeeded ctx itr + else + if state ≥ DecidingBody then + writeHeaderOrBodyIfNeeded ctx itr + else retry - else - retry - writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary !itr - -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ - -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が - -- 空でなければ、それを出力する。空である時は、もし状態が - -- Done であれば後処理をする。 - = {-# SCC "writeHeaderOrBodyIfNecessary" #-} - do wroteHeader <- readItr itr itrWroteHeader id - - if not wroteHeader then - return $! writeHeader itr - else - do bodyToSend <- readItr itr itrBodyToSend id - - if C8.null bodyToSend then - do state <- readItr itr itrState id - - if state == Done then - return $! finalize itr - else - retry - else - return $! writeBodyChunk itr +writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) +writeContinueIfNeeded ctx itr + = do expectedContinue ← readItr itrExpectedContinue itr + if expectedContinue then + do wroteContinue ← readItr itrWroteContinue itr + if wroteContinue then + -- 既に Continue を書込み濟 + retry + else + do reqBodyWanted ← readItr itrReqBodyWanted itr + if reqBodyWanted ≢ Nothing then + return $ writeContinue ctx itr + else + retry + else + retry - writeContinue :: Interaction -> IO () - writeContinue !itr - = {-# SCC "writeContinue" #-} - do let cont = Response { - resVersion = HttpVersion 1 1 - , resStatus = Continue - , resHeaders = emptyHeaders - } - cont' <- completeUnconditionalHeaders cnf cont - hPutResponse h cont' - hFlush h - atomically $! writeItr itr itrWroteContinue True - awaitSomethingToWrite +-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ +-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを +-- 出力する。空である時は、もし状態がDone であれば後処理をする。 +writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) +writeHeaderOrBodyIfNeeded ctx itr + = do wroteHeader ← readItr itrWroteHeader itr + if not wroteHeader then + return $ writeHeader ctx itr + else + do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr) + if noBodyToWrite then + do state ← readItr itrState itr + if state ≡ Done then + return $ finalize ctx itr + else + retry + else + return $ writeBodyChunk ctx itr - writeHeader :: Interaction -> IO () - writeHeader !itr - = {-# SCC "writeHeader" #-} - do res <- atomically $! do writeItr itr itrWroteHeader True - readItr itr itrResponse id - hPutResponse h res - hFlush h - awaitSomethingToWrite - - writeBodyChunk :: Interaction -> IO () - writeBodyChunk !itr - = {-# SCC "writeBodyChunk" #-} - do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id - willChunkBody <- atomically $! readItr itr itrWillChunkBody id - chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id - writeItr itr itrBodyToSend C8.empty - return chunk - unless willDiscardBody - $ do if willChunkBody then - do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk) - hPutLBS h (C8.pack "\r\n") - hPutLBS h chunk - hPutLBS h (C8.pack "\r\n") - else - hPutLBS h chunk - hFlush h - awaitSomethingToWrite +writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () +writeContinue ctx@(Context {..}) itr + = do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = (∅) + } + cont' ← completeUnconditionalHeaders cConfig cont + hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hFlush cHandle + atomically $ writeItr itrWroteContinue True itr + awaitSomethingToWrite ctx - finishBodyChunk :: Interaction -> IO () - finishBodyChunk !itr - = {-# SCC "finishBodyChunk" #-} - do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id - willChunkBody <- atomically $! readItr itr itrWillChunkBody id - when (not willDiscardBody && willChunkBody) - $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h +writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () +writeHeader ctx@(Context {..}) itr + = do res ← atomically + $ do writeItr itrWroteHeader True itr + readItr itrResponse itr + hPutBuilder cHandle $ A.toBuilder $ printResponse res + hFlush cHandle + awaitSomethingToWrite ctx - finalize :: Interaction -> IO () - finalize !itr - = {-# SCC "finalize" #-} - do finishBodyChunk itr - willClose <- atomically $! - do queue <- readTVar tQueue +writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () +writeBodyChunk ctx@(Context {..}) itr + = join $ + atomically $ + do willDiscardBody ← readItr itrWillDiscardBody itr + if willDiscardBody then + do _ ← tryTakeTMVar (itrBodyToSend itr) + return $ awaitSomethingToWrite ctx + else + do willChunkBody ← readItr itrWillChunkBody itr + chunk ← takeTMVar (itrBodyToSend itr) + return $ + do if willChunkBody then + hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk + else + hPutBuilder cHandle chunk + hFlush cHandle + awaitSomethingToWrite ctx - case S.viewr queue of - EmptyR -> return () -- this should never happen - remaining :> _ -> writeTVar tQueue remaining +finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () +finishBodyChunk (Context {..}) itr + = join $ + atomically $ + do willDiscardBody ← readItr itrWillDiscardBody itr + willChunkBody ← readItr itrWillChunkBody itr + if ((¬) willDiscardBody) ∧ willChunkBody then + return $ + do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + else + return $ return () - readItr itr itrWillClose id - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、 - -- スレッドを豫め殺して置かないとをかしくなる。 - do killThread readerTID - hClose h - else - awaitSomethingToWrite +finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () +finalize ctx@(Context {..}) itr + = do finishBodyChunk ctx itr + willClose ← atomically $ + do queue ← readTVar cQueue + case S.viewr queue of + EmptyR → return () -- this should never happen + remaining :> _ → writeTVar cQueue remaining + readItr itrWillClose itr + if willClose then + -- reader は恐らく hWaitForInput してゐる最中なので、スレッ + -- ドを豫め殺して置かないとをかしくなる。 + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx -- 2.40.0