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