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
  21 main ∷ IO ()
  22 main = withOpenSSL $
  23        do ctx  ← SSL.context
  24
  25           key  ← generateRSAKey 1024 3 Nothing
  26           cert ← genCert key
  27           SSL.contextSetPrivateKey     ctx key
  28           SSL.contextSetCertificate    ctx cert
  29           SSL.contextSetDefaultCiphers ctx
  30
  31           let config = defaultConfig {
  32                          cnfServerPort = "9000"
  33                        , cnfSSLConfig  = Just SSLConfig {
  34                                            sslServerPort = "9001"
  35                                          , sslContext    = ctx
  36                                          }
  37                        }
  38               tree   ∷ ResourceTree
  39               tree   = C.fromList [ ([], nonGreedy helloWorld) ]
  40           putStrLn "Access https://localhost:9001/ with your browser."
  41           withSocketsDo $ runHttpd config $ resourceMap tree
  42
  43 helloWorld ∷ Resource
  44 helloWorld
  45     = C.singleton
  46       ( GET
  47       , do setContentType [mimeType| text/plain |]
  48            putChunk "getRemoteCertificate = "
  49            cert ← do cert ← getRemoteCertificate
  50                      case cert of
  51                        Just c  → liftIO $ Lazy.pack <$> printX509 c
  52                        Nothing → return "Nothing"
  53            putChunks cert
  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 =≪ addUTCTime (-1)                 <$> getCurrentTime
  64          setNotAfter     cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime
  65          setPublicKey    cert pkey
  66          signX509        cert pkey Nothing
  67          return cert