From: PHO <pho@cielonegro.org>
Date: Tue, 4 Oct 2011 04:16:01 +0000 (+0900)
Subject: many changes...
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=3fe5ca3bca04e0124a5f2440e893dc5375e0bb51;p=Lucu.git

many changes...

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa
---

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 5b62418..bc75af5 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -10,6 +10,7 @@ module Network.HTTP.Lucu.DefaultPage
     , mkDefaultPage
     )
     where
+import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
@@ -18,7 +19,6 @@ import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.Ascii as A
 import Data.Maybe
-import qualified Data.Sequence as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
@@ -55,13 +55,13 @@ writeDefaultPage !itr
                        let conf = itrConfig itr
                            page = getDefaultPage conf reqM res
 
-                       writeTVar (itrBodyToSend itr)
-                                 (S.singleton (encodeUtf8 page))
+                       putTMVar (itrBodyToSend itr)
+                                (BB.fromByteString $ encodeUtf8 page)
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
 mkDefaultPage !conf !status !msgA
-    = let sStr = A.toString $ printStatusCode status
+    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
                         , T.unpack (cnfServerHost conf)
diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index f87ae5c..a5fdb02 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -12,11 +12,11 @@ module Network.HTTP.Lucu.Headers
     , fromHeaders
 
     , headersP
-    , hPutHeaders
+    , printHeaders
     )
     where
 import Control.Applicative
-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.ByteString as BS
@@ -24,7 +24,6 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid
 import Data.Monoid.Unicode
-import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
@@ -124,13 +123,14 @@ headersP = do xs ← P.many header
       {-# INLINE joinValues #-}
       joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
 
-hPutHeaders ∷ HandleLike h => h → Headers → IO ()
-hPutHeaders !h !(Headers m)
-    = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
+printHeaders ∷ Headers → AsciiBuilder
+printHeaders (Headers m)
+    = mconcat (map printHeader (M.toList m)) ⊕
+      A.toAsciiBuilder "\x0D\x0A"
     where
-      putH ∷ (CIAscii, Ascii) → IO ()
-      putH (!name, !value)
-          = do hPutBS h (A.ciToByteString name)
-               hPutBS h ": "
-               hPutBS h (A.toByteString value)
-               hPutBS h "\r\n"
+      printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
+      printHeader (name, value)
+          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
+            A.toAsciiBuilder ": "                 ⊕
+            A.toAsciiBuilder value                ⊕
+            A.toAsciiBuilder "\x0D\x0A"
diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index 4531c83..a5db1e2 100644
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -3,18 +3,21 @@
   , OverloadedStrings
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Manipulation of HTTP version string.
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
     , httpVersionP
-    , hPutHttpVersion
+    , printHttpVersion
     )
     where
-import Control.Monad.Unicode
+import qualified Blaze.Text.Int as BT
+import Control.Applicative
+import Control.Applicative.Unicode
+import Data.Ascii (AsciiBuilder)
+import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
-import Network.HTTP.Lucu.HandleLike
+import Data.Monoid.Unicode
 import Prelude hiding (min)
 
 -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
@@ -32,24 +35,22 @@ instance Ord HttpVersion where
 
 httpVersionP ∷ Parser HttpVersion
 httpVersionP = string "HTTP/"
-               ≫
-               choice [ string "1.1" ≫ return (HttpVersion 1 1)
-                      , string "1.0" ≫ return (HttpVersion 1 0)
-                      , do major ← decimal
-                           _     ← char '.'
-                           minor ← decimal
-                           return $ HttpVersion major minor
+               *>
+               choice [ string "1.1" *> pure (HttpVersion 1 1)
+                      , string "1.0" *> pure (HttpVersion 1 0)
+                      , HttpVersion <$> decimal ⊛ (char '.' *> decimal)
                       ]
 
-hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO ()
-hPutHttpVersion !h !v
+-- |Convert an 'HttpVersion' to 'AsciiBuilder'.
+printHttpVersion ∷ HttpVersion → AsciiBuilder
+printHttpVersion v
     = case v of
         -- 頻出するので高速化
-        HttpVersion 1 0 → hPutBS h "HTTP/1.0"
-        HttpVersion 1 1 → hPutBS h "HTTP/1.1"
+        HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0"
+        HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1"
         -- 一般の場合
-        HttpVersion !maj !min
-            → do hPutBS   h "HTTP/"
-                 hPutStr  h (show maj)
-                 hPutChar h '.'
-                 hPutStr  h (show min)
+        HttpVersion maj min
+            → A.toAsciiBuilder    "HTTP/"           ⊕
+              A.unsafeFromBuilder (BT.integral maj) ⊕
+              A.toAsciiBuilder    "."               ⊕
+              A.unsafeFromBuilder (BT.integral min)
diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 52a5e2e..ac9c46f 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -11,20 +11,16 @@ module Network.HTTP.Lucu.Interaction
     , newInteraction
     , defaultPageContentType
 
-    , chunksToLBS
-    , chunksFromLBS
-
     , writeItr
     , readItr
     , updateItr
     )
     where
