X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FSocketLike.hs;h=580ee529fdd139d2726a5a5d79435e713b252a3f;hb=db4a546d0d462cb94639b1f273bf0b78bccc960c;hp=f64e24bcad680f86d4ec3067f4f9d583558fcd68;hpb=f504167b85561373b4c444e2d37a513e0ab504a9;p=Lucu.git

diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs
index f64e24b..580ee52 100644
--- a/Network/HTTP/Lucu/SocketLike.hs
+++ b/Network/HTTP/Lucu/SocketLike.hs
@@ -1,31 +1,69 @@
+{-# LANGUAGE
+    CPP
+  , FlexibleContexts
+  , FlexibleInstances
+  , TypeFamilies
+  , UnicodeSyntax
+  #-}
+-- |Type class for things behaves like a 'So.Socket'.
 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
+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
 
-
-class (HandleLike (Handle s)) => SocketLike s where
-    type Handle s :: *
-    accept :: s -> IO (Handle s, So.SockAddr)
-
+class (HandleLike (Handle s)) ⇒ SocketLike s where
+    type Handle s ∷ ★
+    accept        ∷ s → IO (Handle s, So.SockAddr)
+    socketPort    ∷ s → IO So.PortNumber
 
 instance SocketLike So.Socket where
     type Handle So.Socket = I.Handle
+
     accept soSelf
-        = do (soPeer, addr) <- So.accept soSelf
-             hPeer          <- So.socketToHandle soPeer I.ReadWriteMode
+        = do (soPeer, addr) ← So.accept soSelf
+             hPeer          ← So.socketToHandle soPeer I.ReadWriteMode
              return (hPeer, addr)
 
+    socketPort = So.socketPort
 
+#if defined(HAVE_SSL)
 instance SocketLike (SSL.SSLContext, So.Socket) where
     type Handle (SSL.SSLContext, So.Socket) = SSL.SSL
+
     accept (ctx, soSelf)
-        = do (soPeer, addr) <- So.accept soSelf
-             ssl            <- SSL.connection ctx soPeer
-             SSL.accept ssl
-             return (ssl, addr)
+        = do (soPeer, addr) ← So.accept soSelf
+             ssl            ← SSL.connection ctx soPeer
+             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