diff --git a/Keter/Logger.hs b/Keter/Logger.hs --- a/Keter/Logger.hs +++ b/Keter/Logger.hs @@ -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 () diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -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 diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -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 diff --git a/Keter/Process.hs b/Keter/Process.hs --- a/Keter/Process.hs +++ b/Keter/Process.hs @@ -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 () diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -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\nWelcome to Keter

Welcome to Keter

You may access the following sites:

" diff --git a/Keter/SSL.hs b/Keter/SSL.hs --- 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 diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: 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