examples/SSL.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , PackageImports
   4   , QuasiQuotes
   5   , UnicodeSyntax
   6   #-}
   7 import Control.Applicative
   8 import Control.Monad.IO.Class
   9 import Control.Monad.Unicode
  10 import qualified Data.ByteString.Lazy.Char8 as Lazy
  11 import qualified Data.Collections as C
  12 import Data.Time.Clock
  13 import Network
  14 import Network.HTTP.Lucu
  15 import OpenSSL
  16 import OpenSSL.EVP.PKey
  17 import OpenSSL.RSA
  18 import qualified OpenSSL.Session as SSL
  19 import OpenSSL.X509
  20 import Prelude.Unicode
  21
  22 main ∷ IO ()
  23 main = withOpenSSL $
  24        do ctx  ← SSL.context
  25
  26           key  ← generateRSAKey 1024 3 Nothing
  27           cert ← genCert key
  28           SSL.contextSetPrivateKey     ctx key
  29           SSL.contextSetCertificate    ctx cert
  30           SSL.contextSetDefaultCiphers ctx
  31
  32           let config = defaultConfig {
  33                          cnfServerPort = "9000"
  34                        , cnfSSLConfig  = Just SSLConfig {
  35                                            sslServerPort = "9001"
  36                                          , sslContext    = ctx
  37                                          }
  38                        }
  39               tree   ∷ ResourceTree
  40               tree   = C.fromList [ ([], nonGreedy helloWorld) ]
  41           putStrLn "Access https://localhost:9001/ with your browser."
  42           withSocketsDo ∘ runHttpd config $ resourceMap tree
  43
  44 helloWorld ∷ Resource
  45 helloWorld
  46     = C.singleton
  47       ( GET
  48       , do setContentType [mimeType| text/plain |]
  49            putChunk "getRemoteCertificate = "
  50            cert ← do cert ← getRemoteCertificate
  51                      case cert of
  52                        Just c  → liftIO $ Lazy.pack <$> printX509 c
  53                        Nothing → return "Nothing"
  54            putChunks cert
  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 =≪ addUTCTime (-1)                 <$> getCurrentTime
  65          setNotAfter     cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime
  66          setPublicKey    cert pkey
  67          signX509        cert pkey Nothing
  68          return cert