From: PHO <pho@cielonegro.org>
Date: Tue, 15 Nov 2011 15:42:41 +0000 (+0900)
Subject: lots of bugfixes regarding SSL support
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=b495d6b8b7647b719eceef2f3e50d5bf87c430cf

lots of bugfixes regarding SSL support
---

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 97a7603..e83aa34 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -113,6 +113,7 @@ instance Monoid Headers where
     mappend (Headers α) (Headers β)
         = Headers $ insertManySorted β α
 
+-- FIXME: override every methods
 instance Map Headers CIAscii Ascii where
     {-# INLINE lookup #-}
     lookup k (Headers m) = lookup k m
diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index fecb815..6aee0f7 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -9,6 +9,7 @@
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , SomeInteraction(..)
+    , EndOfInteraction(..)
 
     , SyntacticallyInvalidInteraction(..)
     , mkSyntacticallyInvalidInteraction
@@ -63,6 +64,13 @@ instance Interaction SomeInteraction where
     toInteraction   = id
     fromInteraction = Just
 
+-- |'EndOfInteraction' is an 'Interaction' indicating the end of
+-- (possibly pipelined) requests. The connection has already been
+-- closed so no need to reply anything.
+data EndOfInteraction = EndOfInteraction
+    deriving Typeable
+instance Interaction EndOfInteraction
+
 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
 -- a syntactically valid 'Request'. The response code will always be
 -- 'BadRequest'.
diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index ab70998..8830b5c 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -88,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 {..})
diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 24ee47e..1370f05 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -14,6 +14,7 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
+import GHC.IO.Exception (IOException(..), IOErrorType(..))
 import qualified Data.Ascii as A
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
@@ -25,51 +26,46 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
-import System.IO.Error
 
 data Context h
     = Context {
         cConfig ∷ !Config
       , cHandle ∷ !h
       , cQueue  ∷ !InteractionQueue
-      , cReader ∷ !ThreadId
       }
 
 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
 responseWriter cnf h tQueue readerTID
-    = awaitSomethingToWrite (Context cnf h tQueue readerTID)
+    = awaitSomethingToWrite (Context cnf h tQueue)
       `catches`
       [ Handler handleIOE
       , Handler handleAsyncE
       , Handler handleBIOS
       , Handler handleOthers
       ]
+      `finally`
+      do killThread readerTID
+         hClose h
     where
       handleIOE ∷ IOException → IO ()
-      handleIOE e
-          | isIllegalOperation e
-              = return () -- EPIPE: should be ignored at all.
-          | otherwise
-              = terminate e
+      handleIOE e@(IOError {..})
+          | ioe_type ≡ ResourceVanished = return ()
+          | otherwise                   = dump e
 
       handleAsyncE ∷ AsyncException → IO ()
-      handleAsyncE ThreadKilled = terminate'
-      handleAsyncE e            = terminate e
+      handleAsyncE ThreadKilled = return ()
+      handleAsyncE e            = dump e
 
       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
-      handleBIOS = terminate
+      handleBIOS = dump
 
       handleOthers ∷ SomeException → IO ()
-      handleOthers = terminate
+      handleOthers = dump
 
-      terminate ∷ Exception e ⇒ e → IO ()
-      terminate e
+      dump ∷ Exception e ⇒ e → IO ()
+      dump e
           = do hPutStrLn stderr "requestWriter caught an exception:"
                hPutStrLn stderr (show $ toException e)
-               terminate'
-
-      terminate' ∷ IO ()
-      terminate' = hClose h
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})
@@ -85,7 +81,8 @@ writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
 writeSomething ctx itr
     = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
                    writeResponseForSEI ctx <$> fromInteraction itr <|>
-                   writeResponseForSYI ctx <$> fromInteraction itr
+                   writeResponseForSYI ctx <$> fromInteraction itr <|>
+                   endOfResponses          <$> fromInteraction itr
       in
         case writer of
           Just f  → f
@@ -209,12 +206,7 @@ finalize ctx@(Context {..}) (NI {..})
          sentContinue ← takeTMVar niSendContinue
          return $
              if needToClose willClose sentContinue then
-                 -- The RequestReader is probably blocking on
-                 -- hWaitForInput so we have to kill it before closing
-                 -- the socket.  THINKME: Couldn't that somehow be
-                 -- avoided?
-                 do killThread cReader
-                    hClose cHandle
+                 return ()
              else
                  awaitSomethingToWrite ctx
     where
@@ -252,8 +244,7 @@ writeResponseForSEI ctx@(Context {..}) (SEI {..})
                  hPutBuilder cHandle seiBodyToSend
          hFlush cHandle
          if seiWillClose ∨ seiExpectedContinue then
-             do killThread cReader
-                hClose cHandle
+             return ()
          else
              awaitSomethingToWrite ctx
 
@@ -265,5 +256,7 @@ writeResponseForSYI (Context {..}) (SYI {..})
     = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
          hPutBuilder cHandle syiBodyToSend
          hFlush cHandle
-         killThread cReader
-         hClose cHandle
+         return ()
+
+endOfResponses ∷ EndOfInteraction → IO ()
+endOfResponses _ = return ()
diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs
index 998e449..580ee52 100644
--- a/Network/HTTP/Lucu/SocketLike.hs
+++ b/Network/HTTP/Lucu/SocketLike.hs
@@ -10,10 +10,14 @@ module Network.HTTP.Lucu.SocketLike
     ( SocketLike(..)
     )
     where
+#if defined(HAVE_SSL)
+import Control.Exception
+#endif
 import qualified Network.Socket as So
 import Network.HTTP.Lucu.HandleLike
 #if defined(HAVE_SSL)
 import qualified OpenSSL.Session as SSL
+import Prelude hiding (catch)
 import Prelude.Unicode
 #endif
 import qualified System.IO as I
@@ -40,8 +44,26 @@ instance SocketLike (SSL.SSLContext, So.Socket) where
     accept (ctx, soSelf)
         = do (soPeer, addr) ← So.accept soSelf
              ssl            ← SSL.connection ctx soPeer
-             SSL.accept ssl
-             return (ssl, addr)
+             handshake ssl addr `catch` next ssl addr
+        where
+          handshake ∷ SSL.SSL → So.SockAddr → IO (SSL.SSL, So.SockAddr)
+          handshake ssl addr
+              = do SSL.accept ssl
+                   return (ssl, addr)
+
+          next ∷ SSL.SSL
+               → So.SockAddr
+               → SSL.SomeSSLException
+               → IO (SSL.SSL, So.SockAddr)
+          next ssl addr e
+              = do I.hPutStrLn I.stderr
+                       $ "Lucu: failed to accept an SSL connection from "
+                       ⧺ show addr
+                       ⧺ ":"
+                   I.hPutStrLn I.stderr
+                       $ show e
+                   SSL.shutdown ssl SSL.Bidirectional
+                   accept (ctx, soSelf)
 
     socketPort = So.socketPort ∘ snd
 #endif