network-conduit-tls and http-reverse-proxy

2024-12-14 08:05:40 +03:00 · 2012-10-02 21:57:27 +02:00 · 2012-10-02 21:57:27 +02:00 · f5656c660c
commit f5656c660c
parent 9e5e4ab233
5 changed files with 34 additions and 182 deletions
--- a/Keter/Main.hs
+++ b/Keter/Main.hs
@ -38,7 +38,7 @@ data Config = Config
    , configPortMan :: PortMan.Settings
    , configHost :: HostPreference
    , configPort :: PortMan.Port
-    , configSsl :: Maybe Proxy.SslConfig
+    , configSsl :: Maybe Proxy.TLSConfigNoDir
    }
 instance Default Config where
    def = Config
--- a/Keter/Proxy.hs
+++ b/Keter/Proxy.hs
@ -6,7 +6,8 @@ module Keter.Proxy
    , HostList
    , reverseProxySsl
    , setDir
-    , SslConfig
+    , TLSConfig
+    , TLSConfigNoDir
    ) where

 import Keter.Prelude ((++))
@ -14,17 +15,13 @@ import Prelude hiding ((++), FilePath)
 import Data.Conduit
 import Data.Conduit.Network
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as S8
-import Control.Concurrent (forkIO, killThread)
-import Control.Concurrent.MVar
-import Data.Char (isSpace, toLower)
-import Control.Exception (finally)
 import Keter.PortManager (Port)
-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
+import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest))
+import Control.Applicative ((<$>))

 -- | Mapping from virtual hostname to port number.
 type PortLookup = ByteString -> IO (Maybe Port)
@ -34,61 +31,24 @@ 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
+reverseProxySsl :: TLSConfig -> PortLookup -> HostList -> IO ()
+reverseProxySsl settings x = runTCPServerTLS settings . withClient x

 withClient :: PortLookup
           -> HostList
-           -> Source IO ByteString
-           -> Sink ByteString IO ()
-           -> IO ()
-withClient portLookup hostList fromClient toClient = do
-    (rsrc, mvhost) <- fromClient $$+ getVhost
-    mport <- maybe (return Nothing) portLookup mvhost
-    case mport of
-        Nothing -> lift (fmap toResponse hostList) >>= mapM_ yield $$ toClient
-        Just port -> runTCPClient (ClientSettings port "127.0.0.1") (withServer rsrc)
+           -> Application IO
+withClient portLookup hostList =
+    rawProxyTo getDest
  where
-    withServer rsrc fromServer toServer = do
-        x <- newEmptyMVar
-        tid1 <- forkIO $ (rsrc $$+- toServer) `finally` putMVar x True
-        tid2 <- forkIO $ (fromServer $$ toClient) `finally` putMVar x False
-        y <- takeMVar x
-        killThread $ if y then tid2 else tid1
+    getDest headers = do
+        mport <- maybe (return Nothing) portLookup $ lookup "host" headers
+        case mport of
+            Nothing -> Left . toResponse <$> hostList
+            Just port -> return $ Right $ ProxyDest "127.0.0.1" port

