{-# LANGUAGE OverloadedStrings , PackageImports , QuasiQuotes , UnicodeSyntax #-} import Control.Applicative import "mtl" Control.Monad.Trans import Control.Monad.Unicode import qualified Data.ByteString.Lazy.Char8 as Lazy import Data.Time.Clock import Network.HTTP.Lucu import OpenSSL import OpenSSL.EVP.PKey import OpenSSL.RSA import qualified OpenSSL.Session as SSL import OpenSSL.X509 main ∷ IO () main = withOpenSSL $ do ctx ← SSL.context key ← generateRSAKey 1024 3 Nothing cert ← genCert key SSL.contextSetPrivateKey ctx key SSL.contextSetCertificate ctx cert SSL.contextSetDefaultCiphers ctx let config = defaultConfig { cnfServerPort = "9000" , cnfSSLConfig = Just SSLConfig { sslServerPort = "9001" , sslContext = ctx } } resources = mkResTree [ ([], helloWorld) ] putStrLn "Access https://localhost:9001/ with your browser." runHttpd config resources [] helloWorld ∷ ResourceDef helloWorld = emptyResource { resGet = Just $ do setContentType [mimeType| text/plain |] putChunk "getRemoteCertificate = " cert ← do cert ← getRemoteCertificate case cert of Just c → liftIO $ Lazy.pack <$> printX509 c Nothing → return "Nothing" putChunks cert } genCert ∷ KeyPair k ⇒ k → IO X509 genCert pkey = do cert ← newX509 setVersion cert 2 setSerialNumber cert 1 setIssuerName cert [("CN", "localhost")] setSubjectName cert [("CN", "localhost")] setNotBefore cert =≪ addUTCTime (-1) <$> getCurrentTime setNotAfter cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime setPublicKey cert pkey signX509 cert pkey Nothing return cert