X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=ddff647364a4295361379926b5affcff571a7081;hb=1789cee5ee66d2f7f2b26280be2f13eac4df7980;hp=87d2a33338d1e0a726c80af4fef3e1735fbc3e23;hpb=6126eb9cbe5b38c300d855d96d2238831e59b5dd;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 87d2a33..ddff647 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -131,8 +131,8 @@ module Network.HTTP.Lucu.Resource
 
     -- |Computation of these actions changes the state to /Deciding
     -- Body/.
-    , output
-    , outputChunk
+    , putChunk
+    , putBuilder
 
     , driftTo -- private
     )
@@ -154,7 +154,6 @@ import Data.Foldable (toList)
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
-import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Text (Text)
@@ -166,7 +165,6 @@ import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authorization
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.ContentCoding
-import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.HttpVersion
@@ -211,7 +209,7 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction
 getRemoteAddr' ∷ Resource HostName
 getRemoteAddr'
     = do sa          ← getRemoteAddr
-         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
+         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
          return a
 
 -- |Resolve an address to the remote host.
@@ -252,7 +250,7 @@ getRequestVersion = reqVersion <$> getRequest
 -- |Get the path of this 'Resource' (to be exact,
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
--- action is the exact path in the tree even if the
+-- action is the exact path in the tree even when the
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 --
 -- Example:
@@ -413,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
@@ -586,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
@@ -607,7 +605,7 @@ input ∷ Int → Resource Lazy.ByteString
 input limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
+         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
@@ -675,7 +673,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString
 inputChunk limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
+         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
@@ -778,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\".
@@ -815,6 +813,8 @@ setHeader' name value
                 $ do res ← readTVar $ itrResponse itr
                      let res' = H.setHeader name value res
                      writeTVar (itrResponse itr) res'
+                     when (name ≡ "Content-Type")
+                         $ writeTVar (itrResponseHasCType itr) True
 
 -- | Computation of @'redirect' code uri@ sets the response status to
 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
@@ -834,8 +834,8 @@ redirect code uri
 -- | Computation of @'setContentType' mType@ sets the response header
 -- \"Content-Type\" to @mType@.
 setContentType ∷ MIMEType → Resource ()
-setContentType
-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+{-# INLINE setContentType #-}
+setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 -- | Computation of @'setLocation' uri@ sets the response header
 -- \"Location\" to @uri@.
@@ -870,94 +870,65 @@ 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.
-output ∷ Lazy.ByteString → Resource ()
-{-# INLINE output #-}
-output str = outputChunk str *> driftTo Done
-
--- | 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.
-outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk wholeChunk
-    = do driftTo DecidingBody
-         itr ← getInteraction
-         
-         let limit = cnfMaxOutputChunkLength $ itrConfig itr
-         when (limit ≤ 0)
-             $ abort InternalServerError []
-               (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
-
-         discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
-         unless (discardBody)
-             $ sendChunks itr wholeChunk limit
-
-         unless (Lazy.null wholeChunk)
-             $ liftIO $ atomically $
-               writeTVar (itrSentNoBodySoFar itr) False
-    where
-      sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
-      sendChunks itr@(Interaction {..}) str limit
-          | Lazy.null str = return ()
-          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
-                               liftIO $ atomically
-                                      $ putTMVar itrBodyToSend (chunkToBuilder chunk)
-                               sendChunks itr remaining limit
-
-      chunkToBuilder ∷ Lazy.ByteString → Builder
-      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
-
-{-
-
-  [GettingBody からそれ以降の状態に遷移する時]
-  
-  body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
-  [DecidingHeader からそれ以降の状態に遷移する時]
-
-  postprocess する。
-
-
-  [Done に遷移する時]
+-- | 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 response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putChunk ∷ Lazy.ByteString → Resource ()
+{-# INLINE putChunk #-}
+putChunk = putBuilder ∘ BB.fromLazyByteString
+
+-- | 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 response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+    = do itr ← getInteraction
+         liftIO $ atomically
+                $ do driftTo' itr DecidingBody
+                     hasCType ← readTVar $ itrResponseHasCType itr
+                     unless hasCType
+                         $ abortSTM InternalServerError []
+                         $ Just "putBuilder: Content-Type has not been set."
+                     putTMVar (itrBodyToSend itr) b
 
-  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
-  る。
 
--}
+-- 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
-          = fail "It makes no sense to output something after finishing to output."
+          = fail "It makes no sense to output something after finishing outputs."
       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 itr@(Interaction {..}) _ Done
-          = do bodyIsNull ← readTVar itrSentNoBodySoFar
-               when bodyIsNull
-                   $ writeDefaultPage itr
-      drift _ _ _
+      drift _ _
           = return ()