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 2cdc45dc472a42e284472badd85df1f31582c9f5..543c82e52e182524460a13d95efb09295fdd4578 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


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


@@ -112,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 ← 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 +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


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


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