examples/SSL.hs

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