It (at least) builds now...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 37ab99296c2e0b7dff2eb7321e37ef6633e70a54..55c2166aba9d438cf689ee6e949c851c733d547a 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -14,6 +14,7 @@ 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


@@ -25,13 +26,13 @@ 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.Resource.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.Resource.Internal

-import Network.HTTP.Lucu.Resource.Tree

 import Network.HTTP.Lucu.Utils
 import Network.Socket
 import Prelude.Unicode
 import Network.HTTP.Lucu.Utils
 import Network.Socket
 import Prelude.Unicode


@@ -40,8 +41,7 @@ import System.IO (hPutStrLn, stderr)
 data Context h
     = Context {
         cConfig    ∷ !Config
 data Context h
     = Context {
         cConfig    ∷ !Config

-      , cResTree   ∷ !ResTree
-      , cFallbacks ∷ ![FallbackHandler]
+      , cSchemeMap ∷ !SchemeMap

       , cHandle    ∷ !h
       , cPort      ∷ !PortNumber
       , cAddr      ∷ !SockAddr
       , cHandle    ∷ !h
       , cPort      ∷ !PortNumber
       , cAddr      ∷ !SockAddr


@@ -55,19 +55,17 @@ data ChunkReceivingState
 
 requestReader ∷ HandleLike h
               ⇒ Config
 
 requestReader ∷ HandleLike h
               ⇒ Config

-              → ResTree
-              → [FallbackHandler]
+              → SchemeMap

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

-requestReader cnf tree fbs h port addr tQueue
+requestReader cnf sm 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 sm h port addr tQueue) input

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

-      , Handler handleBIOS

       , Handler handleOthers
       ]
       `finally`
       , Handler handleOthers
       ]
       `finally`


@@ -77,15 +75,12 @@ requestReader cnf tree fbs h port addr tQueue
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 
       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:"
+          = do hPutStrLn stderr "Lucu: requestReader caught an exception:"

                hPutStrLn stderr $ show e
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
                hPutStrLn stderr $ show e
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()


@@ -117,7 +112,7 @@ 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
+             do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cSchemeMap

                 case rsrc of
                   Nothing
                       → do let ar' = ar {
                 case rsrc of
                   Nothing
                       → do let ar' = ar {


@@ -142,7 +137,7 @@ acceptRequestForResource ∷ HandleLike h
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]

-                         → ResourceDef
+                         → Resource

                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
     = do
                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
     = do


@@ -152,7 +147,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr
 #else
          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 #endif
 #else
          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 #endif

-         tid  ← spawnResource rsrcDef ni
+         tid  ← spawnRsrc rsrcDef ni

          enqueue ctx ni
          if reqMustHaveBody arRequest then
              waitForReceiveBodyReq ctx ni tid input
          enqueue ctx ni
          if reqMustHaveBody arRequest then
              waitForReceiveBodyReq ctx ni tid input