+import Blaze.ByteString.Builder (Builder)
 import Control.Applicative
 import Control.Concurrent.STM
 import Data.Ascii (Ascii)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import Data.Foldable
 import Data.Sequence (Seq)
 import qualified Data.Sequence as S
 import Network.Socket
@@ -34,7 +30,6 @@ import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509
-import Prelude.Unicode
 
 data Interaction = Interaction {
       itrConfig            ∷ !Config
@@ -55,13 +50,14 @@ data Interaction = Interaction {
     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
     , itrReqBodyWasteAll   ∷ !(TVar Bool)
     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
+    , itrReceivedBodyLen   ∷ !(TVar Int)
 
     , itrWillReceiveBody   ∷ !(TVar Bool)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar Bool)
     , itrWillClose         ∷ !(TVar Bool)
 
-    , itrBodyToSend        ∷ !(TVar (Seq BS.ByteString))
+    , itrBodyToSend        ∷ !(TMVar Builder)
     , itrBodyIsNull        ∷ !(TVar Bool)
 
     , itrState             ∷ !(TVar InteractionState)
@@ -106,13 +102,14 @@ newInteraction !conf !port !addr !cert !req
          reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
          reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
          receivedBody       ← newTVarIO S.empty
+         receivedBodyLen    ← newTVarIO 0
 
          willReceiveBody   ← newTVarIO False
          willChunkBody     ← newTVarIO False
          willDiscardBody   ← newTVarIO False
          willClose         ← newTVarIO False
 
-         bodyToSend ← newTVarIO S.empty
+         bodyToSend ← newEmptyTMVarIO
          bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
          state ← newTVarIO ExaminingRequest
@@ -139,6 +136,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrReqBodyWanted     = reqBodyWanted
                     , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody
+                    , itrReceivedBodyLen   = receivedBodyLen
 
                     , itrWillReceiveBody   = willReceiveBody
                     , itrWillChunkBody     = willChunkBody
@@ -154,6 +152,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrWroteHeader   = wroteHeader
                     }
 
+{-
 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
 {-# INLINE chunksToLBS #-}
 chunksToLBS = LBS.fromChunks ∘ toList
@@ -161,6 +160,7 @@ chunksToLBS = LBS.fromChunks ∘ toList
 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
 {-# INLINE chunksFromLBS #-}
 chunksFromLBS = S.fromList ∘ LBS.toChunks
+-}
 
 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 {-# INLINE writeItr #-}
diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index dfaef11..ce637d5 100644
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -15,7 +15,7 @@ module Network.HTTP.Lucu.MIMEType
     )
     where
 import Control.Applicative
-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.ByteString.Char8 as C8
@@ -35,15 +35,13 @@ data MIMEType = MIMEType {
     , mtParams ∷ !(Map CIAscii Text)
     } deriving (Eq, Show)
 
--- |Convert a 'MIMEType' to 'Ascii'.
-printMIMEType ∷ MIMEType → Ascii
+-- |Convert a 'MIMEType' to 'AsciiBuilder'.
+printMIMEType ∷ MIMEType → AsciiBuilder
 printMIMEType (MIMEType maj min params)
-    = A.fromAsciiBuilder $
-      ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕
-        A.toAsciiBuilder "/" ⊕
-        A.toAsciiBuilder (A.fromCIAscii min) ⊕
-        printParams params
-      )
+    = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
+      A.toAsciiBuilder "/" ⊕
+      A.toAsciiBuilder (A.fromCIAscii min) ⊕
+      printParams params
 
 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
 -- exception for parse error.
diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 3344f4b..226e014 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -115,11 +115,11 @@ serializeExtMap extMap moduleName variableName
                                   [] (HsUnGuardedRhs extMapExp) []]
                      ]
           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
-          comment   =    "{- !!! WARNING !!!\n"
-                      ++ "   This file is automatically generated.\n"
-                      ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+          comment   =   "{- !!! WARNING !!!\n"
+                      ⧺ "   This file is automatically generated.\n"
+                      ⧺ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
       in
-        comment ++ prettyPrint hsModule ++ "\n"
+        comment ⧺ prettyPrint hsModule ⧺ "\n"
     where
       records ∷ [HsExp]
       records = map record $ M.assocs extMap
