X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=examples%2FSSL.hs;h=f78b6c229939c49825fb6ab612ddf783066b3abf;hp=129316eba787f1e26ed7fbe88667bb6d96e7abd5;hb=950640dd241222203778f8167943d30fa52f356a;hpb=195fd2318fb0ad21c2fd60f61e7df72a8f25d12c

diff --git a/examples/SSL.hs b/examples/SSL.hs
index 129316e..f78b6c2 100644
--- a/examples/SSL.hs
+++ b/examples/SSL.hs
@@ -1,68 +1,68 @@
-{-# LANGUAGE PackageImports #-}
-import           Control.Monad
-import "mtl"     Control.Monad.Trans
-import           Data.Time.Clock
-import           Network
-import           Network.HTTP.Lucu
-import           OpenSSL
-import           OpenSSL.EVP.PKey
-import           OpenSSL.RSA
+{-# LANGUAGE
+    OverloadedStrings
+  , PackageImports
+  , QuasiQuotes
+  , UnicodeSyntax
+  #-}
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.Unicode
+import qualified Data.ByteString.Lazy.Char8 as Lazy
+import qualified Data.Collections as C
+import Data.Time.Clock
+import Network
+import Network.HTTP.Lucu
+import OpenSSL
+import OpenSSL.EVP.PKey
+import OpenSSL.RSA
 import qualified OpenSSL.Session as SSL
-import           OpenSSL.X509
+import OpenSSL.X509
+import Prelude.Unicode
 
-main :: IO ()
+main ∷ IO ()
 main = withOpenSSL $
-       do ctx  <- SSL.context
+       do ctx  ← SSL.context
 
-          key  <- generateRSAKey 1024 3 Nothing
-          cert <- genCert key
+          key  ← generateRSAKey 1024 3 Nothing
+          cert ← genCert key
           SSL.contextSetPrivateKey     ctx key
           SSL.contextSetCertificate    ctx cert
           SSL.contextSetDefaultCiphers ctx
 
-          let config    = defaultConfig {
-                            cnfServerPort = PortNumber 9000
-                          , cnfSSLConfig  = Just SSLConfig {
-                                              sslServerPort = PortNumber 9001
-                                            , sslContext    = ctx
-                                            }
-                          }
-              resources = mkResTree [ ( []
-                                      , helloWorld )
-                                    ]
+          let config = defaultConfig {
+                         cnfServerPort = "9000"
+                       , cnfSSLConfig  = Just SSLConfig {
+                                           sslServerPort = "9001"
+                                         , sslContext    = ctx
+                                         }
+                       }
+              tree   ∷ ResourceTree
+              tree   = C.fromList [ ([], nonGreedy helloWorld) ]
           putStrLn "Access https://localhost:9001/ with your browser."
-          runHttpd config resources []
+          withSocketsDo ∘ runHttpd config $ resourceMap tree
 
-
-helloWorld :: ResourceDef
+helloWorld ∷ Resource
 helloWorld 
-    = ResourceDef {
-        resUsesNativeThread = False
-      , resIsGreedy         = False
-      , resGet
-          = Just $ do setContentType $ read "text/plain"
-                      outputChunk "getRemoteCertificate = "
-                      cert <- do c <- getRemoteCertificate
-                                 case c of
-                                   Just c  -> liftIO $ printX509 c
-                                   Nothing -> return "Nothing"
-                      outputChunk cert
-      , resHead   = Nothing
-      , resPost   = Nothing
-      , resPut    = Nothing
-      , resDelete = Nothing
-      }
-
+    = C.singleton
+      ( GET
+      , do setContentType [mimeType| text/plain |]
+           putChunk "getRemoteCertificate = "
+           cert ← do cert ← getRemoteCertificate
+                     case cert of
+                       Just c  → liftIO $ Lazy.pack <$> printX509 c
+                       Nothing → return "Nothing"
+           putChunks cert
+      )
 
-genCert :: KeyPair k => k -> IO X509
+genCert ∷ KeyPair k ⇒ k → IO X509
 genCert pkey
-    = do cert <- newX509
+    = do cert ← newX509
          setVersion      cert 2
          setSerialNumber cert 1
          setIssuerName   cert [("CN", "localhost")]
          setSubjectName  cert [("CN", "localhost")]
-         setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
-         setNotAfter     cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime
+         setNotBefore    cert =≪ addUTCTime (-1)                 <$> getCurrentTime
+         setNotAfter     cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime
          setPublicKey    cert pkey
          signX509        cert pkey Nothing
-         return cert
\ No newline at end of file
+         return cert