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
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
$ 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
-- 受信前から多過ぎる事が分かってゐる
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
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
- chunk ← readItr itrReceivedBody seqToLBS itr
+ chunk ← seqToLBS <$> readItr itrReceivedBody itr
writeItr itrReceivedBody (∅) itr
writeItr itrReceivedBodyLen 0 itr
return chunk
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
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
(Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
discardBody ← liftIO $ atomically $
- readItr itrWillDiscardBody id itr
+ readItr itrWillDiscardBody itr
unless (discardBody)
$ sendChunks wholeChunk limit
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
= postprocess itr
drift itr _ Done
- = do bodyIsNull ← readItr itrSentNoBody id itr
+ = do bodyIsNull ← readItr itrSentNoBody itr
when bodyIsNull
- $ writeDefaultPage itr
+ $ writeDefaultPage itr
drift _ _ _
= return ()
{-# 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
projects / Lucu.git / commitdiff