client-cert.hs

{-# 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
    }
  }