many changes...

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 5b624181a0fa55f885df2ee360ee911e79130ac5..bc75af51f153768091799704ce7d69cb2a75b7a4 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -10,6 +10,7 @@ module Network.HTTP.Lucu.DefaultPage
     , mkDefaultPage
     )
     where
     , mkDefaultPage
     )
     where

+import qualified Blaze.ByteString.Builder.ByteString as BB

 import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
 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 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
 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
 
                        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
 
 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)
           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 f87ae5cc127bf5de7be624241373a779080094ad..a5fdb022e7437e5add0071bcf723834b36f85c23 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -12,11 +12,11 @@ module Network.HTTP.Lucu.Headers
     , fromHeaders
 
     , headersP
     , fromHeaders
 
     , headersP

-    , hPutHeaders
+    , printHeaders

     )
     where
 import Control.Applicative
     )
     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
 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 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
 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
 
       {-# 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
     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 4531c837782ef9b6eda9edd4849e3771f2b0b0a1..a5db1e29193a10aaeec1b4c67ca57092f906a477 100644 (file)
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -3,18 +3,21 @@
   , OverloadedStrings
   , UnicodeSyntax
   #-}
   , OverloadedStrings
   , UnicodeSyntax
   #-}

-{-# OPTIONS_HADDOCK prune #-}

 
 -- |Manipulation of HTTP version string.
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
     , httpVersionP
 
 -- |Manipulation of HTTP version string.
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
     , httpVersionP

-    , hPutHttpVersion
+    , printHttpVersion

     )
     where
     )
     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 Data.Attoparsec.Char8

-import Network.HTTP.Lucu.HandleLike
+import Data.Monoid.Unicode

 import Prelude hiding (min)
 
 -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
 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/"
 
 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
         -- 頻出するので高速化
     = 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 52a5e2eea41e76b334015fedcee80089babad881..ac9c46f5a93b8e8a78c1bcb583f1d712b0c8a374 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -11,20 +11,16 @@ module Network.HTTP.Lucu.Interaction
     , newInteraction
     , defaultPageContentType
 
     , newInteraction
     , defaultPageContentType
 

-    , chunksToLBS
-    , chunksFromLBS
-

     , writeItr
     , readItr
     , updateItr
     )
     where
     , 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 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
 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 Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509

-import Prelude.Unicode

 
 data Interaction = Interaction {
       itrConfig            ∷ !Config
 
 data Interaction = Interaction {
       itrConfig            ∷ !Config


@@ -55,13 +50,14 @@ data Interaction = Interaction {
     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
     , itrReqBodyWasteAll   ∷ !(TVar Bool)
     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
     , 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)
 
 
     , 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)
     , 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
          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
 
 
          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
          bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
          state ← newTVarIO ExaminingRequest


@@ -139,6 +136,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrReqBodyWanted     = reqBodyWanted
                     , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody
                     , itrReqBodyWanted     = reqBodyWanted
                     , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody

+                    , itrReceivedBodyLen   = receivedBodyLen

 
                     , itrWillReceiveBody   = willReceiveBody
                     , itrWillChunkBody     = willChunkBody
 
                     , itrWillReceiveBody   = willReceiveBody
                     , itrWillChunkBody     = willChunkBody


@@ -154,6 +152,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrWroteHeader   = wroteHeader
                     }
 
                     , itrWroteHeader   = wroteHeader
                     }
 

