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 91aa86dc61be20313b4b672b59806177441d3399..497db9320a0d2e87b6dc23d903bc24b213eb6246 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -16,11 +16,11 @@ import Control.Exception hiding (block)
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import qualified Data.Attoparsec.Lazy as LP
-import Data.Attoparsec.Parsable
 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
@@ -34,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.Response.StatusCode
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.Socket
@@ -95,7 +96,7 @@ acceptRequest ctx@(Context {..}) input
          if Lazy.null input then
              return ()
          else
-             case LP.parse parser input of
+             case LP.parse def input of
                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
@@ -110,19 +111,19 @@ acceptParsableRequest ∷ HandleLike h
                       → 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
-             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
-                  Just (path, def)
-                      → acceptRequestForResource ctx ar input path def
+                  Just (path, rsrc)
+                      → acceptRequestForResource ctx ar input path rsrc
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
@@ -141,7 +142,7 @@ acceptRequestForResource ∷ HandleLike h
                          → [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
@@ -149,9 +150,9 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr
 #else
          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 #endif
-         tid  ← spawnRsrc rsrcDef ni
+         tid  ← spawnRsrc rsrc ni
          enqueue ctx ni
-         if reqMustHaveBody arRequest then
+         if reqHasBody arRequest then
              waitForReceiveBodyReq ctx ni tid input
          else
              acceptRequest ctx input