]> 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.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