+{-

 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
 {-# INLINE chunksToLBS #-}
 chunksToLBS = LBS.fromChunks ∘ toList
 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
 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
 {-# INLINE chunksFromLBS #-}
 chunksFromLBS = S.fromList ∘ LBS.toChunks

+-}

 
 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 {-# INLINE writeItr #-}
 
 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 {-# INLINE writeItr #-}

diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index dfaef11172d472666545301c7255043b34aae5b7..ce637d53f8331b75bdcaddae468f8c8122a72800 100644 (file)
--- 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
     )
     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
 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)
 
     , 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)
 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.
 
 -- |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 3344f4b7351f1d545dc5a908f40457f65ad34cfe..226e01483cb233ecf88be8b0e0871f71678e3058 100644 (file)
--- 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)
                                   [] (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
       in

-        comment ++ prettyPrint hsModule ++ "\n"
+        comment ⧺ prettyPrint hsModule ⧺ "\n"

     where
       records ∷ [HsExp]
       records = map record $ M.assocs extMap
     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")))
           = 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 a7c2e070843c45b4f357687c81cebb083a9d02e7..0e089cac47e7cb00504abefc8e3230e4393e0cc1 100644 (file)
--- 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
          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
 
          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
 
          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
 
 
          when (reqM ≢ Nothing) relyOnRequest
 

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index ab8e5c7528f594242b9f0aeea51d4da5d3f770a0..9307c8dcba499b1a3adeeb920ba0fe6238c59b37 100644 (file)
--- 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
                                                       = 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
                                                   -- チャンクフッタを讀む
 
                                               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
                                   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 itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver
                                   writeItr itr itrReqBodyWanted Nothing
                                   writeItr itr itrReceivedBody chunk

+                                  writeItr itrReceivedBody actualReadBytes

 
                                   if isOver then
                                       return $ acceptRequest input'
 
                                   if isOver then
                                       return $ acceptRequest input'

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 2672399bf7a249102d2368d387bc529dcfdae017..c8525af7497b0219c0ede9b54cf25198fe29c3ee 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -139,6 +139,8 @@ module Network.HTTP.Lucu.Resource
     , driftTo -- private
     )
     where
     , 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
 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.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.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.List
 import qualified Data.Map as M
 import Data.Maybe

+import Data.Monoid

 import Data.Monoid.Unicode
 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 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
 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
 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
 
 -- |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
                        askForInput itr
                    else
                        do driftTo DecidingHeader

-                          return L8.empty
+                          return (∅)

          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
          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
                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
                                -- 受信前から多過ぎる事が分かってゐる
                                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
                                 -- 要求された量に滿たなくて、まだ殘りが
                                 -- あるなら再試行。
                                 unless chunkIsOver


@@ -649,8 +652,10 @@ input limit
                                     $ tooLarge actualLimit
                             -- 成功。itr 内にチャンクを置いたままにする
                             -- とメモリの無駄になるので除去。
                                     $ tooLarge actualLimit
                             -- 成功。itr 内にチャンクを置いたままにする
                             -- とメモリの無駄になるので除去。

+                            chunk ← readItr itrReceivedBody seqToLBS itr

                             writeItr itrReceivedBody (∅) itr
                             return chunk
                             writeItr itrReceivedBody (∅) itr
                             return chunk

+

                driftTo DecidingHeader
                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.")
       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
          
 -- | 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
                         askForInput itr
                     else
                         do driftTo DecidingHeader

-                           return L8.empty
+                           return (∅)

          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
          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
                         $ 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
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                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
                    $ 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\".
 -- 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
 inputForm ∷ Int → Resource [(Text, FormData)]
 inputForm limit
     = do cTypeM ← getContentType


@@ -731,7 +746,11 @@ inputForm limit
                → readMultipartFormData params
            Just cType
                → abort UnsupportedMediaType []
                → 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)
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)


@@ -739,7 +758,7 @@ inputForm limit
             (bsToAscii =≪ input limit)
 
       bsToAscii bs
             (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")
 
               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 []
 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 ()
          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@.
 
 -- | 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 #-}
 -- \/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
 
 -- | 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 (discardBody)
              $ sendChunks wholeChunk limit
 

-         unless (L8.null wholeChunk)
+         unless (Lazy.null wholeChunk)

              $ liftIO $ atomically $
                writeItr itrBodyIsNull False itr
     where
              $ 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
       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 df98bf741c24481ed59cc468f47273657d72aa67..a593b3ad928a6710e932edfd0a2711d8a9d80b59 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -6,14 +6,13 @@
   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}

-{-# OPTIONS_HADDOCK prune #-}

 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
     , printStatusCode
 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
     , printStatusCode

-    , hPutResponse
+    , printResponse

     , isInformational
     , isSuccessful
     , isRedirection
     , isInformational
     , isSuccessful
     , isRedirection


@@ -23,11 +22,10 @@ module Network.HTTP.Lucu.Response
     , statusCode
     )
     where
     , 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 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
 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)
 
                 | 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 #))
 printStatusCode (statusCode → (# num, msg #))

-    = A.fromAsciiBuilder $
-      ( show3 num ⊕
+    = ( show3 num            ⊕

         A.toAsciiBuilder " " ⊕
         A.toAsciiBuilder msg
       )
         A.toAsciiBuilder " " ⊕
         A.toAsciiBuilder msg
       )


@@ -108,19 +105,14 @@ instance HasHeaders Response where
     getHeaders = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
 
     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
 
 -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
 isInformational ∷ StatusCode → Bool