Many bugfixes

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index d61f2f45ec3950505020c19c770559ecdd0a2d3b..71ff4838c3945380d44f2dee36fddc2b3952d3d1 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    GeneralizedNewtypeDeriving
+    BangPatterns
+  , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
@@ -136,7 +137,9 @@ module Network.HTTP.Lucu.Resource
     , putBuilder
     )
     where
-import qualified Blaze.ByteString.Builder.ByteString as BB
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
@@ -148,14 +151,11 @@ import qualified Data.Attoparsec.Lazy  as LP
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
-import qualified Data.ByteString.Lazy.Internal as Lazy
-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.Sequence.Unicode hiding ((∅))
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -552,24 +552,23 @@ getChunks Nothing
 getChunks' ∷ Int → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where
-      go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
-      go 0 _  = do chunk ← getChunk 1
-                   if Strict.null chunk then
-                       return (∅)
-                   else
-                       abort $ mkAbortion' RequestEntityTooLarge
-                             $ "Request body must be smaller than "
-                             ⊕ T.pack (show limit)
-                             ⊕ " bytes."
-      go n xs = do let n' = min n Lazy.defaultChunkSize
-                   chunk ← getChunk n'
-                   if Strict.null chunk then
-                       -- Got EOF
-                       return $ Lazy.fromChunks $ toList xs
-                   else
-                       do let n'' = n' - Strict.length chunk
-                              xs' = xs ⊳ chunk
-                          go n'' xs'
+      go ∷ Int → Builder → Resource Lazy.ByteString
+      go  0  _ = do chunk ← getChunk 1
+                    if Strict.null chunk then
+                        return (∅)
+                    else
+                        abort $ mkAbortion' RequestEntityTooLarge
+                              $ "Request body must be smaller than "
+                              ⊕ T.pack (show limit)
+                              ⊕ " bytes."
+      go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
+                    if Strict.null c then
+                        -- Got EOF
+                        return $ BB.toLazyByteString b
+                    else
+                        do let n'  = n - Strict.length c
+                               xs' = b ⊕ BB.fromByteString c
+                           go n' xs'
 
 -- |@'getForm' limit@ attempts to read the request body with
 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
@@ -624,7 +623,12 @@ getForm limit
                        case LP.parse (p b) src of
                          LP.Done _ formList
                              → return formList
-                         _   → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"
+                         LP.Fail _ eCtx e
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Unparsable multipart/form-data: "
+                                     ⊕ T.pack (intercalate ", " eCtx)
+                                     ⊕ ": "
+                                     ⊕ T.pack e
           where
             p b = do xs ← multipartFormP b
                      P.endOfInput
@@ -674,7 +678,10 @@ setContentEncoding codings
                   _               → abort $ mkAbortion' InternalServerError
                                             "setContentEncoding: Unknown HTTP version"
          setHeader "Content-Encoding"
-                   (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
+             $ A.fromAsciiBuilder
+             $ mconcat
+             $ intersperse (A.toAsciiBuilder ", ")
+             $ map tr codings
     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii