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
 {-# LANGUAGE

-    GeneralizedNewtypeDeriving
+    BangPatterns
+  , GeneralizedNewtypeDeriving

   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards


@@ -136,7 +137,9 @@ module Network.HTTP.Lucu.Resource
     , putBuilder
     )
     where
     , 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
 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 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.List
 import qualified Data.Map as M
 import Data.Maybe

+import Data.Monoid

 import Data.Monoid.Unicode
 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
 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
 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
 
 -- |@'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
                        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
           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"
                   _               → 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
 
     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii