X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=d0454c4c630d047a419f335a37ecfeb1c64211cb;hb=72a3e24;hp=298b9b2541edd0f4d3d8b170bccb6cc9965bfe4e;hpb=ca338174155913a969808d7b20193973394e474e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 298b9b2..d0454c4 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -6,7 +6,6 @@
   , UnicodeSyntax
   #-}
 {-# OPTIONS_HADDOCK prune #-}
-
 -- |This is the Resource Monad; monadic actions to define the behavior
 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
@@ -70,7 +69,7 @@ module Network.HTTP.Lucu.Resource
     -- * Types
       Resource
     , FormData(..)
-    , runRes -- private
+    , runRes
 
     -- * Actions
 
@@ -138,7 +137,6 @@ module Network.HTTP.Lucu.Resource
     , driftTo -- private
     )
     where
-import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import Control.Concurrent.STM
@@ -155,7 +153,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)
@@ -167,7 +164,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
@@ -212,7 +208,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.
@@ -253,7 +249,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:
@@ -263,9 +259,9 @@ getRequestVersion = reqVersion <$> getRequest
 -- >
 -- > resFoo = ResourceDef {
 -- >     resIsGreedy = True
--- >   , resGet = Just $ do requestURI   ← getRequestURI
--- >                        resourcePath ← getResourcePath
--- >                        pathInfo     ← getPathInfo
+-- >   , resGet = Just $ do requestURI   <- getRequestURI
+-- >                        resourcePath <- getResourcePath
+-- >                        pathInfo     <- getPathInfo
 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 -- >                        -- resourcePath       == ["foo"]
 -- >                        -- pathInfo           == ["bar", "baz"]
@@ -457,7 +453,9 @@ foundETag tag
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
-              $ setHeader' "ETag" (printETag tag)
+              $ setHeader' "ETag"
+              $ A.fromAsciiBuilder
+              $ printETag tag
          when (method ≡ POST)
               $ abort InternalServerError []
                 (Just "Illegal computation of foundETag for POST request.")
@@ -606,7 +604,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
@@ -624,7 +622,7 @@ input limit
                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted (Just actualLimit)
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
                chunk ← liftIO $ atomically
                        $ do chunkLen    ← readTVar itrReceivedBodyLen
@@ -674,7 +672,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
@@ -692,7 +690,7 @@ inputChunk limit
                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted (Just actualLimit)
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                chunk ← liftIO $ atomically
                        $ do chunkLen ← readTVar itrReceivedBodyLen
@@ -814,6 +812,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
@@ -833,8 +833,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@.
@@ -874,6 +874,9 @@ setWWWAuthenticate challenge
 -- | 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.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
 output ∷ Lazy.ByteString → Resource ()
 {-# INLINE output #-}
 output str = outputChunk str *> driftTo Done
@@ -881,53 +884,19 @@ 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.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
 outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk wholeChunk
+outputChunk str
     = 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 に遷移する時]
-
-  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
-  る。
-
--}
+         liftIO $ atomically
+                $ do hasCType ← readTVar $ itrResponseHasCType itr
+                     unless hasCType
+                         $ abortSTM InternalServerError []
+                         $ Just "outputChunk: Content-Type has not been set."
+                     putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
 
 driftTo ∷ InteractionState → Resource ()
 driftTo newState
@@ -945,7 +914,7 @@ driftTo 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)
 
@@ -954,9 +923,5 @@ driftTo newState
           = writeTVar itrReqBodyWasteAll True
       drift itr DecidingHeader _
           = postprocess itr
-      drift itr@(Interaction {..}) _ Done
-          = do bodyIsNull ← readTVar itrSentNoBodySoFar
-               when bodyIsNull
-                   $ writeDefaultPage itr
       drift _ _ _
           = return ()