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