X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=05b30420a95040bf9284b94d19bfb913fde51ae4;hb=8225cc5;hp=58183787a3942b81993e3ba00ca22e67b3b8fa90;hpb=ca338174155913a969808d7b20193973394e474e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 5818378..05b3042 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -9,28 +9,30 @@ module Network.HTTP.Lucu.RequestReader
     )
     where
 import Control.Applicative
-import           Control.Concurrent.STM
-import           Control.Exception
-import           Control.Monad
+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.Maybe
+import Data.Maybe
+import Data.Monoid.Unicode
 import qualified Data.Sequence as S
-import Data.Sequence.Unicode
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.Chunk
-import           Network.HTTP.Lucu.DefaultPage
-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.Tree
+import Data.Sequence.Unicode hiding ((∅))
+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.Socket
 import Network.URI
 import Prelude.Unicode
-import           System.IO (hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
 
 data Context h
     = Context {
@@ -43,6 +45,11 @@ data Context h
       , cQueue     ∷ !InteractionQueue
       }
 
+data ChunkReceivingState
+    = Initial
+    | InChunk !Int -- ^Number of remaining octets in the current
+                   -- chunk. It's always positive.
+
 requestReader ∷ HandleLike h
               ⇒ Config
               → ResTree
@@ -56,13 +63,25 @@ requestReader cnf tree fbs h port addr tQueue
     = do input ← hGetLBS h
          acceptRequest (Context cnf tree fbs h port addr tQueue) input
       `catches`
-      [ Handler $ \ (_ ∷ IOException)        → return ()
-      , Handler $ \ e → case e of
-                           ThreadKilled      → return ()
-                           _                 → hPutStrLn stderr (show e)
-      , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
-      , Handler $ \ (e ∷ SomeException)      → hPutStrLn stderr (show e)
+      [ Handler handleAsyncE
+      , Handler handleBIOS
+      , Handler handleOthers
       ]
+    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)
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
@@ -76,43 +95,42 @@ acceptRequest ctx@(Context {..}) input
          -- Request 應答を設定し、それを出力してから切斷するやうに
          -- ResponseWriter に通知する。
          case LP.parse requestP input of
-           LP.Done input' req → acceptParsableRequest req input'
+           LP.Done input' req → acceptParsableRequest ctx req input'
            LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
 
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
-acceptNonparsableRequest (Context {..}) status
-    = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing
+acceptNonparsableRequest ctx@(Context {..}) sc
+    = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
          atomically $
-             do setResponseStatus itr status
-                writeTVar (itrWillClose itr) True
-                writeTVar (itrState     itr) Done
-                writeDefaultPage itr
+             do writeTVar (itrState itr) Done
                 postprocess itr
-                enqueue itr
+                enqueue ctx itr
 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h
                       → Request
                       → Lazy.ByteString
                       → IO ()
-acceptParsableRequest (Context {..}) req input
+acceptParsableRequest ctx@(Context {..}) req input
     = do cert ← hGetPeerCert cHandle
          itr  ← newInteraction cConfig cPort cAddr cert (Right req)
          join $ atomically
-              $ do preprocess itr
-                   isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
+              $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
                    if isErr then
-                       acceptSemanticallyInvalidRequest itr input
+                       acceptSemanticallyInvalidRequest ctx itr input
                    else
-                       acceptSemanticallyValidRequest itr (reqURI req) input
+                       return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
 
-acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ())
-acceptSemanticallyInvalidRequest itr input
-    = do writeTVar (itr itrState) Done
-         writeDefaultPage itr
+acceptSemanticallyInvalidRequest ∷ HandleLike h
+                                 ⇒ Context h
+                                 → Interaction
+                                 → Lazy.ByteString
+                                 → STM (IO ())
+acceptSemanticallyInvalidRequest ctx itr input
+    = do writeTVar (itrState itr) Done
          postprocess itr
-         enqueue itr
-         return $ acceptRequest input
+         enqueue ctx itr
+         return $ acceptRequest ctx input
 
 acceptSemanticallyValidRequest ∷ HandleLike h
                                ⇒ Context h
