X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=d1505e80b8386e0f5e42e4b695a1fcf2e91e9a31;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=00d3b03ea5251a3b1fe12ae5c2dccb5a7caa339b;hpb=c6b11025d1f81c668e9995e856b7bb34175230d3;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 00d3b03..d1505e8 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,5 @@
 module Network.HTTP.Lucu.RequestReader
-    ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+    ( requestReader
     )
     where
 
@@ -8,31 +8,28 @@ import           Control.Exception
 import           Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Data.Map as M
-import           Data.Map (Map)
 import           Data.Maybe
 import qualified Data.Sequence as S
-import           Data.Sequence (Seq, (<|), ViewR(..))
-import           Network
+import           Data.Sequence ((<|))
+import           Network.Socket
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
-import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Parser
 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
 import           Network.HTTP.Lucu.Resource.Tree
 import           Prelude hiding (catch)
 import           System.IO
 
 
-requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
-requestReader cnf tree h host tQueue
-    = do catch (do input <- B.hGetContents h
+requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
+requestReader cnf tree h addr tQueue
+    = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
+      do catch (do input <- B.hGetContents h
                    acceptRequest input) $ \ exc ->
              case exc of
                IOException _               -> return ()
@@ -58,13 +55,11 @@ requestReader cnf tree h host tQueue
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
-          = do itr <- newInteraction cnf host Nothing
-               let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = status
-                         , resHeaders = []
-                         }
-               atomically $ do writeItr itr itrResponse $ Just res
+          = do itr <- newInteraction cnf addr Nothing
+               atomically $ do updateItr itr itrResponse
+                                             $ \ res -> res {
+                                                          resStatus = status
+                                                        }
                                writeItr itr itrWillClose True
                                writeItr itr itrState     Done
                                writeDefaultPage itr
@@ -73,20 +68,20 @@ requestReader cnf tree h host tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
-          = do itr <- newInteraction cnf host (Just req)
+          = do itr <- newInteraction cnf addr (Just req)
                action
                    <- atomically $
                       do preprocess itr
-                         isErr <- readItrF itr itrResponse (isError . resStatus)
-                         if isErr == Just True then
+                         isErr <- readItr itr itrResponse (isError . resStatus)
+                         if isErr then
                              acceptSemanticallyInvalidRequest itr input
                            else
-                             case findResource tree $ (reqURI . fromJust . itrRequest) itr of
+                             case findResource tree $ reqURI req of
                                Nothing -- Resource が無かった
                                    -> acceptRequestForNonexistentResource itr input
 
-                               Just rsrcDef -- あった
-                                   -> acceptRequestForExistentResource itr input rsrcDef
+                               Just (rsrcPath, rsrcDef) -- あった
+                                   -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
                action
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
@@ -99,21 +94,20 @@ requestReader cnf tree h host tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
-          = do let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = NotFound
-                         , resHeaders = []
-                         }
-               writeItr itr itrResponse $ Just res
+          = do updateItr itr itrResponse 
+                             $ \res -> res {
+                                         resStatus = NotFound
+                                       }
                writeItr itr itrState Done
                writeDefaultPage itr
                postprocess itr
                enqueue itr
                return $ acceptRequest input
 
-      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
-      acceptRequestForExistentResource itr input rsrcDef
-          = do requestHasBody <- readItr itr itrRequestHasBody id
+      acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
+      acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+          = do let itr = oldItr { itrResourcePath = Just rsrcPath }
+               requestHasBody <- readItr itr itrRequestHasBody id
                enqueue itr
                return $ do runResource rsrcDef itr
                            if requestHasBody then
@@ -223,17 +217,14 @@ requestReader cnf tree h host tQueue
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr
-          = let res = Response {
-                        resVersion = HttpVersion 1 1
-                      , resStatus  = BadRequest
-                      , resHeaders = []
-                      }
-            in
-              atomically $ do writeItr itr itrResponse $ Just res
-                              writeItr itr itrWillClose True
-                              writeItr itr itrState Done
-                              writeDefaultPage itr
-                              postprocess itr
+          = atomically $ do updateItr itr itrResponse 
+                                          $ \ res -> res {
+                                                       resStatus = BadRequest
+                                                     }
+                            writeItr itr itrWillClose True
+                            writeItr itr itrState Done
+                            writeDefaultPage itr
+                            postprocess itr
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input