src/Network/Gemini/Capsule.hs

@@ -34,12 +34,12 @@ import Control.Concurrent (forkIO)
 import Control.Exception (SomeException, try)
 import Control.Exception.Base (bracket, finally)
 import Control.Monad (void)
-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import qualified Data.Connection as C
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.TLSSetting (makeServerParams)
-import Data.X509 (CertificateChain (..), getSigned, signedObject)
+import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
 import qualified Network.Socket as S
-import Network.TLS (ServerParams, getClientCertificateChain)
+import Network.TLS (ServerParams, onClientCertificate, serverHooks)
 import System.IO.Streams.TCP (bindAndListen)
 import System.IO.Streams.TLS (accept)
 
@@ -69,18 +69,32 @@ runGemCapsule settings handler = bracket
 
 listenLoop :: S.Socket -> ServerParams -> GemHandler -> IO a
 listenLoop sock params handler = do
-  try (accept params sock) >>= \case
+  certRef <- newIORef Nothing
+  let params' = adjustServerParams certRef params
+  try (accept params' sock) >>= \case
     Left (_::SomeException) -> return ()
     Right conn            -> void $ forkIO $ finally
-      ( do
+      (readIORef certRef >>= runConnection conn handler)
-        let (context, _) = C.connExtraInfo conn
-        mCert <- runMaybeT $
-          MaybeT (getClientCertificateChain context) >>= \case
-            CertificateChain []     -> fail "no certificate"
-            CertificateChain (se:_) -> return $ signedObject $ getSigned se
-        runConnection conn handler mCert
-      )
       (C.close conn)
   listenLoop sock params handler
 
+adjustServerParams
+  :: IORef (Maybe Certificate)
+  -> ServerParams
+  -> ServerParams
+adjustServerParams certRef params = let
+  hooks    = serverHooks params
+  certHook = onClientCertificate hooks
+
+  certHook' chain = do
+    case chain of
+      CertificateChain []     -> return ()
+      CertificateChain (se:_) -> do
+        let cert = signedObject $ getSigned se
+        writeIORef certRef (Just cert)
+    certHook chain
+
+  hooks' = hooks { onClientCertificate = certHook' }
+  in params { serverHooks = hooks' }
+
 --jl