Compare commits

...

1 Commits

Author SHA1 Message Date
Jonathan Lamothe a45a75c3e2 get the client certificate from the connection's context
...instead of the janky thing we were doing before
2023-01-04 10:26:56 -05:00

View File

@ -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