X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=c8525af7497b0219c0ede9b54cf25198fe29c3ee;hp=2672399bf7a249102d2368d387bc529dcfdae017;hb=3fe5ca3;hpb=db4b61223e0d8b34079d3b190fb3e3644b0b4866

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 2672399..c8525af 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -139,6 +139,8 @@ 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
 import Control.Monad.Reader
@@ -148,18 +150,19 @@ import qualified Data.Ascii as A
 import qualified Data.Attoparsec.Char8 as P
 import qualified Data.Attoparsec.Lazy  as LP
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy  as Lazy
-import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Foldable (toList)
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
+import Data.Monoid
 import Data.Monoid.Unicode
-import qualified Data.Sequence as S
+import Data.Sequence (Seq)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import qualified Data.Text.Encoding.Error as T
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Network.HTTP.Lucu.Abortion
@@ -310,9 +313,9 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
-               , fdContent  = L8.fromChunks [value]
+               , fdContent  = Lazy.fromChunks [value]
                }
-      in (T.decodeUtf8With T.lenientDecode name, fd)
+      in (T.decodeUtf8 name, fd)
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
@@ -612,7 +615,7 @@ input limit
                        askForInput itr
                    else
                        do driftTo DecidingHeader
-                          return L8.empty
+                          return (∅)
          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
@@ -628,16 +631,16 @@ input limit
                liftIO $ atomically
                       $ do chunkLen ← readItr itrReqChunkLength id itr
                            writeItr itrWillReceiveBody True itr
-                           if fmap (> actualLimit) chunkLen ≡ Just True then
+                           if ((> actualLimit) <$> chunkLen) ≡ Just True then
                                -- 受信前から多過ぎる事が分かってゐる
                                tooLarge actualLimit
                            else
                                writeItr itrReqBodyWanted (Just actualLimit) itr
                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
                chunk ← liftIO $ atomically
-                       $ do chunk       ← readItr itrReceivedBody chunksToLBS itr
-                            chunkIsOver ← readItr itrReqChunkIsOver id itr
-                            if L8.length chunk < fromIntegral actualLimit then
+                       $ do chunkLen    ← readItr itrReceivedBodyLen id itr
+                            chunkIsOver ← readItr itrReqChunkIsOver  id itr
+                            if chunkLen < actualLimit then
                                 -- 要求された量に滿たなくて、まだ殘りが
                                 -- あるなら再試行。
                                 unless chunkIsOver
@@ -649,8 +652,10 @@ input limit
                                     $ tooLarge actualLimit
                             -- 成功。itr 内にチャンクを置いたままにする
                             -- とメモリの無駄になるので除去。
+                            chunk ← readItr itrReceivedBody seqToLBS itr
                             writeItr itrReceivedBody (∅) itr
                             return chunk
+
                driftTo DecidingHeader
                return chunk
 
@@ -658,6 +663,10 @@ input limit
       tooLarge lim = abortSTM RequestEntityTooLarge []
                      (Just $ "Request body must be smaller than "
                              ⊕ T.pack (show lim) ⊕ " bytes.")
