-{-# 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 "mtl" Control.Monad.Trans
+import Control.Monad.Unicode
+import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Time.Clock
+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
-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
+ cnfServerPort = "9000"
, cnfSSLConfig = Just SSLConfig {
- sslServerPort = PortNumber 9001
+ sslServerPort = "9001"
, sslContext = ctx
}
}
- resources = mkResTree [ ( []
- , helloWorld )
- ]
+ resources = mkResTree [ ([], helloWorld) ]
putStrLn "Access https://localhost:9001/ with your browser."
runHttpd config resources []
-
-helloWorld :: ResourceDef
+helloWorld ∷ ResourceDef
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
+ = emptyResource {
+ resGet
+ = Just $ 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