Skip to content

Instantly share code, notes, and snippets.

@kazu-yamamoto
Created November 27, 2019 06:34
Show Gist options
  • Save kazu-yamamoto/a7712642ad6c05cbab8017536375c71f to your computer and use it in GitHub Desktop.
Save kazu-yamamoto/a7712642ad6c05cbab8017536375c71f to your computer and use it in GitHub Desktop.
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.IORef
import Data.Default
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import qualified Network.TLS
import Data.X509 as X509
type TLSAppInfo = IORef (Maybe X509.CertificateChain)
main :: IO ()
main = do
ioref <- newIORef Nothing :: IO TLSAppInfo
WarpTLS.runTLS (tlsSettings' ioref) Warp.defaultSettings $ handler ioref
handler :: TLSAppInfo -> Wai.Application
handler ioref _req resp = do
maybeChain <- readIORef ioref
case maybeChain of
Just (X509.CertificateChain (cert : _)) -> do
putStrLn "Got cert:"
print cert
_ -> do
putStrLn "This shouldn't happen because client cert is required"
resp $ Wai.responseLBS Http.status200 [] "Hello World"
tlsSettings' :: TLSAppInfo -> WarpTLS.TLSSettings
tlsSettings' ioref = (WarpTLS.tlsSettings "cert_server_cert.pem" "cert_server_key.pem")
{ WarpTLS.tlsWantClientCert = True
, WarpTLS.tlsServerHooks = def
{ Network.TLS.onClientCertificate = \chain -> do
atomicWriteIORef ioref $ Just chain
return Network.TLS.CertificateUsageAccept
}
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment