Resource paths should not be assumed to be encoded in UTF-8. HTTP/1.1 says nothing...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index fbc8551bac76a4f2a273ad323525a24613eb2031..ecaaadb1d28a7f9ad479443c7b27e5dcc22493d1 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -20,13 +20,13 @@ import Data.Sequence.Unicode
 import Data.Text (Text)
 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.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.Socket
 import Network.URI
@@ -57,13 +57,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
@@ -85,7 +97,6 @@ acceptNonparsableRequest ctx@(Context {..}) sc
     = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
          atomically $
              do writeTVar (itrState itr) Done
-                writeDefaultPage itr
                 postprocess itr
                 enqueue ctx itr
 
@@ -111,7 +122,6 @@ acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  → STM (IO ())
 acceptSemanticallyInvalidRequest ctx itr input
     = do writeTVar (itrState itr) Done
-         writeDefaultPage itr
          postprocess itr
          enqueue ctx itr
          return $ acceptRequest ctx input
@@ -139,7 +149,6 @@ acceptRequestForNonexistentResource ctx itr input
     = do atomically $
              do setResponseStatus itr NotFound
                 writeTVar (itrState itr) Done
-                writeDefaultPage itr
                 postprocess itr
                 enqueue ctx itr
          acceptRequest ctx input
@@ -154,8 +163,8 @@ acceptRequestForExistentResource ∷ HandleLike h
 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
          atomically $ enqueue ctx itr
-         do _ ← runResource rsrcDef itr
-            if reqHasBody $ fromJust $ itrRequest itr then
+         do _ ← spawnResource rsrcDef itr
+            if reqMustHaveBody $ fromJust $ itrRequest itr then
                 observeRequest ctx itr input
             else
                 acceptRequest ctx input
@@ -185,16 +194,14 @@ observeChunkedRequest ctx itr input remaining
          if isOver then
              return $ acceptRequest ctx input
          else
-             do wantedM ← readTVar $ itrReqBodyWanted itr
-                case wantedM of
-                  Nothing
-                      → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
-                           if wasteAll then
-                               return $ wasteCurrentChunk ctx itr input remaining
-                           else
-                               retry
-                  Just wanted
-                      → return $ readCurrentChunk ctx itr input wanted remaining
+             do wanted ← readTVar $ itrReqBodyWanted itr
+                case wanted of
+                  0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+                         if wasteAll then
+                             return $ wasteCurrentChunk ctx itr input remaining
+                         else
+                             retry
+                  _ → return $ readCurrentChunk ctx itr input wanted remaining
 
 wasteCurrentChunk ∷ HandleLike h
                   ⇒ Context h
@@ -226,9 +233,7 @@ readCurrentChunk ctx itr input wanted remaining
         = 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
+                 newWanted       = wanted - actualReadBytes
                  newRemaining    = remaining - actualReadBytes
                  chunk'          = S.fromList $ Lazy.toChunks chunk
                  updateStates    = atomically $
@@ -277,7 +282,6 @@ chunkWasMalformed itr
       do setResponseStatus itr BadRequest
          writeTVar (itrWillClose itr) True
          writeTVar (itrState     itr) Done
-         writeDefaultPage itr
          postprocess itr
 
 observeNonChunkedRequest ∷ HandleLike h
@@ -289,16 +293,14 @@ observeNonChunkedRequest ∷ HandleLike h
 observeNonChunkedRequest ctx itr input remaining
     = join $
       atomically $
-      do wantedM ← readTVar $ itrReqBodyWanted itr
-         case wantedM of
-           Nothing
-               → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
-                    if wasteAll then
-                        return $ wasteNonChunkedRequestBody ctx itr input remaining
-                    else
-                        retry
-           Just wanted
-               → return $ readNonChunkedRequestBody ctx itr input wanted remaining
+      do wanted ← readTVar $ itrReqBodyWanted itr
+         case wanted of
+           0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+                  if wasteAll then
+                      return $ wasteNonChunkedRequestBody ctx itr input remaining
+                  else
+                      retry
+           _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
 
 wasteNonChunkedRequestBody ∷ HandleLike h
                            ⇒ Context h
@@ -322,12 +324,13 @@ readNonChunkedRequestBody ctx itr input wanted remaining
     = do let bytesToRead     = min wanted remaining
              (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
              actualReadBytes = fromIntegral $ Lazy.length chunk
+             newWanted       = wanted - actualReadBytes
              newRemaining    = remaining - actualReadBytes
              isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
              chunk'          = S.fromList $ Lazy.toChunks chunk
          atomically $
              do writeTVar (itrReqChunkIsOver  itr) isOver
-                writeTVar (itrReqBodyWanted   itr) Nothing
+                writeTVar (itrReqBodyWanted   itr) newWanted
                 writeTVar (itrReceivedBody    itr) chunk'
                 writeTVar (itrReceivedBodyLen itr) actualReadBytes
          if isOver then