Many bugfixes

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 314e1f55972c1ac40d26deaadeb64602fbb1df12..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


@@ -28,8 +29,8 @@
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the

---   request header fields and thinks about a corresponding entity for
---   it. If there is a suitable entity, the 'Resource' tells the
+--   request header fields and thinks about the corresponding entity
+--   for it. If there is a suitable entity, the 'Resource' tells the

 --   system an entity tag and its last modification time
 --   ('foundEntity'). If it found no entity, it tells the system so
 --   ('foundNoEntity'). In case it is impossible to decide the
 --   system an entity tag and its last modification time
 --   ('foundEntity'). If it found no entity, it tells the system so
 --   ('foundNoEntity'). In case it is impossible to decide the


@@ -41,11 +42,11 @@
 --   socket, the system sends \"100 Continue\" to the client if need
 --   be. When a 'Resource' transits to the next state without
 --   receiving all or part of a request body, the system automatically
 --   socket, the system sends \"100 Continue\" to the client if need
 --   be. When a 'Resource' transits to the next state without
 --   receiving all or part of a request body, the system automatically

---   receives and discards it.
+--   discards it.

 --
 --

---   [/Deciding Header/] A 'Resource' makes a decision of status code
---   and response header fields. When it transits to the next state,
---   the system validates and completes the response header fields and
+--   [/Deciding Header/] A 'Resource' makes a decision of response
+--   status code and header fields. When it transits to the next
+--   state, the system validates and completes the header fields and

 --   then sends them to the client.
 --
 --   [/Sending Body/] In this state, a 'Resource' asks the system to
 --   then sends them to the client.
 --
 --   [/Sending Body/] In this state, a 'Resource' asks the system to


@@ -103,6 +104,7 @@ module Network.HTTP.Lucu.Resource
     , foundETag
     , foundTimeStamp
     , foundNoEntity
     , foundETag
     , foundTimeStamp
     , foundNoEntity

+    , foundNoEntity'

 
     -- * Receiving a request body
     -- |These functions make the 'Resource' transit to the /Receiving
 
     -- * Receiving a request body
     -- |These functions make the 'Resource' transit to the /Receiving


@@ -127,14 +129,17 @@ module Network.HTTP.Lucu.Resource
     , deleteHeader
 
     -- * Sending a response body
     , deleteHeader
 
     -- * Sending a response body

-    -- |These functions make the 'Resource' transit to the /Sending
-    -- Body/ state.
+
+    -- |These functions make the 'Resource' transit to the
+    -- /Sending Body/ state.

     , putChunk
     , putChunks
     , putBuilder
     )
     where
     , putChunk
     , putChunks
     , 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


@@ -146,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


@@ -239,7 +241,7 @@ toPairWithFormData (name, value)
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that
 -- this function is not intended to be used so frequently: there
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that
 -- this function is not intended to be used so frequently: there

--- should be actions like 'getContentType' for every common headers.
+-- should be functions like 'getContentType' for every common headers.

 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest


@@ -297,7 +299,8 @@ getAcceptEncoding
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 

--- |Return 'True' iff a given content-coding is acceptable.
+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.

 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where
 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where


@@ -519,6 +522,11 @@ foundNoEntity msgM
 
          driftTo ReceivingBody
 
 
          driftTo ReceivingBody
 

+-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
+foundNoEntity' ∷ Resource ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+

 
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the
 
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the


@@ -530,8 +538,8 @@ foundNoEntity msgM
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- limitation value ('cnfMaxEntityLength') instead.
 --
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- limitation value ('cnfMaxEntityLength') instead.
 --

--- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
+-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
+-- lazy: reading from the socket just happens at the computation of

 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 getChunks ∷ Maybe Int → Resource Lazy.ByteString
 getChunks (Just n)
 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 getChunks ∷ Maybe Int → Resource Lazy.ByteString
 getChunks (Just n)


@@ -544,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


@@ -616,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


@@ -666,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
 


@@ -681,9 +696,8 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 

--- |Write a chunk in 'Lazy.ByteString' to the response body. It is
--- safe to apply this function to an infinitely long
--- 'Lazy.ByteString'.
+-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
+-- can be safely applied to an infinitely long 'Lazy.ByteString'.

 --
 -- Note that you must first declare the response header
 -- \"Content-Type\" before applying this function. See
 --
 -- Note that you must first declare the response header
 -- \"Content-Type\" before applying this function. See