Destroy Data.Attoparsec.Parsable; use Data.Default instead

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 4c59b3e9f8b1ac5a1524d634d2595a339c80c853..543c82e52e182524460a13d95efb09295fdd4578 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -14,24 +14,27 @@ 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 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


@@ -39,13 +42,12 @@ import System.IO (hPutStrLn, stderr)
 
 data Context h
     = Context {
 
 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


@@ -53,18 +55,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

-              → 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
       , Handler handleOthers
       `catches`
       [ Handler handleAsyncE
       , Handler handleOthers


@@ -94,7 +95,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
 


@@ -113,15 +114,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,7 +141,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


@@ -148,9 +149,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


@@ -299,11 +300,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