X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=ddff647364a4295361379926b5affcff571a7081;hp=d0454c4c630d047a419f335a37ecfeb1c64211cb;hb=1789cee;hpb=1f3ac4a08b413a7438258c8e196873f5e8a9718f

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index d0454c4..ddff647 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -131,12 +131,13 @@ module Network.HTTP.Lucu.Resource
 
     -- |Computation of these actions changes the state to /Deciding
     -- Body/.
-    , output
-    , outputChunk
+    , putChunk
+    , putBuilder
 
     , driftTo -- private
     )
     where
+import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import Control.Concurrent.STM
@@ -410,7 +411,7 @@ getAuthorization
              return ac
 
 
-{- ExaminingRequest 時に使用するアクション群 -}
+-- Finding an entity
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
@@ -583,7 +584,7 @@ foundNoEntity msgM
          driftTo GettingBody
 
 
-{- GettingBody 時に使用するアクション群 -}
+-- Getting a request body
 
 -- | Computation of @'input' limit@ attempts to read the request body
 -- up to @limit@ bytes, and then make the 'Resource' transit to
@@ -775,7 +776,7 @@ defaultLimit ∷ Int
 defaultLimit = (-1)
 
 
-{- DecidingHeader 時に使用するアクション群 -}
+-- Setting response headers
 
 -- | Set the response status code. If you omit to compute this action,
 -- the status code will be defaulted to \"200 OK\".
@@ -869,48 +870,54 @@ setWWWAuthenticate challenge
     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 
 
-{- DecidingBody 時に使用するアクション群 -}
+-- Writing a response body
 
--- | Write a 'Lazy.ByteString' to the response body, and then transit
--- to the /Done/ state. It is safe to apply 'output' to an infinite
--- string, such as the lazy stream of \/dev\/random.
+-- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- safe to apply this function to an infinitely long
+-- 'Lazy.ByteString'.
 --
--- Note that you must first set the \"Content-Type\" response header
+-- Note that you must first set the response header \"Content-Type\"
 -- before applying this function. See: 'setContentType'
-output ∷ Lazy.ByteString → Resource ()
-{-# INLINE output #-}
-output str = outputChunk str *> driftTo Done
+putChunk ∷ Lazy.ByteString → Resource ()
+{-# INLINE putChunk #-}
+putChunk = putBuilder ∘ BB.fromLazyByteString
 
--- | Write a 'Lazy.ByteString' to the response body. This action can
--- be repeated as many times as you want. It is safe to apply
--- 'outputChunk' to an infinite string.
+-- | Run a 'Builder' to construct a chunk, and write it to the
+-- response body. It is safe to apply this function to a 'Builder'
+-- producing an infinitely long stream of octets.
 --
--- Note that you must first set the \"Content-Type\" response header
+-- Note that you must first set the response header \"Content-Type\"
 -- before applying this function. See: 'setContentType'
-outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk str
-    = do driftTo DecidingBody
-         itr ← getInteraction
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+    = do itr ← getInteraction
          liftIO $ atomically
-                $ do hasCType ← readTVar $ itrResponseHasCType itr
+                $ do driftTo' itr DecidingBody
+                     hasCType ← readTVar $ itrResponseHasCType itr
                      unless hasCType
                          $ abortSTM InternalServerError []
-                         $ Just "outputChunk: Content-Type has not been set."
-                     putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
+                         $ Just "putBuilder: Content-Type has not been set."
+                     putTMVar (itrBodyToSend itr) b
+
+
+-- Private
 
 driftTo ∷ InteractionState → Resource ()
 driftTo newState
     = do itr ← getInteraction
-         liftIO $ atomically
-                $ do oldState ← readTVar $ itrState itr
-                     if newState < oldState then
-                         throwStateError oldState newState
-                     else
-                         do let a = [oldState .. newState]
-                                b = tail a
-                                c = zip a b
-                            mapM_ (uncurry $ drift itr) c
-                            writeTVar (itrState itr) newState
+         liftIO $ atomically $ driftTo' itr newState
+
+driftTo' ∷ Interaction → InteractionState → STM ()
+driftTo' itr@(Interaction {..}) newState
+    = do oldState ← readTVar itrState
+         if newState < oldState then
+             throwStateError oldState newState
+         else
+             do let a = [oldState .. newState]
+                    b = tail a
+                    c = zip a b
+                mapM_ (uncurry drift) c
+                writeTVar itrState newState
     where
       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
       throwStateError Done DecidingBody
@@ -918,10 +925,10 @@ driftTo newState
       throwStateError old new
           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 
-      drift ∷ Interaction → InteractionState → InteractionState → STM ()
-      drift (Interaction {..}) GettingBody _
+      drift ∷ InteractionState → InteractionState → STM ()
+      drift GettingBody _
           = writeTVar itrReqBodyWasteAll True
-      drift itr DecidingHeader _
+      drift DecidingHeader _
           = postprocess itr
-      drift _ _ _
+      drift _ _
           = return ()