keter 0.2.0.3 → 0.3.0
raw patch · 7 files changed
+128/−244 lines, 7 filesdep +http-reverse-proxydep +network-conduit-tlsdep +unixdep −certificatedep −crypto-apidep −pemdep ~network-conduitdep ~unix-compat
Dependencies added: http-reverse-proxy, network-conduit-tls, unix, unix-process-conduit
Dependencies removed: certificate, crypto-api, pem, tls, tls-extra
Dependency ranges changed: network-conduit, unix-compat
Files
- Keter/Logger.hs +57/−42
- Keter/Main.hs +3/−3
- Keter/Prelude.hs +4/−0
- Keter/Process.hs +25/−17
- Keter/Proxy.hs +19/−56
- Keter/SSL.hs +13/−118
- keter.cabal +7/−8
Keter/Logger.hs view
@@ -6,27 +6,56 @@ , start , attach , detach- , Handles (..)+ , LogPipes (..)+ , LogPipe+ , mkLogPipe , dummy ) where import Keter.Prelude-import System.IO (Handle, hClose) import qualified Prelude as P import qualified Keter.LogFile as LogFile import Control.Concurrent (killThread) import qualified Data.ByteString as S-import Control.Exception (fromException, AsyncException (ThreadKilled))+import Data.Conduit (Sink, await)+import qualified Control.Concurrent.MVar as M+import Control.Monad.Trans.Class (lift) -data Handles = Handles- { stdIn :: Maybe Handle- , stdOut :: Maybe Handle- , stdErr :: Maybe Handle+data LogPipes = LogPipes+ { stdOut :: LogPipe+ , stdErr :: LogPipe } +data LogPipe = LogPipe+ { readLogPipe :: KIO (Maybe S.ByteString)+ , closeLogPipe :: KIO ()+ }++mkLogPipe :: KIO (LogPipe, Sink S.ByteString P.IO ())+mkLogPipe = do+ toSink <- newEmptyMVar+ fromSink <- newEmptyMVar+ let pipe = LogPipe+ { readLogPipe = do+ putMVar toSink True+ takeMVar fromSink+ , closeLogPipe = do+ _ <- tryTakeMVar toSink+ putMVar toSink False+ }+ sink = do+ toCont <- lift $ M.takeMVar toSink+ if toCont+ then do+ mbs <- await+ lift $ M.putMVar fromSink mbs+ maybe (return ()) (P.const sink) mbs+ else return ()+ return (pipe, sink)+ newtype Logger = Logger (Command -> KIO ()) -data Command = Attach Handles | Detach+data Command = Attach LogPipes | Detach start :: LogFile.LogFile -- ^ stdout -> LogFile.LogFile -- ^ stderr@@ -50,52 +79,38 @@ Detach -> do LogFile.close lfout LogFile.close lferr- Attach (Handles min mout merr) -> do+ Attach (LogPipes out err) -> do LogFile.addChunk lfout "\n\nAttaching new process\n\n" LogFile.addChunk lferr "\n\nAttaching new process\n\n"- hmClose min- let go mhandle lf =- case mhandle of- Nothing -> return Nothing- Just handle -> do- etid <- forkKIO' $ listener handle lf- case etid of- Left e -> do- $logEx e- hmClose mhandle- return Nothing- Right tid -> return $ Just tid- newout <- go mout lfout- newerr <- go merr lferr+ let go logpipe lf = do+ etid <- forkKIO' $ listener logpipe lf+ case etid of+ Left e -> do+ $logEx e+ closeLogPipe logpipe+ return Nothing+ Right tid -> return $ Just tid+ newout <- go out lfout+ newerr <- go err lferr loop chan newout newerr -hmClose :: Maybe Handle -> KIO ()-hmClose Nothing = return ()-hmClose (Just h) = liftIO (hClose h) >>= either $logEx return--listener :: Handle -> LogFile.LogFile -> KIO ()+listener :: LogPipe -> LogFile.LogFile -> KIO () listener out lf = loop where loop = do- ebs <- liftIO $ S.hGetSome out 4096- case ebs of- Left e -> do- case fromException e of- Just ThreadKilled -> return ()- _ -> $logEx e- hmClose $ Just out- Right bs- | S.null bs -> hmClose (Just out)- | otherwise -> do- LogFile.addChunk lf bs- listener out lf+ mbs <- readLogPipe out+ case mbs of+ Nothing -> return ()+ Just bs -> do+ LogFile.addChunk lf bs+ loop -attach :: Logger -> Handles -> KIO ()+attach :: Logger -> LogPipes -> KIO () attach (Logger f) h = f (Attach h) detach :: Logger -> KIO () detach (Logger f) = f Detach dummy :: Logger-dummy = P.error "Logger.dummy"+dummy = Logger $ P.const $ return ()
Keter/Main.hs view
@@ -15,7 +15,7 @@ import qualified Keter.PortManager as PortMan import qualified Keter.Proxy as Proxy -import Data.Conduit.Network (ServerSettings (ServerSettings), HostPreference)+import Data.Conduit.Network (serverSettings, HostPreference) import qualified Control.Concurrent.MVar as M import Control.Concurrent (forkIO) import qualified Data.Map as Map@@ -38,7 +38,7 @@ , configPortMan :: PortMan.Settings , configHost :: HostPreference , configPort :: PortMan.Port- , configSsl :: Maybe Proxy.SslConfig+ , configSsl :: Maybe Proxy.TLSConfigNoDir } instance Default Config where def = Config@@ -85,7 +85,7 @@ runKIOPrint = runKIO P.print _ <- forkIO $ Proxy.reverseProxy- (ServerSettings configPort configHost)+ (serverSettings configPort configHost) (runKIOPrint . PortMan.lookupPort portman) (runKIOPrint $ PortMan.hostList portman) case configSsl of
Keter/Prelude.hs view
@@ -84,6 +84,7 @@ , modifyMVar_ , swapMVar , takeMVar+ , tryTakeMVar , putMVar -- * IORef , I.IORef@@ -246,6 +247,9 @@ takeMVar :: M.MVar a -> KIO a takeMVar = liftIO_ . M.takeMVar++tryTakeMVar :: M.MVar a -> KIO (P.Maybe a)+tryTakeMVar = liftIO_ . M.tryTakeMVar putMVar :: M.MVar a -> a -> KIO () putMVar m = liftIO_ . M.putMVar m
Keter/Process.hs view
@@ -7,11 +7,16 @@ ) where import Keter.Prelude-import Keter.Logger-import qualified System.Process as SP+import Keter.Logger (Logger, attach, LogPipes (..), mkLogPipe) import Data.Time (diffUTCTime)+import Data.Conduit.Process.Unix (forkExecuteFile, waitForProcess, killProcess)+import System.Posix.Types (ProcessID)+import Prelude (error)+import Filesystem.Path.CurrentOS (encode)+import Data.Text.Encoding (encodeUtf8)+import Data.Conduit (($$)) -data Status = NeedsRestart | NoRestart | Running SP.ProcessHandle+data Status = NeedsRestart | NoRestart | Running ProcessID -- | Run the given command, restarting if the process dies. run :: FilePath -- ^ executable@@ -33,27 +38,30 @@ log $ ProcessWaiting exec threadDelay $ 5 * 1000 * 1000 _ -> return ()- res <- liftIO $ SP.createProcess cp+ (pout, sout) <- mkLogPipe+ (perr, serr) <- mkLogPipe+ res <- liftIO $ forkExecuteFile+ (encode exec)+ False+ (map encodeUtf8 args)+ (Just $ map (encodeUtf8 *** encodeUtf8) env)+ (Just $ encode dir)+ (Just $ return ())+ (Just sout)+ (Just serr) case res of Left e -> do+ void $ liftIO $ return () $$ sout+ void $ liftIO $ return () $$ serr $logEx e return (NeedsRestart, return ())- Right (hin, hout, herr, ph) -> do- attach logger $ Handles hin hout herr+ Right pid -> do+ attach logger $ LogPipes pout perr log $ ProcessCreated exec- return (Running ph, liftIO (SP.waitForProcess ph) >> loop (Just now))+ return (Running pid, liftIO (waitForProcess pid) >> loop (Just now)) next forkKIO $ loop Nothing return $ Process mstatus- where- cp = (SP.proc (toString exec) $ map toString args)- { SP.cwd = Just $ toString dir- , SP.env = Just $ map (toString *** toString) env- , SP.std_in = SP.CreatePipe- , SP.std_out = SP.CreatePipe- , SP.std_err = SP.CreatePipe- , SP.close_fds = True- } -- | Abstract type containing information on a process which will be restarted. newtype Process = Process (MVar Status)@@ -63,5 +71,5 @@ terminate (Process mstatus) = do status <- swapMVar mstatus NoRestart case status of- Running ph -> void $ liftIO $ SP.terminateProcess ph+ Running pid -> void $ liftIO $ killProcess pid _ -> return ()
Keter/Proxy.hs view
@@ -6,7 +6,8 @@ , HostList , reverseProxySsl , setDir- , SslConfig+ , TLSConfig+ , TLSConfigNoDir ) where import Keter.Prelude ((++))@@ -14,81 +15,43 @@ 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) type HostList = IO [ByteString] -reverseProxy :: ServerSettings -> PortLookup -> HostList -> IO ()+reverseProxy :: ServerSettings IO -> 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)- 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--getHeaders :: Monad m => Sink ByteString m ByteString-getHeaders =- go id+ -> Application IO+withClient portLookup hostList =+ rawProxyTo getDest 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'+ getDest headers = do+ mport <- maybe (return Nothing) portLookup $ lookup "host" headers+ case mport of+ Nothing -> Left . srcToApp . toResponse <$> hostList+ Just port -> return $ Right $ ProxyDest "127.0.0.1" port -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'+srcToApp :: Monad m => Source m ByteString -> Application m+srcToApp src appdata = src $$ appSink appdata -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>"
Keter/SSL.hs view
@@ -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
keter.cabal view
@@ -1,5 +1,5 @@ Name: keter-Version: 0.2.0.3+Version: 0.3.0 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme> Homepage: http://www.yesodweb.com/@@ -29,17 +29,16 @@ , template-haskell , blaze-builder >= 0.3 && < 0.4 , yaml >= 0.7 && < 0.9- , unix-compat >= 0.3 && < 0.4+ , unix-compat >= 0.3 && < 0.5 , hinotify >= 0.3 && < 0.4 , system-filepath >= 0.4 && < 0.5 , 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 >= 0.6 && < 0.7+ , network-conduit-tls >= 0.5 && < 0.6+ , http-reverse-proxy >= 0.1 && < 0.2+ , unix-process-conduit >= 0.1 && < 0.2+ , unix >= 2.5 && < 2.6 Exposed-Modules: Keter.Process Keter.Postgres Keter.TempFolder