examples/SSL.hs

   1 {-# LANGUAGE PackageImports #-}
   2 import           Control.Monad
   3 import "mtl"     Control.Monad.Trans
   4 import           Data.Time.Clock
   5 import           Network
   6 import           Network.HTTP.Lucu
   7 import           OpenSSL
   8 import           OpenSSL.EVP.PKey
   9 import           OpenSSL.RSA
  10 import qualified OpenSSL.Session as SSL
  11 import           OpenSSL.X509
  12
  13 main :: IO ()
  14 main = withOpenSSL $
  15        do ctx  <- SSL.context
  16
  17           key  <- generateRSAKey 1024 3 Nothing
  18           cert <- genCert key
  19           SSL.contextSetPrivateKey     ctx key
  20           SSL.contextSetCertificate    ctx cert
  21           SSL.contextSetDefaultCiphers ctx
  22
  23           let config    = defaultConfig {
  24                             cnfServerPort = PortNumber 9000
  25                           , cnfSSLConfig  = Just SSLConfig {
  26                                               sslServerPort = PortNumber 9001
  27                                             , sslContext    = ctx
  28                                             }
  29                           }
  30               resources = mkResTree [ ( []
  31                                       , helloWorld )
  32                                     ]
  33           putStrLn "Access https://localhost:9001/ with your browser."
  34           runHttpd config resources []
  35
  36
  37 helloWorld :: ResourceDef
  38 helloWorld
  39     = ResourceDef {
  40         resUsesNativeThread = False
  41       , resIsGreedy         = False
  42       , resGet
  43           = Just $ do setContentType $ read "text/plain"
  44                       outputChunk "getRemoteCertificate = "
  45                       cert <- do c <- getRemoteCertificate
  46                                  case c of
  47                                    Just c  -> liftIO $ printX509 c
  48                                    Nothing -> return "Nothing"
  49                       outputChunk cert
  50       , resHead   = Nothing
  51       , resPost   = Nothing
  52       , resPut    = Nothing
  53       , resDelete = Nothing
  54       }
  55
  56
  57 genCert :: KeyPair k => k -> IO X509
  58 genCert pkey
  59     = do cert <- newX509
  60          setVersion      cert 2
  61          setSerialNumber cert 1
  62          setIssuerName   cert [("CN", "localhost")]
  63          setSubjectName  cert [("CN", "localhost")]
  64          setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
  65          setNotAfter     cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime
  66          setPublicKey    cert pkey
  67          signX509        cert pkey Nothing
  68          return cert