examples/SSL.hs

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