lots of bugfixes regarding SSL support

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index b5feafe4f07ed624191e74c34c3d4f73129e8c82..8830b5c010f8adf9d562207dfb1b43a33543a7d9 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables
@@ -20,7 +21,6 @@ import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
@@ -32,6 +32,7 @@ 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 System.IO (hPutStrLn, stderr)
@@ -87,18 +88,21 @@ requestReader cnf tree fbs h port addr tQueue
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
-    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
-    -- それが限度以下になるまで待つ。
     = do atomically $
              do queue ← readTVar cQueue
-                when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+                when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
+                    -- Too many requests in the pipeline...
                     retry
-         -- リクエストを讀む。パースできない場合は直ちに 400 Bad
-         -- Request 應答を設定し、それを出力してから切斷するやうに
-         -- ResponseWriter に通知する。
-         case LP.parse request input of
-           LP.Done input' req → acceptParsableRequest ctx req input'
-           LP.Fail _ _ _      → acceptNonparsableRequest ctx
+         if Lazy.null input then
+             endOfRequests ctx
+         else
+             case LP.parse request input of
+               LP.Done input' req → acceptParsableRequest ctx req input'
+               LP.Fail _ _ _      → acceptNonparsableRequest ctx
+
+endOfRequests ∷ HandleLike h ⇒ Context h → IO ()
+endOfRequests ctx
+    = enqueue ctx EndOfInteraction
 
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 acceptNonparsableRequest ctx@(Context {..})
@@ -143,8 +147,13 @@ acceptRequestForResource ∷ HandleLike h
                          → ResourceDef
                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
-    = do cert ← hGetPeerCert cHandle
+    = do
+#if defined(HAVE_SSL)
+         cert ← hGetPeerCert cHandle
          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
          tid  ← spawnResource rsrcDef ni
          enqueue ctx ni
          if reqMustHaveBody arRequest then