]> gitweb @ CieloNegro.org - Lucu.git/blob - examples/SSL.hs
docs
[Lucu.git] / 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.fromList
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
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