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 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
 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
     = 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
          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.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
 
       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
               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'
 
       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
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h


@@ -253,9 +255,9 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen
                       → 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
 
       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
                    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'
 
                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'
                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
     = 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
 
       in
         throwTo tid abo