+
+seqToLBS ∷ Seq ByteString → Lazy.ByteString
+{-# INLINE seqToLBS #-}
+seqToLBS = Lazy.fromChunks ∘ toList
          
 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 -- request body up to @limit@ bytes. You can read any large request by
@@ -680,7 +689,7 @@ inputChunk limit
                         askForInput itr
                     else
                         do driftTo DecidingHeader
-                           return L8.empty
+                           return (∅)
          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
@@ -694,31 +703,37 @@ inputChunk limit
                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                          $ do writeItr itrReqBodyWanted (Just actualLimit) itr
-                               writeItr itrWillReceiveBody True itr
+                      $ do writeItr itrReqBodyWanted (Just actualLimit) itr
+                           writeItr itrWillReceiveBody True itr
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                chunk ← liftIO $ atomically
-                        $ do chunk ← readItr itrReceivedBody chunksToLBS itr
-                             -- 要求された量に滿たなくて、まだ殘りがあ
-                             -- るなら再試行。
-                             when (L8.length chunk < fromIntegral actualLimit)
-                                      $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
-                                           unless chunkIsOver
-                                               $ retry
-                             -- 成功
-                             writeItr itrReceivedBody (∅) itr
-                             return chunk
-               when (L8.null chunk)
+                       $ do chunkLen ← readItr itrReceivedBodyLen id itr
+                            -- 要求された量に滿たなくて、まだ殘りがある
+                            -- なら再試行。
+                            when (chunkLen < actualLimit)
+                                $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
+                                     unless chunkIsOver
+                                         $ retry
+                            -- 成功
+                            chunk ← readItr itrReceivedBody seqToLBS itr
+                            writeItr itrReceivedBody (∅) itr
+                            return chunk
+               when (Lazy.null chunk)
                    $ driftTo DecidingHeader
                return chunk
 
 -- | Computation of @'inputForm' limit@ attempts to read the request
 -- body with 'input' and parse it as
--- application\/x-www-form-urlencoded or multipart\/form-data. If the
--- request header \"Content-Type\" is neither of them, 'inputForm'
+-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
+-- the request header \"Content-Type\" is neither of them, 'inputForm'
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".
+--
+-- Field names in @multipart\/form-data@ will be precisely decoded in
+-- accordance with RFC 2231. On the other hand,
+-- @application\/x-www-form-urlencoded@ says nothing about the
+-- encoding of field names, so they'll always be decoded in UTF-8.
 inputForm ∷ Int → Resource [(Text, FormData)]
 inputForm limit
     = do cTypeM ← getContentType
@@ -731,7 +746,11 @@ inputForm limit
                → readMultipartFormData params
            Just cType
                → abort UnsupportedMediaType []
-                 (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType))
+                 $ Just
+                 $ A.toText
+                 $ A.fromAsciiBuilder
+                 $ A.toAsciiBuilder "Unsupported media type: "
+                 ⊕ printMIMEType cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -739,7 +758,7 @@ inputForm limit
             (bsToAscii =≪ input limit)
 
       bsToAscii bs
-          = case A.fromByteString (C8.concat (L8.toChunks bs)) of
+          = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
               Just a  → return a
               Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
 
@@ -814,15 +833,19 @@ redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))
              $ abort InternalServerError []
-               (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code))
+             $ Just
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "Attempted to redirect with status "
+             ⊕ printStatusCode code
          setStatus code
          setLocation uri
 
 -- | Computation of @'setContentType' mType@ sets the response header
 -- \"Content-Type\" to @mType@.
 setContentType ∷ MIMEType → Resource ()
-setContentType mType
-    = setHeader "Content-Type" (printMIMEType mType)
+setContentType
+    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 -- | Computation of @'setLocation' uri@ sets the response header
 -- \"Location\" to @uri@.
@@ -865,8 +888,7 @@ setWWWAuthenticate challenge
 -- \/dev\/random.
 output ∷ Lazy.ByteString → Resource ()
 {-# INLINE output #-}
-output str = do outputChunk str
-                driftTo Done
+output str = outputChunk str *> driftTo Done
 
 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
 -- response body. You can compute this action multiple times to write
@@ -888,30 +910,21 @@ outputChunk wholeChunk
          unless (discardBody)
              $ sendChunks wholeChunk limit
 
-         unless (L8.null wholeChunk)
+         unless (Lazy.null wholeChunk)
              $ liftIO $ atomically $
                writeItr itrBodyIsNull False itr
     where
-      -- チャンクの大きさは Config で制限されてゐる。もし例へば
-      -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
-      -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
-      -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
-      -- く爲にチャンクの大きさを測るからだ。
       sendChunks ∷ Lazy.ByteString → Int → Resource ()
       sendChunks str limit
-          | L8.null str = return ()
-          | otherwise   = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
-                             itr ← getInteraction
-                             liftIO $ atomically $ 
-                                 do buf ← readItr itrBodyToSend id itr
-                                    if S.null buf then
-                                        -- バッファが消化された
-                                        writeItr itrBodyToSend (chunksFromLBS chunk) itr
-                                    else
-                                        -- 消化されるのを待つ
-                                        retry
-                             -- 殘りのチャンクについて繰り返す
-                             sendChunks remaining limit
+          | Lazy.null str = return ()
+          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
+                               itr ← getInteraction
+                               liftIO $ atomically
+                                      $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
+                               sendChunks remaining limit
+
+      chunkToBuilder ∷ Lazy.ByteString → Builder
+      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
 
 {-