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