Code reorganisation

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b5feafe4f07ed624191e74c34c3d4f73129e8c82..edd3fa2fedf899243d22840769aa2ccbd653a828 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,38 +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 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.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.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


@@ -52,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 request 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 {..})


@@ -115,15 +115,15 @@ acceptParsableRequest ctx@(Context {..}) req input
          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
                       → do let ar' = ar {
                                        arInitialStatus = fromStatusCode NotFound
                                      }
                            acceptSemanticallyInvalidRequest ctx ar' input
                   Nothing
                       → do let ar' = ar {
                                        arInitialStatus = fromStatusCode NotFound
                                      }
                            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


@@ -140,14 +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
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+         tid  ← spawnRsrc rsrc ni

          enqueue ctx ni
          enqueue ctx ni

-         if reqMustHaveBody arRequest then
+         if reqHasBody arRequest then

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


@@ -296,11 +301,11 @@ chunkWasMalformed tid eCtx e msg
     = let abo = mkAbortion BadRequest [("Connection", "close")]
                 $ Just
                 $ "chunkWasMalformed: "
     = let abo = mkAbortion BadRequest [("Connection", "close")]
                 $ Just
                 $ "chunkWasMalformed: "

-                ⊕ T.pack msg
+                ⊕ cs msg

                 ⊕ ": "
                 ⊕ ": "

-                ⊕ T.pack (intercalate ", " eCtx)
+                ⊕ cs (intercalate ", " eCtx)

                 ⊕ ": "
                 ⊕ ": "

-                ⊕ T.pack e
+                ⊕ cs e

       in
         throwTo tid abo
 
       in
         throwTo tid abo
 


@@ -372,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)