X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=4c59b3e9f8b1ac5a1524d634d2595a339c80c853;hp=05b30420a95040bf9284b94d19bfb913fde51ae4;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=8225cc52ffe4c3d900ae1f79573089be230b80bd

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 05b3042..4c59b3e 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE
-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse
+  , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax
@@ -8,29 +10,30 @@ module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where
-import Control.Applicative
+import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception hiding (block)
 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 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
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Preprocess
 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 Network.URI
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 
@@ -64,47 +67,41 @@ requestReader cnf tree fbs h port addr tQueue
          acceptRequest (Context cnf tree fbs h port addr tQueue) input
       `catches`
       [ Handler handleAsyncE
-      , Handler handleBIOS
       , Handler handleOthers
       ]
+      `finally`
+      enqueue' tQueue EndOfInteraction
     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 
-      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
-      handleBIOS = dump
-
       handleOthers ∷ SomeException → IO ()
       handleOthers = dump
 
       dump ∷ Exception e ⇒ e → IO ()
       dump e
-          = do hPutStrLn stderr "requestReader caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+          = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
+               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 BadRequest
+         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 → StatusCode → IO ()
-acceptNonparsableRequest ctx@(Context {..}) sc
-    = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
-         atomically $
-             do writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
+acceptNonparsableRequest ctx@(Context {..})
+    = do syi ← mkSyntacticallyInvalidInteraction cConfig
+         enqueue ctx syi
 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h
@@ -112,129 +109,116 @@ acceptParsableRequest ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input
-    = do cert ← hGetPeerCert cHandle
-         itr  ← newInteraction cConfig cPort cAddr cert (Right req)
-         join $ atomically
-              $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
-                   if isErr then
-                       acceptSemanticallyInvalidRequest ctx itr input
-                   else
-                       return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
+    = do let ar = preprocess (cnfServerHost cConfig) cPort req
+         if isError $ arInitialStatus ar then
+             acceptSemanticallyInvalidRequest ctx ar input
+         else
+             do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+                case rsrc of
+                  Nothing
+                      → do let ar' = ar {
+                                       arInitialStatus = fromStatusCode NotFound
+                                     }
+                           acceptSemanticallyInvalidRequest ctx ar' input
+                  Just (path, def)
+                      → acceptRequestForResource ctx ar input path def
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
-                                 → Interaction
+                                 → AugmentedRequest
                                  → Lazy.ByteString
-                                 → STM (IO ())
-acceptSemanticallyInvalidRequest ctx itr input
-    = do writeTVar (itrState itr) Done
-         postprocess itr
-         enqueue ctx itr
-         return $ acceptRequest ctx input
-
-acceptSemanticallyValidRequest ∷ HandleLike h
-                               ⇒ Context h
-                               → Interaction
-                               → URI
-                               → Lazy.ByteString
-                               → IO ()
-acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
-    = do rsrcM ← findResource cResTree cFallbacks uri
-         case rsrcM of
-           Nothing
-               → acceptRequestForNonexistentResource ctx itr input
-           Just (rsrcPath, rsrcDef)
-               → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-
-acceptRequestForNonexistentResource ∷ HandleLike h
-                                    ⇒ Context h
-                                    → Interaction
-                                    → Lazy.ByteString
-                                    → IO ()
-acceptRequestForNonexistentResource ctx itr input
-    = do atomically $
-             do setResponseStatus itr NotFound
-                writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+                                 → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+    = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+         enqueue ctx sei
          acceptRequest ctx input
 
-acceptRequestForExistentResource ∷ HandleLike h
-                                 ⇒ Context h
-                                 → Interaction
-                                 → Lazy.ByteString
-                                 → [Strict.ByteString]
-                                 → ResourceDef
-                                 → IO ()
-acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
-    = do let itr = oldItr { itrResourcePath = Just rsrcPath }
-         atomically $ enqueue ctx itr
-         do _ ← spawnResource rsrcDef itr
-            if reqMustHaveBody $ fromJust $ itrRequest itr then
-                waitForReceiveBodyReq ctx itr input
-            else
-                acceptRequest ctx input
+acceptRequestForResource ∷ HandleLike h
+                         ⇒ Context h
+                         → AugmentedRequest
+                         → Lazy.ByteString
+                         → [Strict.ByteString]
+                         → Resource
+                         → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+    = do
+#if defined(HAVE_SSL)
+         cert ← hGetPeerCert cHandle
+         ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+         tid  ← spawnRsrc rsrcDef ni
+         enqueue ctx ni
+         if reqMustHaveBody arRequest then
+             waitForReceiveBodyReq ctx ni tid input
+         else
+             acceptRequest ctx input
 
 waitForReceiveBodyReq ∷ HandleLike h
                       ⇒ Context h
-                      → Interaction
+                      → NormalInteraction
+                      → ThreadId
                       → Lazy.ByteString
                       → IO ()
-waitForReceiveBodyReq ctx itr input
-    = case fromJust $ itrReqBodyLength itr of
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+    = case fromJust niReqBodyLength of
         Chunked
-            → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+            → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
         Fixed len
-            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
 
 -- Toooooo long name for a function...
 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                             ⇒ Context h
-                                            → Interaction
+                                            → NormalInteraction
+                                            → ThreadId
                                             → Lazy.ByteString
                                             → IO ()
-waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
     = join $
       atomically $
-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq
          case req of
            ReceiveBody wanted
-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readCurrentChunk ctx itr input Initial wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
            WasteAll
-               → do putTMVar itrSendContinue False
-                    return $ wasteAllChunks ctx itr input Initial
+               → do putTMVar niSendContinue False
+                    return $ wasteAllChunks ctx rsrcTid input Initial
 
 waitForReceiveChunkedBodyReq ∷ HandleLike h
                              ⇒ Context h
