Still working on Router arrow

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b0af8d1f38d773571c8374ce4c5cff2101992b75..497db9320a0d2e87b6dc23d903bc24b213eb6246 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


@@ -13,37 +14,41 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception hiding (block)
 import Control.Monad
 import Control.Concurrent.STM
 import Control.Exception hiding (block)
 import Control.Monad

+import Control.Monad.Trans.Maybe

 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.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Default
+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 Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk

+import Network.HTTP.Lucu.Dispatcher.Internal

 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response

+import Network.HTTP.Lucu.Response.StatusCode

 import Network.HTTP.Lucu.Resource.Internal
 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)
 
 data Context h
     = Context {
 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 
 data Context h
     = Context {

-        cConfig    ∷ !Config
-      , cResTree   ∷ !ResTree
-      , cFallbacks ∷ ![FallbackHandler]
-      , cHandle    ∷ !h
-      , cPort      ∷ !PortNumber
-      , cAddr      ∷ !SockAddr
-      , cQueue     ∷ !InteractionQueue
+        cConfig  ∷ !Config
+      , cHostMap ∷ !HostMap
+      , cHandle  ∷ !h
+      , cPort    ∷ !PortNumber
+      , cAddr    ∷ !SockAddr
+      , cQueue   ∷ !InteractionQueue

       }
 
 data ChunkReceivingState
       }
 
 data ChunkReceivingState


@@ -51,53 +56,49 @@ data ChunkReceivingState
     | InChunk !Int -- ^Number of remaining octets in the current
                    -- chunk. It's always positive.
 
     | InChunk !Int -- ^Number of remaining octets in the current
                    -- chunk. It's always positive.
 

-requestReader ∷ HandleLike h
+requestReader ∷ (HostMapper hm, HandleLike h)

               ⇒ Config
               ⇒ Config

-              → ResTree
-              → [FallbackHandler]
+              → hm

               → h
               → PortNumber
               → SockAddr
               → InteractionQueue
               → IO ()
               → h
               → PortNumber
               → SockAddr
               → InteractionQueue
               → IO ()

-requestReader cnf tree fbs h port addr tQueue
+requestReader cnf hm h port addr tQueue

     = do input ← hGetLBS h
     = do input ← hGetLBS h

-         acceptRequest (Context cnf tree fbs h port addr tQueue) input
+         acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input

       `catches`
       [ Handler handleAsyncE
       `catches`
       [ Handler handleAsyncE

-      , Handler handleBIOS

       , Handler handleOthers
       ]
       , Handler handleOthers
       ]

+      `finally`
+      enqueue' tQueue EndOfInteraction

     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 
     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
       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
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input

-    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
-    -- それが限度以下になるまで待つ。

     = do atomically $
              do queue ← readTVar cQueue
     = 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
                     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 def input of
+               LP.Done input' req → acceptParsableRequest ctx req input'
+               LP.Fail _ _ _      → acceptNonparsableRequest ctx

 
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 acceptNonparsableRequest ctx@(Context {..})
 
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 acceptNonparsableRequest ctx@(Context {..})


@@ -110,17 +111,19 @@ acceptParsableRequest ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input

-    = do let ar = preprocess (cnfServerHost cConfig) cPort req
+    = do let ar = preprocess (cnfServerHost cConfig) cPort (hIsSSL cHandle) req

          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else
          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else

-             do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
-                case rsrc of
+             do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
+                case rsrcM of

                   Nothing
                   Nothing

-                      → do let ar' = ar { arInitialStatus = NotFound }
+                      → do let ar' = ar {
+                                       arInitialStatus = fromStatusCode NotFound
+                                     }

                            acceptSemanticallyInvalidRequest ctx ar' input
                            acceptSemanticallyInvalidRequest ctx ar' input

-                  Just (path, def)
-                      → acceptRequestForResource ctx ar input path def
+                  Just (path, rsrc)
+                      → acceptRequestForResource ctx ar input path rsrc

 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h


@@ -137,13 +140,19 @@ acceptRequestForResource ∷ HandleLike h
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]

-                         → ResourceDef
+                         → Resource

                          → IO ()
                          → IO ()

-acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
-    = do cert ← hGetPeerCert cHandle
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
+    = do
+#if defined(HAVE_SSL)
+         cert ← hGetPeerCert cHandle

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

-         tid  ← spawnResource rsrcDef ni
-         if reqMustHaveBody arRequest then
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+         tid  ← spawnRsrc rsrc ni
+         enqueue ctx ni
+         if reqHasBody arRequest then

              waitForReceiveBodyReq ctx ni tid input
          else
              acceptRequest ctx input
              waitForReceiveBodyReq ctx ni tid input
          else
              acceptRequest ctx input


@@ -155,7 +164,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 +214,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 +228,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 +256,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 +277,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: "
+                ⊕ cs msg
+                ⊕ ": "
+                ⊕ cs (intercalate ", " eCtx)
+                ⊕ ": "
+                ⊕ cs e

       in
         throwTo tid abo
 
       in
         throwTo tid abo
 


@@ -363,8 +377,10 @@ readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
                acceptRequest ctx input
 
 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
                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 $
     = atomically $

-      do queue ← readTVar cQueue
-         writeTVar cQueue (toInteraction itr ⊲ queue)
+      do queue ← readTVar tQueue
+         writeTVar tQueue (toInteraction itr ⊲ queue)