@@ -137,4 +137,7 @@ serializeExtMap extMap moduleName variableName
           = HsApp (HsVar (UnQual (HsIdent "parseMIMEType")))
             (HsParen
              (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString")))
-              (HsLit (HsString $ A.toString $ printMIMEType mt))))
+              (HsLit (HsString $ mimeToString mt))))
+
+      mimeToString ∷ MIMEType → String
+      mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a7c2e07..0e089ca 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -71,22 +71,28 @@ postprocess !itr
          unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status code is not good for a final status of a response: "
-                          ⊕ printStatusCode sc )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
+             ⊕ printStatusCode sc
 
          when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Allow header." )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status was "
+             ⊕ printStatusCode sc
+             ⊕ A.toAsciiBuilder " but no Allow header."
 
          when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status code was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Location header." )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status code was "
+             ⊕ printStatusCode sc
+             ⊕ A.toAsciiBuilder " but no Location header."
 
          when (reqM ≢ Nothing) relyOnRequest
 
diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index ab8e5c7..9307c8d 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -190,6 +190,7 @@ requestReader !cnf !tree !fbs !h !port !addr !tQueue
                                                       = do writeItr itr itrReqChunkRemaining newRemaining
                                                            writeItr itr itrReqBodyWanted newWanted
                                                            updateItr itr itrReceivedBody $ flip B.append chunk
+                                                           updateItr itrReceivedBodyLen (+ actualReadBytes) itr
 
                                               if newRemaining == Just 0 then
                                                   -- チャンクフッタを讀む
@@ -276,15 +277,15 @@ requestReader !cnf !tree !fbs !h !port !addr !tQueue
                                   let wanted          = fromJust wantedM
                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
                                       (chunk, input') = B.splitAt bytesToRead input
-                                      newRemaining    = fmap
-                                                        (\ x -> x - (fromIntegral $ B.length chunk))
-                                                        remainingM
-                                      isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
+                                      actualReadBytes = fromIntegral $ B.length chunk
+                                      newRemaining    = (- actualReadBytes) <$> remainingM
+                                      isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
 
                                   writeItr itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver
                                   writeItr itr itrReqBodyWanted Nothing
                                   writeItr itr itrReceivedBody chunk
+                                  writeItr itrReceivedBody actualReadBytes
 
                                   if isOver then
                                       return $ acceptRequest input'
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
 
 {-
 
diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index df98bf7..a593b3a 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -6,14 +6,13 @@
   , UnicodeSyntax
   , ViewPatterns
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
     , printStatusCode
-    , hPutResponse
+    , printResponse
     , isInformational
     , isSuccessful
     , isRedirection
@@ -23,11 +22,10 @@ module Network.HTTP.Lucu.Response
     , statusCode
     )
     where
-import Data.Ascii (Ascii)
+import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Monoid.Unicode
 import Data.Typeable
-import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Utils
@@ -89,11 +87,10 @@ data StatusCode = Continue
                 | InsufficientStorage
                   deriving (Eq, Show, Typeable)
 
--- |Convert a 'StatusCode' to 'Ascii'.
-printStatusCode ∷ StatusCode → Ascii
+-- |Convert a 'StatusCode' to 'AsciiBuilder'.
+printStatusCode ∷ StatusCode → AsciiBuilder
 printStatusCode (statusCode → (# num, msg #))
-    = A.fromAsciiBuilder $
-      ( show3 num ⊕
+    = ( show3 num            ⊕
         A.toAsciiBuilder " " ⊕
         A.toAsciiBuilder msg
       )
@@ -108,19 +105,14 @@ instance HasHeaders Response where
     getHeaders = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
 
-hPutResponse ∷ HandleLike h ⇒ h → Response → IO ()
-hPutResponse h (Response {..})
-    = do hPutHttpVersion h resVersion
-         hPutChar        h ' '
-         hPutStatus      h resStatus
-         hPutBS          h "\r\n"
-         hPutHeaders     h resHeaders
-
-hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO ()
-hPutStatus h (statusCode → (# num, msg #))
-    = do hPutBS   h (A.toByteString $ A.fromAsciiBuilder $ show3 num)
-         hPutChar h ' '
-         hPutBS   h (A.toByteString msg)
+-- |Convert a 'Response' to 'AsciiBuilder'.
+printResponse ∷ Response → AsciiBuilder
+printResponse (Response {..})
+    = printHttpVersion resVersion ⊕
+      A.toAsciiBuilder " "        ⊕
+      printStatusCode  resStatus  ⊕
+      A.toAsciiBuilder "\x0D\x0A" ⊕
+      printHeaders     resHeaders
 
 -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
 isInformational ∷ StatusCode → Bool