Code reorganisation

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index d793703c6c64ff240c8f3aaec1b36bd47be5205e..edd3fa2fedf899243d22840769aa2ccbd653a828 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -18,11 +18,13 @@ 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 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


@@ -32,6 +34,7 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 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.Utils
 import Network.Socket
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.Socket


@@ -53,17 +56,17 @@ 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

-              → HostMap
+              → hm

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

-requestReader cnf sm h port addr tQueue
+requestReader cnf hm h port addr tQueue

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

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

       `catches`
       [ Handler handleAsyncE
       , Handler handleOthers
       `catches`
       [ Handler handleAsyncE
       , Handler handleOthers


@@ -93,7 +96,7 @@ acceptRequest ctx@(Context {..}) input
          if Lazy.null input then
              return ()
          else
          if Lazy.null input then
              return ()
          else

-             case LP.parse request input of
+             case LP.parse def input of

                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 


@@ -112,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 ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
-                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


@@ -139,7 +142,7 @@ acceptRequestForResource ∷ HandleLike h
                          → [Strict.ByteString]
                          → Resource
                          → IO ()
                          → [Strict.ByteString]
                          → Resource
                          → IO ()

-acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc

     = do
 #if defined(HAVE_SSL)
          cert ← hGetPeerCert cHandle
     = do
 #if defined(HAVE_SSL)
          cert ← hGetPeerCert cHandle


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

-         tid  ← spawnRsrc rsrcDef ni
+         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


@@ -298,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