-getHeaders :: Monad m => Sink ByteString m ByteString
-getHeaders =
-    go id
-  where
-    go front =
-        await >>= maybe close push
-      where
-        close = leftover bs >> return bs
-          where
-            bs = front S8.empty
-        push bs'
-            | "\r\n\r\n" `S8.isInfixOf` bs
-              || "\n\n" `S8.isInfixOf` bs
-              || S8.length bs > 1000 = leftover bs >> return bs
-            | otherwise = go $ S8.append bs
-          where
-            bs = front bs'
-
-getVhost :: Monad m => Sink ByteString m (Maybe ByteString)
-getVhost =
-    getHeaders >>= return . go . drop 1 . S8.lines
-  where
-    go [] = Nothing
-    go (bs:bss)
-        | S8.map toLower k == "host" = Just v
-        | otherwise = go bss
-      where
-        (k, v') = S8.break (== ':') bs
-        v = S8.takeWhile (not . isSpace) $ S8.dropWhile isSpace $ S8.drop 1 v'
-
-toResponse :: [ByteString] -> [ByteString]
+toResponse :: Monad m => [ByteString] -> Source m ByteString
 toResponse hosts =
-    L.toChunks $ toLazyByteString $ front ++ mconcat (map go hosts) ++ end
+    mapM_ yield $ L.toChunks $ toLazyByteString $ front ++ mconcat (map go hosts) ++ end
  where
    front = fromByteString "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You may access the following sites:</p><ul>"
    end = fromByteString "</ul></body></html>"
--- a/Keter/SSL.hs
+++ b/Keter/SSL.hs
@ -1,136 +1,31 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 module Keter.SSL
-    ( SslConfig (..)
+    ( TLSConfig (..)
+    , TLSConfigNoDir
    , setDir
-    , runTCPServerSsl
+    , runTCPServerTLS
    ) where

-import Keter.Prelude ((++))
-import Prelude hiding ((++), FilePath, readFile)
+import Prelude hiding (FilePath)
 import Data.Yaml (FromJSON (parseJSON), (.:), (.:?), (.!=), Value (Object))
 import Control.Applicative ((<$>), (<*>))
-import Control.Monad (mzero, forever)
+import Control.Monad (mzero)
 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
+import Data.Conduit.Network.TLS

-data SslConfig = SslConfig
-    { sslHost :: HostPreference
-    , sslPort :: Port
-    , sslCertificate :: FilePath
-    , sslKey :: FilePath
+setDir :: FilePath -> TLSConfigNoDir -> TLSConfig
+setDir dir (TLSConfigNoDir tls) = tls
+    { tlsCertificate = dir </> tlsCertificate tls
+    , tlsKey = dir </> tlsKey tls
    }

-setDir :: FilePath -> SslConfig -> SslConfig
-setDir dir ssl = ssl
-    { sslCertificate = dir </> sslCertificate ssl
-    , sslKey = dir </> sslKey ssl
-    }
+newtype TLSConfigNoDir = TLSConfigNoDir TLSConfig

-instance FromJSON SslConfig where
-    parseJSON (Object o) = SslConfig
+instance FromJSON TLSConfigNoDir where
+    parseJSON (Object o) = fmap TLSConfigNoDir $ TLSConfig
        <$> (fmap fromString <$> o .:? "host") .!= "*"
        <*> o .:? "port" .!= 443
        <*> (fromString <$> o .: "certificate")
        <*> (fromString <$> o .: "key")
    parseJSON _ = mzero
-
-runTCPServerSsl :: SslConfig -> Application IO -> IO ()
-runTCPServerSsl SslConfig{..} app = do
-    certs <- readCertificates sslCertificate
-    key <- readPrivateKey sslKey
-    bracket
-        (bindPort sslPort sslHost)
-        sClose
-        (forever . serve certs key)
-  where
-    serve certs 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    = zip certs $ Just key : repeat Nothing
-            }
-
-- 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
-    ]
-
-readCertificates :: FilePath -> IO [X509.X509]
-readCertificates filepath = do
-    certs <- rights . parseCerts . PEM.pemParseBS <$> readFile filepath
-    case certs of
-        []    -> error "no valid certificate found"
-        (_:_) -> return certs
-    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
--- a/keter-config.yaml
+++ b/keter-config.yaml
@ -1,9 +1,9 @@
 # Just a sample config file, using Debian/Ubuntu settings

 root: .
-host: 127.0.0.1
+host: "*4"
 port: 80
 ssl:
-    host: 127.0.0.1
+    host: "*4"
    key: key.pem
    certificate: certificate.pem
--- a/keter.cabal
+++ b/keter.cabal
@ -35,11 +35,8 @@ 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
+                     , network-conduit-tls       >= 0.5           && < 0.6
+                     , http-reverse-proxy        >= 0.1           && < 0.2
  Exposed-Modules:     Keter.Process
                       Keter.Postgres
                       Keter.TempFolder