Lucu-0.3: examples/SSL.hs

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