SSL Support

[Lucu.git] / examples / SSL.hs

diff --git a/examples/SSL.hs b/examples/SSL.hs
new file mode 100644 (file)
index 0000000..3efdcae
--- /dev/null
+++ b/examples/SSL.hs
@@ -0,0 +1,67 @@
+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