Many bugfixes

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b0af8d1f38d773571c8374ce4c5cff2101992b75..5a4559e1948e29c6015ff831231b9751b91521a5 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -16,6 +16,7 @@ import Control.Monad
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
+import Data.List
 import qualified Data.Strict.Maybe as S
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
@@ -143,6 +144,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr
     = do cert ← hGetPeerCert cHandle
          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
          tid  ← spawnResource rsrcDef ni
+         enqueue ctx ni
          if reqMustHaveBody arRequest then
              waitForReceiveBodyReq ctx ni tid input
          else
@@ -209,9 +211,9 @@ wasteAllChunks ctx rsrcTid = go
               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen
-              LP.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkHeaderP"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -222,18 +224,18 @@ wasteAllChunks ctx rsrcTid = go
               case LP.parse chunkFooterP input' of
                 LP.Done input'' _
                     → go input'' Initial
-                LP.Fail _ _ msg
-                    → chunkWasMalformed rsrcTid
-                          $ "wasteAllChunks: chunkFooterP: " ⧺ msg
+                LP.Fail _ eCtx e
+                    → chunkWasMalformed rsrcTid eCtx e
+                          "wasteAllChunks: chunkFooterP"
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
           = case LP.parse chunkTrailerP input of
               LP.Done input' _
                   → acceptRequest ctx input'
-              LP.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkTrailerP"
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
@@ -253,9 +255,9 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen
-              LP.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "readCurrentChunk: chunkHeaderP"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -271,9 +273,9 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                    case LP.parse chunkFooterP input' of
                      LP.Done input'' _
                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
-                     LP.Fail _ _ msg
-                         → chunkWasMalformed rsrcTid
-                               $ "readCurrentChunk: chunkFooterP: " ⧺ msg
+                     LP.Fail _ eCtx e
+                         → chunkWasMalformed rsrcTid eCtx e
+                               "readCurrentChunk: chunkFooterP: "
                else
                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
@@ -283,15 +285,20 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                case LP.parse chunkTrailerP input of
                  LP.Done input' _
                      → acceptRequest ctx input'
-                 LP.Fail _ _ msg
-                     → chunkWasMalformed rsrcTid
-                           $ "readCurrentChunk: chunkTrailerP: " ⧺ msg
+                 LP.Fail _ eCtx e
+                     → chunkWasMalformed rsrcTid eCtx e
+                           "readCurrentChunk: chunkTrailerP"
 
-chunkWasMalformed ∷ ThreadId → String → IO ()
-chunkWasMalformed tid msg
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
     = let abo = mkAbortion BadRequest [("Connection", "close")]
                 $ Just
-                $ "chunkWasMalformed: " ⊕ T.pack msg
+                $ "chunkWasMalformed: "
+                ⊕ T.pack msg
+                ⊕ ": "
+                ⊕ T.pack (intercalate ", " eCtx)
+                ⊕ ": "
+                ⊕ T.pack e
       in
         throwTo tid abo