+import Control.Monad
+import Control.Monad.Trans
+import Data.Time.Clock
+import Network
+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 = PortNumber 9000
+ , cnfSSLConfig = Just SSLConfig {
+ sslServerPort = PortNumber 9001
+ , sslContext = ctx
+ }
+ }
+ resources = mkResTree [ ( []
+ , helloWorld )
+ ]
+ putStrLn "Access https://localhost:9001/ with your browser."
+ runHttpd config resources []
+
+
+helloWorld :: ResourceDef
+helloWorld
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = False
+ , resGet
+ = Just $ do setContentType $ read "text/plain"
+ outputChunk "getRemoteCertificate = "
+ cert <- do c <- getRemoteCertificate
+ case c of
+ Just c -> liftIO $ printX509 c
+ Nothing -> return "Nothing"
+ outputChunk cert
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+
+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 =<< liftM (addUTCTime (-1)) getCurrentTime
+ setNotAfter cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime
+ setPublicKey cert pkey
+ signX509 cert pkey Nothing
+ return cert
\ No newline at end of file