diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -14,7 +14,7 @@ import Keter.Postgres import Keter.Process import Keter.Logger (Logger, detach) -import Keter.Nginx hiding (start) +import Keter.PortManager hiding (start) import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (decompress) import qualified Filesystem.Path.CurrentOS as F @@ -66,14 +66,14 @@ liftIO $ rest `onException` removeTree dir start :: TempFolder - -> Nginx + -> PortManager -> Postgres -> Logger -> Appname -> F.FilePath -- ^ app bundle -> KIO () -- ^ action to perform to remove this App from list of actives -> KIO (App, KIO ()) -start tf nginx postgres logger appname bundle removeFromList = do +start tf portman postgres logger appname bundle removeFromList = do chan <- newChan return (App $ writeChan chan, rest chan) where @@ -119,7 +119,7 @@ $logEx e removeFromList Right (dir, config) -> do - eport <- getPort nginx + eport <- getPort portman case eport of Left e -> do $logEx e @@ -129,11 +129,11 @@ b <- testApp port if b then do - addEntry nginx (configHost config) $ AppEntry port + addEntry portman (configHost config) port loop chan dir process port config else do removeFromList - releasePort nginx port + releasePort portman port Keter.Process.terminate process loop chan dirOld processOld portOld configOld = do @@ -141,7 +141,7 @@ case command of Terminate -> do removeFromList - removeEntry nginx $ configHost configOld + removeEntry portman $ configHost configOld log $ TerminatingApp appname terminateOld detach logger @@ -152,7 +152,7 @@ log $ InvalidBundle bundle e loop chan dirOld processOld portOld configOld Right (dir, config) -> do - eport <- getPort nginx + eport <- getPort portman case eport of Left e -> $logEx e Right port -> do @@ -160,14 +160,14 @@ b <- testApp port if b then do - addEntry nginx (configHost config) $ AppEntry port + addEntry portman (configHost config) port when (configHost config /= configHost configOld) $ - removeEntry nginx $ configHost configOld + removeEntry portman $ configHost configOld log $ FinishedReloading appname terminateOld loop chan dir process port config else do - releasePort nginx port + releasePort portman port Keter.Process.terminate process log $ ProcessDidNotStart bundle loop chan dirOld processOld portOld configOld diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -7,14 +7,17 @@ ) where import Keter.Prelude hiding (getCurrentTime) -import qualified Keter.Nginx as Nginx import qualified Keter.TempFolder as TempFolder import qualified Keter.App as App import qualified Keter.Postgres as Postgres import qualified Keter.LogFile as LogFile import qualified Keter.Logger as Logger +import qualified Keter.PortManager as PortMan +import qualified Keter.Proxy as Proxy +import Data.Conduit.Network (ServerSettings (ServerSettings), HostPreference) import qualified Control.Concurrent.MVar as M +import Control.Concurrent (forkIO) import qualified Data.Map as Map import qualified System.INotify as I import Control.Monad (forever, mzero) @@ -28,16 +31,31 @@ import Data.Maybe (fromMaybe) import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=)) import Control.Applicative ((<$>), (<*>)) +import Data.String (fromString) data Config = Config { configDir :: F.FilePath - , configNginx :: Nginx.Settings + , 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 parseJSON (Object o) = Config <$> (F.fromText <$> o .: "root") - <*> o .:? "nginx" .!= def + <*> 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 @@ -47,10 +65,10 @@ Config{..} <- if exists then decodeFile input' >>= maybe (P.error "Invalid config file") return - else return $ Config input def + else return def { configDir = input } let dir = F.directory input F. configDir - nginx <- runThrow $ Nginx.start configNginx + portman <- runThrow $ PortMan.start configPortMan tf <- runThrow $ TempFolder.setup $ dir "temp" postgres <- runThrow $ Postgres.load def $ dir "etc" "postgres.yaml" mainlog <- runThrow $ LogFile.start $ dir "log" "keter" @@ -66,6 +84,19 @@ runKIOPrint $ LogFile.addChunk mainlog bs runKIOPrint = runKIO P.print + _ <- forkIO $ Proxy.reverseProxy + (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 addApp bundle = do @@ -95,7 +126,7 @@ let logger = fromMaybe Logger.dummy mlogger (app, rest) <- App.start tf - nginx + portman postgres logger appname diff --git a/Keter/Nginx.hs b/Keter/Nginx.hs deleted file mode 100644 --- a/Keter/Nginx.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -module Keter.Nginx - ( -- * Types - Port - , Host - , Entry (..) - , Nginx - -- ** Settings - , Settings - , configFile - , reloadAction - , startAction - , portRange - -- * Actions - , getPort - , releasePort - , addEntry - , removeEntry - -- * Initialize - , start - ) where - -import Keter.Prelude -import System.Cmd (rawSystem) -import qualified Control.Monad.Trans.State as S -import Control.Monad.Trans.Class (lift) -import qualified Data.Map as Map -import Control.Monad (forever, mzero) -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (copyByteString, toLazyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow) -import Data.Monoid (Monoid, mconcat) -import Data.ByteString.Char8 () -import qualified Network -import qualified Data.ByteString as S -import System.Exit (ExitCode (ExitSuccess)) -import Data.Yaml (FromJSON (parseJSON), Value (Object), (.:?), (.!=)) -import Control.Applicative ((<$>), (<*>)) - --- | A port for an individual app to listen on. -type Port = Int - --- | A virtual host we want to serve content from. -type Host = String - -data Command = GetPort (Either SomeException Port -> KIO ()) - | ReleasePort Port - | AddEntry Host Entry - | RemoveEntry Host - --- | An individual virtual host may either be a reverse proxy to an app --- (@AppEntry@), or may serve static files (@StaticEntry@). -data Entry = AppEntry Port - | StaticEntry FilePath - --- | An abstract type which can accept commands and sends them to a background --- nginx thread. -newtype Nginx = Nginx (Command -> KIO ()) - --- | Controls execution of the nginx thread. Follows the settings type pattern. --- See: . -data Settings = Settings - { configFile :: FilePath - -- ^ Location of config file. Default: \/etc\/nginx\/sites-enabled\/keter - , reloadAction :: KIO (Either SomeException ()) - -- ^ How to tell Nginx to reload config file. Default: \/etc\/init.d\/nginx reload - , startAction :: KIO (Either SomeException ()) - -- ^ How to tell Nginx to start running. Default: \/etc\/init.d\/nginx start - , portRange :: [Port] - -- ^ Which ports to assign to apps. Default: 4000-4999 - } - -instance Default Settings where - def = Settings - { configFile = "/etc/nginx/sites-enabled/keter" - , reloadAction = rawSystem' "/etc/init.d/nginx" ["reload"] - , startAction = rawSystem' "/etc/init.d/nginx" ["start"] - , portRange = [4000..4999] - } - -instance FromJSON Settings where - parseJSON (Object o) = Settings - <$> (fmap fromText <$> o .:? "config") .!= configFile def - <*> (runRawSystem (reloadAction def) <$> (o .:? "reload")) - <*> (runRawSystem (startAction def) <$> (o .:? "start")) - <*> return (portRange def) - where - runRawSystem :: KIO (Either SomeException ()) -> Maybe [Text] -> KIO (Either SomeException ()) - runRawSystem _ (Just (command:args)) = rawSystem' (fromText command) args - runRawSystem _ (Just []) = fail "Command with empty list" - runRawSystem k Nothing = k - parseJSON _ = mzero - -rawSystem' :: FilePath -> [String] -> KIO (Either SomeException ()) -rawSystem' fp args = do - eec <- liftIO $ rawSystem (toString fp) (map toString args) - case eec of - Left e -> return $ Left e - Right ec - | ec == ExitSuccess -> return $ Right () - | otherwise -> return $ Left $ toException $ ExitCodeFailure fp ec - --- | Start running a separate thread which will accept commands and modify --- Nginx's behavior accordingly. -start :: Settings -> KIO (Either SomeException Nginx) -start Settings{..} = do - -- Start off by ensuring we can read and write the config file and reload - eres <- liftIO $ do - exists <- isFile configFile - config0 <- - if exists - then S.readFile $ toString configFile - else return "" - let tmp = configFile <.> "tmp" - S.writeFile (toString tmp) config0 - rename tmp configFile - case eres of - Left e -> return $ Left e - Right () -> do - eres2 <- reloadAction - case eres2 of - Left e -> return $ Left e - Right () -> go - - where - go :: KIO (Either SomeException Nginx) - go = do - chan <- newChan - forkKIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do - command <- lift $ readChan chan - case command of - GetPort f -> do - ns0 <- S.get - let loop :: NState -> KIO (Either SomeException Port, NState) - loop ns = - case nsAvail ns of - p:ps -> do - res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p - case res of - Left (_ :: SomeException) -> do - log $ RemovingPort p - loop ns { nsAvail = ps } - Right socket -> do - res' <- liftIO $ Network.sClose socket - case res' of - Left e -> do - $logEx e - log $ RemovingPort p - loop ns { nsAvail = ps } - Right () -> return (Right p, ns { nsAvail = ps }) - [] -> - case reverse $ nsRecycled ns of - [] -> return (Left $ toException NoPortsAvailable, ns) - ps -> loop ns { nsAvail = ps, nsRecycled = [] } - (eport, ns) <- lift $ loop ns0 - S.put ns - lift $ f eport - ReleasePort p -> - S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns } - AddEntry h e -> change $ Map.insert h e - RemoveEntry h -> change $ Map.delete h - return $ Right $ Nginx $ writeChan chan - - change f = do - ns <- S.get - let entries = f $ nsEntries ns - S.put $ ns { nsEntries = entries } - let tmp = configFile <.> "tmp" - lift $ do - res1 <- liftIO $ do - L.writeFile (toString tmp) $ mkConfig entries - rename tmp configFile - res2 <- case res1 of - Left e -> return $ Left e - Right () -> reloadAction - case res2 of - Left e -> $logEx e - Right () -> return () - mkConfig = toLazyByteString . mconcat . map mkConfig' . Map.toList - mkConfig' (host, entry) = - copyByteString "server {\n listen 80;\n server_name " ++ - fromText host ++ copyByteString ";\n" ++ - mkConfigEntry entry ++ - copyByteString "}\n" - mkConfigEntry (AppEntry port) = - copyByteString " location / {\n proxy_pass http://127.0.0.1:" ++ - fromShow port ++ copyByteString ";\n proxy_set_header X-Real-IP $remote_addr;\n }\n" - mkConfigEntry (StaticEntry fp) = - copyByteString " root " ++ fromString (toString fp) ++ copyByteString ";\n expires max;\n" - -data NState = NState - { nsAvail :: [Port] - , nsRecycled :: [Port] - , nsEntries :: Map.Map Host Entry - } - --- | Gets an unassigned port number. -getPort :: Nginx -> KIO (Either SomeException Port) -getPort (Nginx f) = do - x <- newEmptyMVar - f $ GetPort $ \p -> putMVar x p - takeMVar x - --- | Inform the nginx thread that the given port number is no longer being --- used, and may be reused by a new process. Note that recycling puts the new --- ports at the end of the queue (FIFO), so that if an application holds onto --- the port longer than expected, there should be no issues. -releasePort :: Nginx -> Port -> KIO () -releasePort (Nginx f) p = f $ ReleasePort p - --- | Add a new entry to the configuration for the given hostname and reload --- nginx. Will overwrite any existing configuration for the given host. The --- second point is important: it is how we achieve zero downtime transitions --- between an old and new version of an app. -addEntry :: Nginx -> Host -> Entry -> KIO () -addEntry (Nginx f) h e = f $ AddEntry h e - --- | Remove an entry from the configuration and reload nginx. -removeEntry :: Nginx -> Host -> KIO () -removeEntry (Nginx f) h = f $ RemoveEntry h diff --git a/Keter/PortManager.hs b/Keter/PortManager.hs new file mode 100644 --- /dev/null +++ b/Keter/PortManager.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +module Keter.PortManager + ( -- * Types + Port + , Host + , PortManager + -- ** Settings + , Settings + , portRange + -- * Actions + , getPort + , releasePort + , addEntry + , removeEntry + , lookupPort + , hostList + -- * Initialize + , start + ) where + +import Keter.Prelude +import qualified Control.Monad.Trans.State as S +import Control.Monad.Trans.Class (lift) +import qualified Data.Map as Map +import Control.Monad (forever, mzero) +import Data.ByteString.Char8 () +import qualified Network +import qualified Data.ByteString as S +import Data.Text.Encoding (encodeUtf8) +import Data.Yaml (FromJSON (parseJSON), Value (Object)) +import Control.Applicative ((<$>)) + +-- | A port for an individual app to listen on. +type Port = Int + +-- | A virtual host we want to serve content from. +type Host = String + +data Command = GetPort (Either SomeException Port -> KIO ()) + | ReleasePort Port + | AddEntry Host Port + | RemoveEntry Host + | LookupPort S.ByteString (Maybe Port -> KIO ()) + | HostList ([S.ByteString] -> KIO ()) + +-- | An abstract type which can accept commands and sends them to a background +-- nginx thread. +newtype PortManager = PortManager (Command -> KIO ()) + +-- | Controls execution of the nginx thread. Follows the settings type pattern. +-- See: . +data Settings = Settings + { portRange :: [Port] + -- ^ Which ports to assign to apps. Default: 4000-4999 + } + +instance Default Settings where + def = Settings + { portRange = [4000..4999] + } + +instance FromJSON Settings where + parseJSON (Object _) = Settings + <$> return (portRange def) + parseJSON _ = mzero + +-- | Start running a separate thread which will accept commands and modify +-- Nginx's behavior accordingly. +start :: Settings -> KIO (Either SomeException PortManager) +start Settings{..} = do + chan <- newChan + forkKIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do + command <- lift $ readChan chan + case command of + GetPort f -> do + ns0 <- S.get + let loop :: NState -> KIO (Either SomeException Port, NState) + loop ns = + case nsAvail ns of + p:ps -> do + res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p + case res of + Left (_ :: SomeException) -> do + log $ RemovingPort p + loop ns { nsAvail = ps } + Right socket -> do + res' <- liftIO $ Network.sClose socket + case res' of + Left e -> do + $logEx e + log $ RemovingPort p + loop ns { nsAvail = ps } + Right () -> return (Right p, ns { nsAvail = ps }) + [] -> + case reverse $ nsRecycled ns of + [] -> return (Left $ toException NoPortsAvailable, ns) + ps -> loop ns { nsAvail = ps, nsRecycled = [] } + (eport, ns) <- lift $ loop ns0 + S.put ns + lift $ f eport + ReleasePort p -> + S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns } + AddEntry h e -> change $ Map.insert (encodeUtf8 h) e + RemoveEntry h -> change $ Map.delete $ encodeUtf8 h + LookupPort h f -> do + NState {..} <- S.get + lift $ f $ Map.lookup h nsEntries + HostList f -> do + NState {..} <- S.get + lift $ f $ Map.keys nsEntries + return $ Right $ PortManager $ writeChan chan + where + change f = do + ns <- S.get + let entries = f $ nsEntries ns + S.put $ ns { nsEntries = entries } + +data NState = NState + { nsAvail :: [Port] + , nsRecycled :: [Port] + , nsEntries :: Map.Map S.ByteString Port + } + +-- | Gets an unassigned port number. +getPort :: PortManager -> KIO (Either SomeException Port) +getPort (PortManager f) = do + x <- newEmptyMVar + f $ GetPort $ \p -> putMVar x p + takeMVar x + +-- | Inform the nginx thread that the given port number is no longer being +-- used, and may be reused by a new process. Note that recycling puts the new +-- ports at the end of the queue (FIFO), so that if an application holds onto +-- the port longer than expected, there should be no issues. +releasePort :: PortManager -> Port -> KIO () +releasePort (PortManager f) p = f $ ReleasePort p + +-- | Add a new entry to the configuration for the given hostname and reload +-- nginx. Will overwrite any existing configuration for the given host. The +-- second point is important: it is how we achieve zero downtime transitions +-- between an old and new version of an app. +addEntry :: PortManager -> Host -> Port -> KIO () +addEntry (PortManager f) h p = f $ AddEntry h p + +-- | Remove an entry from the configuration and reload nginx. +removeEntry :: PortManager -> Host -> KIO () +removeEntry (PortManager f) h = f $ RemoveEntry h + +lookupPort :: PortManager -> S.ByteString -> KIO (Maybe Port) +lookupPort (PortManager f) h = do + x <- newEmptyMVar + f $ LookupPort h $ \p -> putMVar x p + takeMVar x + +hostList :: PortManager -> KIO [S.ByteString] +hostList (PortManager f) = do + x <- newEmptyMVar + f $ HostList $ \p -> putMVar x p + takeMVar x diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs new file mode 100644 --- /dev/null +++ b/Keter/Proxy.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | A light-weight, minimalistic reverse HTTP proxy. +module Keter.Proxy + ( reverseProxy + , PortLookup + , HostList + , reverseProxySsl + , setDir + , SslConfig + ) where + +import Keter.Prelude ((++)) +import Prelude hiding ((++), FilePath) +import Data.Conduit +import Data.Conduit.List (peek) +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 (onException) +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 + +-- | Mapping from virtual hostname to port number. +type PortLookup = ByteString -> IO (Maybe Port) + +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 + 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) + where + withServer rsrc fromServer toServer = do + x <- newEmptyMVar + tid1 <- forkIO $ (rsrc $$+- toServer) `onException` putMVar x True + tid2 <- forkIO $ (fromServer $$ toClient) `onException` putMVar x False + y <- takeMVar x + killThread $ if y then tid2 else tid1 + +getVhost :: Monad m => Sink ByteString m (Maybe ByteString) +getVhost = + peek >>= maybe (return Nothing) (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 hosts = + 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\nWelcome to Keter

Welcome to Keter

You may access the following sites:

" + go host = fromByteString "
  • " ++ + fromByteString host ++ fromByteString "
    • " diff --git a/Keter/SSL.hs b/Keter/SSL.hs new file mode 100644 --- /dev/null +++ b/Keter/SSL.hs @@ -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 diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 0.1.0.1 +Version: 0.2.0 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Handles deployment of web apps, using Nginx as a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: Homepage: http://www.yesodweb.com/ @@ -33,8 +33,14 @@ , hinotify >= 0.3 && < 0.4 , system-filepath >= 0.4 && < 0.5 , system-fileio >= 0.3 && < 0.4 - Exposed-Modules: Keter.Nginx - Keter.Process + , 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 Keter.App @@ -42,6 +48,9 @@ Keter.Prelude Keter.LogFile Keter.Logger + Keter.Proxy + Keter.PortManager + Keter.SSL ghc-options: -Wall Executable keter