-                             → Interaction
+                             → NormalInteraction
+                             → ThreadId
                              → Lazy.ByteString
                              → ChunkReceivingState
                              → IO ()
-waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+    = do req ← atomically $ takeTMVar niReceiveBodyReq
          case req of
            ReceiveBody wanted
-               → readCurrentChunk ctx itr input st wanted
+               → readCurrentChunk ctx ni rsrcTid wanted input st
            WasteAll
-               → wasteAllChunks ctx itr input st
+               → wasteAllChunks ctx rsrcTid input st
 
 wasteAllChunks ∷ HandleLike h
                ⇒ Context h
-               → Interaction
+               → ThreadId
                → Lazy.ByteString
                → ChunkReceivingState
                → IO ()
-wasteAllChunks ctx itr = go
+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 _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                       "wasteAllChunks: chunkHeader"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -242,44 +226,43 @@ wasteAllChunks ctx itr = 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 _ _ _
-                    → chunkWasMalformed itr
+                LP.Fail _ eCtx e
+                    → chunkWasMalformed rsrcTid eCtx e
+                          "wasteAllChunks: chunkFooter"
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
-          = case LP.parse chunkFooterP input of
+          = case LP.parse chunkTrailer input of
               LP.Done input' _
-                  → case LP.parse chunkTrailerP input' of
-                       LP.Done input'' _
-                           → acceptRequest ctx input''
-                       LP.Fail _ _ _
-                           → chunkWasMalformed itr
-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+                  → acceptRequest ctx input'
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkTrailer"
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
-                 → Interaction
+                 → NormalInteraction
+                 → ThreadId
+                 → Int
                  → Lazy.ByteString
                  → ChunkReceivingState
-                 → Int
                  → IO ()
-readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
-    = go input0 st0
+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 _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "readCurrentChunk: chunkHeader"
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
@@ -290,67 +273,69 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    chunkLen'       = chunkLen - actualReadBytes
-               atomically $ putTMVar itrReceivedBody block'
+               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 itr input'' Initial
-                     LP.Fail _ _ _
-                         → chunkWasMalformed itr
+                         → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+                     LP.Fail _ eCtx e
+                         → chunkWasMalformed rsrcTid eCtx e
+                               "readCurrentChunk: chunkFooter"
                else
-                   waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+                   waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
-          = do atomically $ putTMVar itrReceivedBody (∅)
-               case LP.parse chunkFooterP input of
+          = do atomically $ putTMVar niReceivedBody (∅)
+               case LP.parse chunkTrailer input of
                  LP.Done input' _
-                     → case LP.parse chunkTrailerP input' of
-                          LP.Done input'' _
-                              → acceptRequest ctx input''
-                          LP.Fail _ _ _
-                              → chunkWasMalformed itr
-                 LP.Fail _ _ _
-                     → chunkWasMalformed itr
+                     → acceptRequest ctx input'
+                 LP.Fail _ eCtx e
+                     → chunkWasMalformed rsrcTid eCtx e
+                           "readCurrentChunk: chunkTrailer"
 
-chunkWasMalformed ∷ Interaction → IO ()
-chunkWasMalformed itr
-    -- FIXME: This is a totally wrong way to abort!
-    = atomically $
-      do setResponseStatus itr BadRequest
-         writeTVar (itrWillClose itr) True
-         writeTVar (itrState     itr) Done
-         postprocess itr
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
+    = let abo = mkAbortion BadRequest [("Connection", "close")]
+                $ Just
+                $ "chunkWasMalformed: "
+                ⊕ T.pack msg
+                ⊕ ": "
+                ⊕ T.pack (intercalate ", " eCtx)
+                ⊕ ": "
+                ⊕ T.pack e
+      in
+        throwTo tid abo
 
 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                                ⇒ Context h
-                                               → Interaction
+                                               → NormalInteraction
                                                → Lazy.ByteString
                                                → Int
                                                → IO ()
-waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
     = join $
       atomically $
-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq
          case req of
            ReceiveBody wanted
-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
            WasteAll
-               → do putTMVar itrSendContinue False
+               → do putTMVar niSendContinue False
                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 
 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                 ⇒ Context h
-                                → Interaction
+                                → NormalInteraction
                                 → Lazy.ByteString
                                 → Int
                                 → IO ()
-waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+    = do req ← atomically $ takeTMVar niReceiveBodyReq
          case req of
            ReceiveBody wanted
-               → readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → readNonChunkedRequestBody ctx ni input bodyLen wanted
            WasteAll
                → wasteNonChunkedRequestBody ctx input bodyLen
 
@@ -365,12 +350,12 @@ wasteNonChunkedRequestBody ctx input bodyLen
 
 readNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h
-                          → Interaction
+                          → NormalInteraction
                           → Lazy.ByteString
                           → Int
                           → Int
                           → IO ()
-readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
     | bodyLen ≡ 0 = gotEndOfRequest
     | otherwise   = gotBody
     where
@@ -381,15 +366,19 @@ readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    bodyLen'        = bodyLen - actualReadBytes
-               atomically $ putTMVar itrReceivedBody block'
-               waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+               atomically $ putTMVar niReceivedBody block'
+               waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
 
       gotEndOfRequest ∷ IO ()
       gotEndOfRequest
-          = do atomically $ putTMVar itrReceivedBody (∅)
+          = do atomically $ putTMVar niReceivedBody (∅)
                acceptRequest ctx input
 
-enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
-enqueue (Context {..}) itr
-    = do queue ← readTVar cQueue
-         writeTVar cQueue (itr ⊲ queue)
+enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
+    = atomically $
+      do queue ← readTVar tQueue
+         writeTVar tQueue (toInteraction itr ⊲ queue)