examples/SSL.hs

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