]> gitweb @ CieloNegro.org - Lucu.git/blob - examples/SSL.hs
Data.URI has been moved to https://github.com/phonohawk/extensible-uri
[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.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