X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=37ab99296c2e0b7dff2eb7321e37ef6633e70a54;hb=1b822bc79ce9fd0ee537fe81819e7501af83f7bd;hp=b0af8d1f38d773571c8374ce4c5cff2101992b75;hpb=f402841101b4b84f263eea1a43c848f81c48ff93;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b0af8d1..37ab992 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse
   , 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.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 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.Utils
 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
@@ -68,6 +70,8 @@ requestReader cnf tree fbs h port addr tQueue
       , Handler handleBIOS
       , Handler handleOthers
       ]
+      `finally`
+      enqueue' tQueue EndOfInteraction
     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
@@ -82,22 +86,21 @@ requestReader cnf tree fbs h port addr tQueue
       dump ∷ Exception e ⇒ e → IO ()
       dump e
           = do hPutStrLn stderr "requestReader caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+               hPutStrLn stderr $ show e
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
-    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
-    -- それが限度以下になるまで待つ。
     = do atomically $
              do queue ← readTVar cQueue
-                when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+                when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
+                    -- Too many requests in the pipeline...
                     retry
-         -- リクエストを讀む。パースできない場合は直ちに 400 Bad
-         -- Request 應答を設定し、それを出力してから切斷するやうに
-         -- ResponseWriter に通知する。
-         case LP.parse requestP input of
-           LP.Done input' req → acceptParsableRequest ctx req input'
-           LP.Fail _ _ _      → acceptNonparsableRequest ctx
+         if Lazy.null input then
+             return ()
+         else
+             case LP.parse request input of
+               LP.Done input' req → acceptParsableRequest ctx req input'
+               LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 acceptNonparsableRequest ctx@(Context {..})
@@ -117,7 +120,9 @@ acceptParsableRequest ctx@(Context {..}) req input
              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
@@ -140,9 +145,15 @@ acceptRequestForResource ∷ HandleLike h
                          → 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
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
          tid  ← spawnResource rsrcDef ni
+         enqueue ctx ni
          if reqMustHaveBody arRequest then
              waitForReceiveBodyReq ctx ni tid input
          else
@@ -155,7 +166,7 @@ waitForReceiveBodyReq ∷ HandleLike h
                       → 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
@@ -205,13 +216,13 @@ wasteAllChunks ctx rsrcTid = go
     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.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                       "wasteAllChunks: chunkHeader"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -219,21 +230,21 @@ wasteAllChunks ctx rsrcTid = go
       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.Fail _ _ msg
-                    → chunkWasMalformed rsrcTid
-                          $ "wasteAllChunks: chunkFooterP: " ⧺ msg
+                LP.Fail _ eCtx e
+                    → chunkWasMalformed rsrcTid eCtx e
+                          "wasteAllChunks: chunkFooter"
 
       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.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkTrailer"
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
@@ -247,15 +258,15 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
     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.Fail _ _ msg
-                  → chunkWasMalformed rsrcTid
-                        $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "readCurrentChunk: chunkHeader"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -268,30 +279,35 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                    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.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 (∅)
-               case LP.parse chunkTrailerP input of
+               case LP.parse chunkTrailer 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: 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
-                $ "chunkWasMalformed: " ⊕ T.pack msg
+                $ "chunkWasMalformed: "
+                ⊕ T.pack msg
+                ⊕ ": "
+                ⊕ T.pack (intercalate ", " eCtx)
+                ⊕ ": "
+                ⊕ T.pack e
       in
         throwTo tid abo
 
@@ -363,8 +379,10 @@ readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
                acceptRequest ctx input
 
 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
-{-# INLINEABLE enqueue #-}
-enqueue (Context {..}) itr
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
     = atomically $
-      do queue ← readTVar cQueue
-         writeTVar cQueue (toInteraction itr ⊲ queue)
+      do queue ← readTVar tQueue
+         writeTVar tQueue (toInteraction itr ⊲ queue)