MIMEParams is now an instance of collections-api's type classes.

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b0af8d1f38d773571c8374ce4c5cff2101992b75..ab70998d648e30a0e4a7f1ac74d62d190423c5d7 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse

   , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables
   , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables


@@ -16,10 +17,10 @@ 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.Monoid.Unicode
 import qualified Data.Sequence as S

-import Data.Sequence.Unicode hiding ((∅))

 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config


@@ -31,6 +32,7 @@ import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree

+import Network.HTTP.Lucu.Utils

 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)


@@ -95,7 +97,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 +119,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


@@ -140,9 +144,15 @@ acceptRequestForResource ∷ HandleLike h
                          → ResourceDef
                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
                          → ResourceDef
                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef

-    = do cert ← hGetPeerCert cHandle
+    = do
+#if defined(HAVE_SSL)
+         cert ← hGetPeerCert cHandle

          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath

+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif

          tid  ← spawnResource rsrcDef ni
          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 +165,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 +215,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 +229,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 +257,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 +278,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