Permalink
Browse files

Initial SSL support

  • Loading branch information...
1 parent 80798aa commit 0cb1d5b2a0b125630da330b0d58e2503365fbc66 @snoyberg committed Aug 9, 2012
Showing with 195 additions and 2 deletions.
  1. +11 −0 Keter/Main.hs
  2. +8 −2 Keter/Proxy.hs
  3. +136 −0 Keter/SSL.hs
  4. +15 −0 certificate.pem
  5. +4 −0 keter-config.yaml
  6. +6 −0 keter.cabal
  7. +15 −0 key.pem
View
@@ -38,13 +38,15 @@ data Config = Config
, configPortMan :: PortMan.Settings
, configHost :: HostPreference
, configPort :: PortMan.Port
+ , configSsl :: Maybe Proxy.SslConfig
}
instance Default Config where
def = Config
{ configDir = "."
, configPortMan = def
, configHost = "*"
, configPort = 80
+ , configSsl = Nothing
}
instance FromJSON Config where
@@ -53,6 +55,7 @@ instance FromJSON Config where
<*> o .:? "port-manager" .!= def
<*> (fmap fromString <$> o .:? "host") .!= configHost def
<*> o .:? "port" .!= configPort def
+ <*> o .:? "ssl"
parseJSON _ = mzero
keter :: P.FilePath -- ^ root directory or config file
@@ -85,6 +88,14 @@ keter input' = do
(ServerSettings configPort configHost)
(runKIOPrint . PortMan.lookupPort portman)
(runKIOPrint $ PortMan.hostList portman)
+ case configSsl of
+ Nothing -> return ()
+ Just ssl -> do
+ _ <- forkIO $ Proxy.reverseProxySsl
+ (Proxy.setDir dir ssl)
+ (runKIOPrint . PortMan.lookupPort portman)
+ (runKIOPrint $ PortMan.hostList portman)
+ return ()
mappMap <- M.newMVar Map.empty
let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname
View
@@ -4,10 +4,13 @@ module Keter.Proxy
( reverseProxy
, PortLookup
, HostList
+ , reverseProxySsl
+ , setDir
+ , SslConfig
) where
import Keter.Prelude ((++))
-import Prelude hiding ((++))
+import Prelude hiding ((++), FilePath)
import Data.Conduit
import Data.Conduit.List (peek)
import Data.Conduit.Network
@@ -22,6 +25,7 @@ import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
import Data.Monoid (mconcat)
+import Keter.SSL
-- | Mapping from virtual hostname to port number.
type PortLookup = ByteString -> IO (Maybe Port)
@@ -31,14 +35,16 @@ type HostList = IO [ByteString]
reverseProxy :: ServerSettings -> PortLookup -> HostList -> IO ()
reverseProxy settings x = runTCPServer settings . withClient x
+reverseProxySsl :: SslConfig -> PortLookup -> HostList -> IO ()
+reverseProxySsl settings x = runTCPServerSsl settings . withClient x
+
withClient :: PortLookup
-> HostList
-> Source IO ByteString
-> Sink ByteString IO ()
-> IO ()
withClient portLookup hostList fromClient toClient = do
(rsrc, mvhost) <- fromClient $$+ getVhost
- putStrLn $ "Received client connection for host: " ++ show mvhost
mport <- maybe (return Nothing) portLookup mvhost
case mport of
Nothing -> lift (fmap toResponse hostList) >>= mapM_ yield $$ toClient
View
@@ -0,0 +1,136 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Keter.SSL
+ ( SslConfig (..)
+ , setDir
+ , runTCPServerSsl
+ ) where
+
+import Keter.Prelude ((++))
+import Prelude hiding ((++), FilePath, readFile)
+import Data.Yaml (FromJSON (parseJSON), (.:), (.:?), (.!=), Value (Object))
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (mzero, forever)
+import Data.String (fromString)
+import Filesystem.Path.CurrentOS ((</>), FilePath)
+import Filesystem (readFile)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Certificate.KeyRSA as KeyRSA
+import qualified Data.PEM as PEM
+import qualified Network.TLS as TLS
+import qualified Data.Certificate.X509 as X509
+import Data.Conduit.Network (HostPreference, Application, bindPort, sinkSocket)
+import Data.Conduit (($$), yield)
+import qualified Data.Conduit.List as CL
+import Data.Either (rights)
+import Keter.PortManager (Port)
+import Network.Socket (sClose, accept)
+import Network.Socket.ByteString (recv)
+import Control.Exception (bracket, finally)
+import Control.Concurrent (forkIO)
+import Control.Monad.Trans.Class (lift)
+import qualified Network.TLS.Extra as TLSExtra
+import Crypto.Random
+
+data SslConfig = SslConfig
+ { sslHost :: HostPreference
+ , sslPort :: Port
+ , sslCertificate :: FilePath
+ , sslKey :: FilePath
+ }
+
+setDir :: FilePath -> SslConfig -> SslConfig
+setDir dir ssl = ssl
+ { sslCertificate = dir </> sslCertificate ssl
+ , sslKey = dir </> sslKey ssl
+ }
+
+instance FromJSON SslConfig where
+ parseJSON (Object o) = SslConfig
+ <$> (fmap fromString <$> o .:? "host") .!= "*"
+ <*> o .:? "port" .!= 443
+ <*> (fromString <$> o .: "certificate")
+ <*> (fromString <$> o .: "key")
+ parseJSON _ = mzero
+
+runTCPServerSsl :: SslConfig -> Application IO -> IO ()
+runTCPServerSsl SslConfig{..} app = do
+ cert <- readCertificate sslCertificate
+ key <- readPrivateKey sslKey
+ bracket
+ (bindPort sslPort sslHost)
+ sClose
+ (forever . serve cert key)
+ where
+ serve cert key lsocket = do
+ (socket, _addr) <- accept lsocket -- FIXME exception safety
+ _ <- forkIO $ handle socket
+ return ()
+ where
+ handle socket = do
+ gen <- newGenIO
+ ctx <- TLS.serverWith
+ params
+ (gen :: SystemRandom)
+ socket
+ (return ()) -- flush
+ (\bs -> yield bs $$ sinkSocket socket)
+ (recv socket)
+
+ TLS.handshake ctx
+ {-
+ let conn = Connection
+ { connSendMany = TLS.sendData ctx . L.fromChunks
+ , connSendAll = TLS.sendData ctx . L.fromChunks . return
+ , connSendFile = \fp offset len _th headers -> do
+ TLS.sendData ctx $ L.fromChunks headers
+ C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)
+ , connClose = do
+ TLS.bye ctx
+ sClose s
+ , connRecv = TLS.recvData ctx
+ }
+ return (conn, sa)
+ -}
+
+ let src = lift (TLS.recvData ctx) >>= yield >> src
+ sink = CL.mapM_ $ TLS.sendData ctx . L.fromChunks . return
+
+ app src sink `finally` sClose socket
+
+ params = TLS.defaultParams
+ { TLS.pWantClientCert = False
+ , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]
+ , TLS.pCiphers = ciphers
+ , TLS.pCertificates = [(cert, Just key)]
+ }
+
+-- taken from stunnel example in tls-extra
+ciphers :: [TLS.Cipher]
+ciphers =
+ [ TLSExtra.cipher_AES128_SHA1
+ , TLSExtra.cipher_AES256_SHA1
+ , TLSExtra.cipher_RC4_128_MD5
+ , TLSExtra.cipher_RC4_128_SHA1
+ ]
+
+readCertificate :: FilePath -> IO X509.X509
+readCertificate filepath = do
+ certs <- rights . parseCerts . PEM.pemParseBS <$> readFile filepath
+ case certs of
+ [] -> error "no valid certificate found"
+ (x:_) -> return x
+ where parseCerts (Right pems) = map (X509.decodeCertificate . L.fromChunks . (:[]) . PEM.pemContent)
+ $ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . PEM.pemName) pems
+ parseCerts (Left err) = error $ "cannot parse PEM file: " ++ err
+
+readPrivateKey :: FilePath -> IO TLS.PrivateKey
+readPrivateKey filepath = do
+ pk <- rights . parseKey . PEM.pemParseBS <$> readFile filepath
+ case pk of
+ [] -> error "no valid RSA key found"
+ (x:_) -> return x
+
+ where parseKey (Right pems) = map (fmap (TLS.PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . PEM.pemContent)
+ $ filter ((== "RSA PRIVATE KEY") . PEM.pemName) pems
+ parseKey (Left err) = error $ "Cannot parse PEM file: " ++ err
View
@@ -0,0 +1,15 @@
+-----BEGIN CERTIFICATE-----
+MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV
+BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX
+aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF
+MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50
+ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
+gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx
+EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs
++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV
+HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM
+b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk
+D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0
+k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw
+VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==
+-----END CERTIFICATE-----
View
@@ -3,3 +3,7 @@
root: .
host: 127.0.0.1
port: 80
+ssl:
+ host: 127.0.0.1
+ key: key.pem
+ certificate: certificate.pem
View
@@ -35,6 +35,11 @@ Library
, system-fileio >= 0.3 && < 0.4
, conduit >= 0.5 && < 0.6
, network-conduit >= 0.5 && < 0.6
+ , pem >= 0.1 && < 0.2
+ , certificate >= 1.2 && < 1.3
+ , tls >= 0.9.8 && < 0.10
+ , tls-extra >= 0.4 && < 0.5
+ , crypto-api >= 0.10 && < 0.11
Exposed-Modules: Keter.Process
Keter.Postgres
Keter.TempFolder
@@ -45,6 +50,7 @@ Library
Keter.Logger
Keter.Proxy
Keter.PortManager
+ Keter.SSL
ghc-options: -Wall
Executable keter
View
15 key.pem
@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd
+thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD
+JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB
+AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63
+CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM
+MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp
+ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid
+Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B
+5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs
+eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV
+YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv
+jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG
+T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=
+-----END RSA PRIVATE KEY-----

0 comments on commit 0cb1d5b

Please sign in to comment.