Merge branch 'convertible'

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 55c2166aba9d438cf689ee6e949c851c733d547a..6c5070b5738c0e54d4bce48f809219f6db97eb93 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -18,11 +18,12 @@ 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.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


@@ -40,12 +41,12 @@ import System.IO (hPutStrLn, stderr)
 
 data Context h
     = Context {
 
 data Context h
     = Context {

-        cConfig    ∷ !Config
-      , cSchemeMap ∷ !SchemeMap
-      , 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,17 +54,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

-              → SchemeMap
+              → 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


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

                 case rsrc of
                   Nothing
                       → do let ar' = ar {
                 case rsrc of
                   Nothing
                       → do let ar' = ar {


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