From b0a09ca6269ccc9b15566f0fe54757f769dae6a4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 May 2012 11:19:03 +0300 Subject: [PATCH] Converted Keter.App --- Keter/App.hs | 163 ++++++++++++++++++++++------------------------- Keter/Main.hs | 17 ++--- Keter/Prelude.hs | 23 ++++++- 3 files changed, 108 insertions(+), 95 deletions(-) diff --git a/Keter/App.hs b/Keter/App.hs index 4e0b19d..b6d2972 100644 --- a/Keter/App.hs +++ b/Keter/App.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} module Keter.App ( App , start @@ -7,27 +8,21 @@ module Keter.App , Keter.App.terminate ) where +import Keter.Prelude import Keter.TempFolder import Keter.Postgres import Keter.Process import Keter.Nginx hiding (start) -import qualified Keter.Prelude import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (decompress) import qualified Filesystem.Path.CurrentOS as F import Data.Yaml import Control.Applicative ((<$>), (<*>)) import System.PosixCompat.Files -import qualified Control.Concurrent.Chan as C -import Control.Concurrent (forkIO, threadDelay) -import System.Timeout (timeout) import qualified Network import Data.Maybe (fromMaybe) -import Control.Exception (try, SomeException, onException, throwIO) +import Control.Exception (onException) import System.IO (hClose) -import System.Directory (removeDirectoryRecursive) -import Control.Monad (when) -import Data.Text (Text, pack) data Config = Config { configExec :: F.FilePath @@ -45,57 +40,53 @@ instance FromJSON Config where parseJSON _ = fail "Wanted an object" data Command = Reload | Terminate -newtype App = App (Command -> IO ()) - -tryM :: IO a -> IO (Maybe a) -tryM f = do - res <- try f - case res of - Left (e :: SomeException) -> do - putStrLn $ "Exception received: " ++ show e - return Nothing - Right x -> return $ Just x +newtype App = App (Command -> KIO ()) unpackBundle :: TempFolder -> F.FilePath -> Appname - -> IO (Maybe (FilePath, Config)) -unpackBundle tf bundle appname = tryM $ do - elbs <- runKIO $ Keter.Prelude.readFileLBS bundle - lbs <- either throwIO return elbs - edir <- runKIO $ getFolder tf appname - dir <- either throwIO return edir - putStrLn $ "Unpacking bundle to: " ++ show dir - let rest = do - Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs - let configFP = dir F. "config" F. "keter.yaml" - Just config <- decodeFile $ F.encodeString configFP - return (F.encodeString dir, config) - rest `onException` Keter.Prelude.removeTree dir + -> KIO (Either SomeException (FilePath, Config)) +unpackBundle tf bundle appname = do + elbs <- readFileLBS bundle + case elbs of + Left e -> return $ Left e + Right lbs -> do + edir <- getFolder tf appname + case edir of + Left e -> return $ Left e + Right dir -> do + log $ UnpackingBundle bundle dir + let rest = do + Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs + let configFP = dir F. "config" F. "keter.yaml" + Just config <- decodeFile $ F.encodeString configFP + return (dir, config) + liftIO $ rest `onException` removeTree dir start :: TempFolder -> Nginx -> Postgres -> Appname -> F.FilePath -- ^ app bundle - -> IO () -- ^ action to perform to remove this App from list of actives - -> IO (App, IO ()) + -> KIO () -- ^ action to perform to remove this App from list of actives + -> KIO (App, KIO ()) start tf nginx postgres appname bundle removeFromList = do - chan <- C.newChan - return (App $ C.writeChan chan, rest chan) + chan <- newChan + return (App $ writeChan chan, rest chan) where - void f = f >> return () - runApp port dir config = do - setFileMode (F.encodeString $ F.decodeString dir F. "config" F. configExec config) ownerExecuteMode + res1 <- liftIO $ setFileMode (toString $ dir "config" configExec config) ownerExecuteMode + case res1 of + Left e -> log $ ExceptionThrown e + Right () -> return () otherEnv <- do mdbi <- if configPostgres config then do - edbi <- Keter.Prelude.runKIO print $ getInfo postgres appname + edbi <- getInfo postgres appname case edbi of Left e -> do - Keter.Prelude.runKIO print $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e + log $ ExceptionThrown e return Nothing Right dbi -> return $ Just dbi else return Nothing @@ -108,103 +99,103 @@ start tf nginx postgres appname bundle removeFromList = do , ("PGDATABASE", dbiName dbi) ] Nothing -> [] - runKIO $ run - ("config" F. configExec config) - (F.decodeString dir) + run + ("config" configExec config) + dir (configArgs config) - $ ("PORT", pack $ show port) - : ("APPROOT", pack $ "http://" ++ configHost config) + $ ("PORT", show port) + : ("APPROOT", "http://" ++ configHost config) : otherEnv - rest chan = void $ forkIO $ do + rest chan = forkKIO $ do mres <- unpackBundle tf bundle appname case mres of - Nothing -> removeFromList - Just (dir, config) -> do - eport <- runKIO $ getPort nginx + Left e -> do + log $ ExceptionThrown e + removeFromList + Right (dir, config) -> do + eport <- getPort nginx case eport of Left e -> do - runKIO $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e + log $ ExceptionThrown e removeFromList Right port -> do process <- runApp port dir config b <- testApp port if b then do - runKIO $ addEntry nginx (pack $ configHost config) $ AppEntry port + addEntry nginx (configHost config) $ AppEntry port loop chan dir process port config else do removeFromList - runKIO $ releasePort nginx port - runKIO $ Keter.Process.terminate process + releasePort nginx port + Keter.Process.terminate process loop chan dirOld processOld portOld configOld = do - command <- C.readChan chan + command <- readChan chan case command of Terminate -> do removeFromList - runKIO $ removeEntry nginx $ pack $ configHost configOld - putStrLn $ "Received terminate signal for app: " ++ show appname + removeEntry nginx $ configHost configOld + log $ TerminatingApp appname terminateOld Reload -> do mres <- unpackBundle tf bundle appname case mres of - Nothing -> do - runKIO $ Keter.Prelude.log $ Keter.Prelude.InvalidBundle bundle + Left e -> do + log $ InvalidBundle bundle e loop chan dirOld processOld portOld configOld - Just (dir, config) -> do - eport <- runKIO $ getPort nginx + Right (dir, config) -> do + eport <- getPort nginx case eport of - Left e -> runKIO $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e + Left e -> log $ ExceptionThrown e Right port -> do process <- runApp port dir config b <- testApp port if b then do - runKIO $ addEntry nginx (pack $ configHost config) $ AppEntry port + addEntry nginx (configHost config) $ AppEntry port when (configHost config /= configHost configOld) $ - runKIO $ removeEntry nginx $ pack $ configHost configOld - putStrLn $ "Finished reloading: " ++ show appname + removeEntry nginx $ configHost configOld + log $ FinishedReloading appname terminateOld loop chan dir process port config else do - runKIO $ do - releasePort nginx port - Keter.Process.terminate process - Keter.Prelude.log $ Keter.Prelude.ProcessDidNotStart bundle + releasePort nginx port + Keter.Process.terminate process + log $ ProcessDidNotStart bundle loop chan dirOld processOld portOld configOld where - terminateOld = void $ forkIO $ do + terminateOld = forkKIO $ do threadDelay $ 20 * 1000 * 1000 - putStrLn $ "Terminating old process for: " ++ show appname - runKIO $ Keter.Process.terminate processOld + log $ TerminatingOldProcess appname + Keter.Process.terminate processOld threadDelay $ 60 * 1000 * 1000 - putStrLn $ "Removing folder: " ++ dirOld - removeDirectoryRecursive dirOld + log $ RemovingOldFolder dirOld + res <- liftIO $ removeTree dirOld + case res of + Left e -> log $ ExceptionThrown e + Right () -> return () -runKIO :: Keter.Prelude.KIO a -> IO a -- FIXME remove this -runKIO = Keter.Prelude.runKIO print - -testApp :: Port -> IO Bool +testApp :: Port -> KIO Bool testApp port = do - putStrLn $ "Testing app on port: " ++ show port res <- timeout (90 * 1000 * 1000) testApp' return $ fromMaybe False res where testApp' = do threadDelay $ 2 * 1000 * 1000 - eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port + eres <- liftIO $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port case eres of - Left (e :: SomeException) -> do - putStrLn $ "Connection failed: " ++ show e - testApp' + Left _ -> testApp' Right handle -> do - putStrLn $ "App is running on port: " ++ show port - hClose handle + res <- liftIO $ hClose handle + case res of + Left e -> log $ ExceptionThrown e + Right () -> return () return True -reload :: App -> IO () +reload :: App -> KIO () reload (App f) = f Reload -terminate :: App -> IO () +terminate :: App -> KIO () terminate (App f) = f Terminate diff --git a/Keter/Main.hs b/Keter/Main.hs index 5186bba..a87f1a5 100644 --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -25,24 +25,25 @@ import Control.Exception (throwIO) keter :: FilePath -- ^ root directory, with incoming, temp, and etc folders -> IO () keter dir = do - enginx <- Keter.Prelude.runKIO print $ Nginx.start def + let runKIO = Keter.Prelude.runKIO print + enginx <- runKIO $ Nginx.start def nginx <- either throwIO return enginx - etf <- Keter.Prelude.runKIO print $ TempFolder.setup $ F.decodeString dir F. "temp" + etf <- runKIO $ TempFolder.setup $ F.decodeString dir F. "temp" tf <- either throwIO return etf - epostgres <- Keter.Prelude.runKIO print $ Postgres.load def $ F.decodeString $ dir "etc" "postgres.yaml" + epostgres <- runKIO $ Postgres.load def $ F.decodeString $ dir "etc" "postgres.yaml" postgres <- either throwIO return epostgres mappMap <- M.newMVar Map.empty - let removeApp appname = M.modifyMVar_ mappMap $ return . Map.delete appname + let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname addApp bundle = do let appname = getAppname bundle rest <- M.modifyMVar mappMap $ \appMap -> case Map.lookup appname appMap of Just app -> do - App.reload app + runKIO $ App.reload app return (appMap, return ()) Nothing -> do - (app, rest) <- App.start + (app, rest) <- runKIO $ App.start tf nginx postgres @@ -51,12 +52,12 @@ keter dir = do (removeApp appname) let appMap' = Map.insert appname app appMap return (appMap', rest) - rest + runKIO rest terminateApp appname = do appMap <- M.readMVar mappMap case Map.lookup appname appMap of Nothing -> return () - Just app -> App.terminate app + Just app -> runKIO $ App.terminate app let incoming = dir "incoming" let hidden ('.':_) = True diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs index 054510a..f75213d 100644 --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -37,6 +37,8 @@ module Keter.Prelude , Default (..) , P.Int , (P.==) + , (P./=) + , (P.*) , P.fromIntegral , P.reverse , P.otherwise @@ -50,11 +52,14 @@ module Keter.Prelude , F.createTree , F.directory , F.rename + , timeout + , threadDelay -- * MVar , M.MVar , newMVar , newEmptyMVar , modifyMVar + , modifyMVar_ , swapMVar , takeMVar , putMVar @@ -81,6 +86,7 @@ import qualified Control.Monad import qualified Control.Applicative import qualified Control.Concurrent.MVar as M import Control.Concurrent (forkIO) +import qualified Control.Concurrent import qualified Data.IORef as I import Data.Monoid (Monoid, mappend) import qualified Data.Text.Lazy.Builder as B @@ -91,6 +97,7 @@ import Data.Default (Default (..)) import System.Exit (ExitCode) import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char.Utf8 +import qualified System.Timeout type String = T.Text @@ -121,10 +128,15 @@ void f = f P.>> P.return () data LogMessage = ProcessCreated F.FilePath - | InvalidBundle F.FilePath + | InvalidBundle F.FilePath E.SomeException | ProcessDidNotStart F.FilePath | ExceptionThrown E.SomeException | RemovingPort P.Int + | UnpackingBundle F.FilePath F.FilePath + | TerminatingApp T.Text + | FinishedReloading T.Text + | TerminatingOldProcess T.Text + | RemovingOldFolder F.FilePath deriving P.Show class ToString a where @@ -158,6 +170,9 @@ newEmptyMVar = liftIO_ M.newEmptyMVar modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x) +modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO () +modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x) + swapMVar :: M.MVar a -> a -> KIO a swapMVar m = liftIO_ . M.swapMVar m @@ -212,3 +227,9 @@ readChan = liftIO_ . C.readChan writeChan :: C.Chan a -> a -> KIO () writeChan c = liftIO_ . C.writeChan c + +timeout :: P.Int -> KIO a -> KIO (P.Maybe a) +timeout seconds (KIO f) = KIO $ \x -> System.Timeout.timeout seconds $ f x + +threadDelay :: P.Int -> KIO () +threadDelay = liftIO_ . Control.Concurrent.threadDelay