StatusCode is now a type class, not an algebraic data type.

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b0af8d1f38d773571c8374ce4c5cff2101992b75..b5feafe4f07ed624191e74c34c3d4f73129e8c82 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -16,7 +16,8 @@ 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 qualified Data.Strict.Maybe as S
+import Data.List
+import Data.Maybe

 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))


@@ -95,7 +96,7 @@ acceptRequest ctx@(Context {..}) input
          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
          -- Request 應答を設定し、それを出力してから切斷するやうに
          -- ResponseWriter に通知する。
          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
          -- Request 應答を設定し、それを出力してから切斷するやうに
          -- ResponseWriter に通知する。

-         case LP.parse requestP input of
+         case LP.parse request input of

            LP.Done input' req → acceptParsableRequest ctx req input'
            LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
            LP.Done input' req → acceptParsableRequest ctx req input'
            LP.Fail _ _ _      → acceptNonparsableRequest ctx
 


@@ -117,7 +118,9 @@ acceptParsableRequest ctx@(Context {..}) req input
              do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
                 case rsrc of
                   Nothing
              do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
                 case rsrc of
                   Nothing

-                      → do let ar' = ar { arInitialStatus = NotFound }
+                      → do let ar' = ar {
+                                       arInitialStatus = fromStatusCode NotFound
+                                     }

                            acceptSemanticallyInvalidRequest ctx ar' input
                   Just (path, def)
                       → acceptRequestForResource ctx ar input path def
                            acceptSemanticallyInvalidRequest ctx ar' input
                   Just (path, def)
                       → acceptRequestForResource ctx ar input path def


@@ -143,6 +146,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


@@ -155,7 +159,7 @@ waitForReceiveBodyReq ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
                       → Lazy.ByteString
                       → IO ()
 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input

-    = case S.fromJust niReqBodyLength of
+    = case fromJust niReqBodyLength of

         Chunked
             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
         Fixed len
         Chunked
             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
         Fixed len


@@ -205,13 +209,13 @@ wasteAllChunks ctx rsrcTid = go
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               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: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -219,21 +223,21 @@ wasteAllChunks ctx rsrcTid = go
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in

-              case LP.parse chunkFooterP input' of
+              case LP.parse chunkFooter input' of

                 LP.Done input'' _
                     → go input'' Initial
                 LP.Done input'' _
                     → go input'' Initial

-                LP.Fail _ _ msg
-                    → chunkWasMalformed rsrcTid
-                          $ "wasteAllChunks: chunkFooterP: " ⧺ msg
+                LP.Fail _ eCtx e
+                    → chunkWasMalformed rsrcTid eCtx e
+                          "wasteAllChunks: chunkFooter"

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = case LP.parse chunkTrailerP input of
+          = case LP.parse chunkTrailer input of

               LP.Done input' _
                   → acceptRequest ctx input'
               LP.Done input' _
                   → acceptRequest ctx input'

-              LP.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkTrailer"

 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h


@@ -247,15 +251,15 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               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
-                        $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "readCurrentChunk: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -268,30 +272,35 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                    chunkLen'       = chunkLen - actualReadBytes
                atomically $ putTMVar niReceivedBody block'
                if chunkLen' ≡ 0 then
                    chunkLen'       = chunkLen - actualReadBytes
                atomically $ putTMVar niReceivedBody block'
                if chunkLen' ≡ 0 then

-                   case LP.parse chunkFooterP input' of
+                   case LP.parse chunkFooter input' of

                      LP.Done input'' _
                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
                      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: chunkFooter"

                else
                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
           = do atomically $ putTMVar niReceivedBody (∅)
                else
                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
           = do atomically $ putTMVar niReceivedBody (∅)

-               case LP.parse chunkTrailerP input of
+               case LP.parse chunkTrailer input of

                  LP.Done input' _
                      → acceptRequest ctx input'
                  LP.Done input' _
                      → acceptRequest ctx input'

-                 LP.Fail _ _ msg
-                     → chunkWasMalformed rsrcTid
-                           $ "readCurrentChunk: chunkTrailerP: " ⧺ msg
+                 LP.Fail _ eCtx e
+                     → chunkWasMalformed rsrcTid eCtx e
+                           "readCurrentChunk: chunkTrailer"

 
 

-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