diff --git a/src/Network/Gemini/Capsule.hs b/src/Network/Gemini/Capsule.hs index c01f329..ec7baac 100644 --- a/src/Network/Gemini/Capsule.hs +++ b/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 (Certificate, CertificateChain (..), getSigned, signedObject) +import Data.X509 (CertificateChain (..), getSigned, signedObject) import qualified Network.Socket as S -import Network.TLS (ServerParams, onClientCertificate, serverHooks) +import Network.TLS (ServerParams, getClientCertificateChain) import System.IO.Streams.TCP (bindAndListen) import System.IO.Streams.TLS (accept) @@ -69,32 +69,18 @@ runGemCapsule settings handler = bracket listenLoop :: S.Socket -> ServerParams -> GemHandler -> IO a listenLoop sock params handler = do - certRef <- newIORef Nothing - let params' = adjustServerParams certRef params - try (accept params' sock) >>= \case + try (accept params sock) >>= \case Left (_::SomeException) -> return () Right conn -> void $ forkIO $ finally - (readIORef certRef >>= runConnection conn handler) + ( do + 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