@@ -120,161 +138,256 @@ acceptSemanticallyValidRequest ∷ HandleLike h
                                → URI
                                → Lazy.ByteString
                                → IO ()
-acceptSemanticallyValidRequest (Context {..}) itr uri input
+acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
     = do rsrcM ← findResource cResTree cFallbacks uri
          case rsrcM of
            Nothing
-               → acceptRequestForNonexistentResource itr input
+               → acceptRequestForNonexistentResource ctx itr input
            Just (rsrcPath, rsrcDef)
-               → acceptRequestForExistentResource itr input rsrcPath rsrcDef
+               → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
 
-acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ())
-acceptRequestForNonexistentResource itr input
-    = do setResponseStatus itr NotFound
-         writeTVar (itrState itr) Done
-         writeDefaultPage itr
-         postprocess itr
-         enqueue itr
-         return $ acceptRequest input
+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
+         acceptRequest ctx input
 
-acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ())
-acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+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 }
-         enqueue itr
-         return $ do _ ← runResource rsrcDef itr
-                     if reqHasBody $ fromJust $ itrRequest itr then
-                         observeRequest itr input
-                     else
-                         acceptRequest input
+         atomically $ enqueue ctx itr
+         do _ ← spawnResource rsrcDef itr
+            if reqMustHaveBody $ fromJust $ itrRequest itr then
+                waitForReceiveBodyReq ctx itr input
+            else
+                acceptRequest ctx input
 
-observeRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeRequest itr input
-    | itrReqBodyLength itr ≡ Just Chunked
-        = observeChunkedRequest itr input
-    | otherwise
-        = observeNonChunkedRequest itr input
+waitForReceiveBodyReq ∷ HandleLike h
+                      ⇒ Context h
+                      → Interaction
+                      → Lazy.ByteString
+                      → IO ()
+waitForReceiveBodyReq ctx itr input
+    = case fromJust $ itrReqBodyLength itr of
+        Chunked
+            → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+        Fixed len
+            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
 
-observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeChunkedRequest itr input
+-- Toooooo long name for a function...
+waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
+                                            ⇒ Context h
+                                            → Interaction
+                                            → Lazy.ByteString
+                                            → IO ()
+waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
     = join $
       atomically $
-      do isOver ← readTVar $ itrReqChunkIsOver itr
-         if isOver then
-             return $ acceptRequest input
-         else
-             do wantedM ← readTVar $ itrReqBodyWanted itr
-                if isNothing wantedM then
-                    do wasteAll ← readTVar $ itrReqBodyWasteAll itr
-                       if wasteAll then
-                           wasteCurrentChunk input
-                       else
-                           retry
-                else
-                    readCurrentChunk (fromJust wantedM)
+      do req ← takeTMVar itrReceiveBodyReq
+         case req of
+           ReceiveBody wanted
+               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
+                    return $ readCurrentChunk ctx itr input Initial wanted
+           WasteAll
+               → do putTMVar itrSendContinue False
+                    return $ wasteAllChunks ctx itr input Initial
+
+waitForReceiveChunkedBodyReq ∷ HandleLike h
+                             ⇒ Context h
+                             → Interaction
+                             → Lazy.ByteString
+                             → ChunkReceivingState
+                             → IO ()
+waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
+    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+         case req of
+           ReceiveBody wanted
+               → readCurrentChunk ctx itr input st wanted
+           WasteAll
+               → wasteAllChunks ctx itr input st
+
+wasteAllChunks ∷ HandleLike h
+               ⇒ Context h
+               → Interaction
+               → Lazy.ByteString
+               → ChunkReceivingState
+               → IO ()
+wasteAllChunks ctx itr = go
+    where
+      go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+      go input Initial
+          = case LP.parse chunkHeaderP input of
+              LP.Done input' chunkLen
+                  | chunkLen ≡ 0 → gotFinalChunk input'
+                  | otherwise    → gotChunk input' chunkLen
+              LP.Fail _ _ _
+                  → chunkWasMalformed itr
+      go input (InChunk chunkLen)
+          = gotChunk input chunkLen
+
+      gotChunk ∷ Lazy.ByteString → Int → IO ()
+      gotChunk input chunkLen
+          = let input' = Lazy.drop (fromIntegral chunkLen) input
+            in
+              case LP.parse chunkFooterP input' of
+                LP.Done input'' _
+                    → go input'' Initial
+                LP.Fail _ _ _
+                    → chunkWasMalformed itr
 
-wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO ()
-wasteCurrentChunk itr input len
-    | len > 0
-        = let input' = Lazy.drop (fromIntegral len) input
-          in
-            case LP.parse chunkFooterP input' of
-              LP.Done input'' _
-                  → observeChunkedRequest itr input''
+      gotFinalChunk ∷ Lazy.ByteString → IO ()
+      gotFinalChunk input
+          = case LP.parse chunkFooterP 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
-    | otherwise
-        = seekNextChunk itr input
 
-readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO ()
-readCurrentChunk itr input wanted remaining
-    | remaining > 0
-        = do let bytesToRead     = fromIntegral $ min wanted remaining
-                 (chunk, input') = Lazy.splitAt bytesToRead input
-                 actualReadBytes = fromIntegral $ Lazy.length chunk
-                 newWanted       = case wanted - actualReadBytes of
-                                     0 → Nothing
-                                     n → Just n
-                 newRemaining    = Just $ remaining - actualReadBytes
-                 updateStates    = do writeTVar (itrReqBodyWanted itr) newWanted
-                                      oldBody    ← readTVar $ itrReceivedBody    itr
-                                      oldBodyLen ← readTVar $ itrReceivedBodyLen itr
-                                      writeTVar (itrReceivedBody    itr) $ oldBody ⊳ chunk
-                                      writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
-             if newRemaining ≡ Just 0 then
-                 case LP.parse chunkFooterP input' of
-                   LP.Done input'' _
-                       → do updateStates
-                            observeChunkedRequest itr input''
-                   LP.Fail _ _ _
-                       → chunkWasMalformed itr
-             else
-                 do updateStates
-                    observeChunkedRequest itr input'
-    | otherwise
-        = seekNextChunk itr input
+readCurrentChunk ∷ HandleLike h
+                 ⇒ Context h
+                 → Interaction
+                 → Lazy.ByteString
+                 → ChunkReceivingState
+                 → Int
+                 → IO ()
+readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
+    = go input0 st0
+    where
+      go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+      go input Initial
+          = case LP.parse chunkHeaderP input of
+              LP.Done input' chunkLen
+                  | chunkLen ≡ 0
+                      → gotFinalChunk input'
+                  | otherwise
+                      → gotChunk input' chunkLen
+              LP.Fail _ _ _
+                  → chunkWasMalformed itr
+      go input (InChunk chunkLen)
+          = gotChunk input chunkLen
 
-seekNextChunk ∷ Interaction → Lazy.ByteString → IO ()
-seekNextChunk itr input
-    = case LP.parse chunkHeaderP input of
-        LP.Done input' len
-            | len ≡ 0 -- Final chunk
-                → case LP.parse chunkTrailerP input' of
+      gotChunk ∷ Lazy.ByteString → Int → IO ()
+      gotChunk input chunkLen
+          = do let bytesToRead     = min wanted chunkLen
+                   (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
+                   block'          = Strict.concat $ Lazy.toChunks block
+                   actualReadBytes = Strict.length block'
+                   chunkLen'       = chunkLen - actualReadBytes
+               atomically $ putTMVar itrReceivedBody block'
+               if chunkLen' ≡ 0 then
+                   case LP.parse chunkFooterP input' of
                      LP.Done input'' _
-                         → do writeTVar (itrReqChunkIsOver itr) True
-                              acceptRequest input''
+                         → waitForReceiveChunkedBodyReq ctx itr input'' Initial
                      LP.Fail _ _ _
                          → chunkWasMalformed itr
-            | otherwise -- Non-final chunk
-                →  do observeChunkedRequest itr input'
-        LP.Fail _ _ _
-                → chunkWasMalformed itr
+               else
+                   waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+
+      gotFinalChunk ∷ Lazy.ByteString → IO ()
+      gotFinalChunk input
+          = do atomically $ putTMVar itrReceivedBody (∅)
+               case LP.parse chunkFooterP 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
 
 chunkWasMalformed ∷ Interaction → IO ()
 chunkWasMalformed itr
+    -- FIXME: This is a totally wrong way to abort!
     = atomically $
-          do setResponseStatus BadRequest
-             writeTVar (itrWillClose itr) True
-             writeTVar (itrState     itr) Done
-             writeDefaultPage itr
-             postprocess itr
+      do setResponseStatus itr BadRequest
+         writeTVar (itrWillClose itr) True
+         writeTVar (itrState     itr) Done
+         postprocess itr
 
-observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeNonChunkedRequest itr input
+waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
+                                               ⇒ Context h
+                                               → Interaction
+                                               → Lazy.ByteString
+                                               → Int
+                                               → IO ()
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
     = join $
       atomically $
-      do wantedM ← readTVar $ itrReqBodyWanted itr
-         if isNothing wantedM then
-             do wasteAll ← readTVar itr itrReqBodyWasteAll id
-                if wasteAll then
-                    wasteNonChunkedRequestBody itr input
-                else
-                    retry
-         else
-             readNonChunkedRequestBody itr input
+      do req ← takeTMVar itrReceiveBodyReq
+         case req of
+           ReceiveBody wanted
+               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
+                    return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+           WasteAll
+               → do putTMVar itrSendContinue False
+                    return $ wasteNonChunkedRequestBody ctx input bodyLen
 
-wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO ()
-wasteNonChunkedRequestBody itr input remaining
-    = do let input' = case remaining of
-                        Just len → Lazy.drop len input
-                        Nothing  → (∅)
-         writeTVar (itrReqChunkIsOver itr) True
-         acceptRequest input'
+waitForReceiveNonChunkedBodyReq ∷ HandleLike h
+                                ⇒ Context h
+                                → Interaction
+                                → Lazy.ByteString
+                                → Int
+                                → IO ()
+waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
+    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+         case req of
+           ReceiveBody wanted
+               → readNonChunkedRequestBody ctx itr input bodyLen wanted
+           WasteAll
+               → wasteNonChunkedRequestBody ctx input bodyLen
+
+wasteNonChunkedRequestBody ∷ HandleLike h
+                           ⇒ Context h
+                           → Lazy.ByteString
+                           → Int
+                           → IO ()
+wasteNonChunkedRequestBody ctx input bodyLen
+    = do let input' = Lazy.drop (fromIntegral bodyLen) input
+         acceptRequest ctx input'
+
+readNonChunkedRequestBody ∷ HandleLike h
+                          ⇒ Context h
+                          → Interaction
+                          → Lazy.ByteString
+                          → Int
+                          → Int
+                          → IO ()
+readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+    | bodyLen ≡ 0 = gotEndOfRequest
+    | otherwise   = gotBody
+    where
+      gotBody ∷ IO ()
+      gotBody
+          = do let bytesToRead     = min wanted bodyLen
+                   (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
+                   block'          = Strict.concat $ Lazy.toChunks block
+                   actualReadBytes = Strict.length block'
+                   bodyLen'        = bodyLen - actualReadBytes
+               atomically $ putTMVar itrReceivedBody block'
+               waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
 
-readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO ()
-readNonChunkedRequestBody itr input wanted remaining
-    = do let bytesToRead     = fromIntegral $ maybe wanted (min wanted) remaining
-             (chunk, input') = Lazy.splitAt bytesToRead input
-             actualReadBytes = fromIntegral $ Lazy.length chunk
-             newRemaining    = (- actualReadBytes) <$> remaining
-             isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
-         writeTVar (itrReqChunkIsOver  itr) isOver
-         writeTVar (itrReqBodyWanted   itr) Nothing
-         writeTVar (itrReceivedBody    itr) chunk
-         writeTVar (itrReceivedBodyLen itr) actualReadBytes
-         if isOver then
-             acceptRequest input'
-         else
-             observeNonChunkedRequest itr input'
+      gotEndOfRequest ∷ IO ()
+      gotEndOfRequest
+          = do atomically $ putTMVar itrReceivedBody (∅)
+               acceptRequest ctx input
 
 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
 enqueue (Context {..}) itr