From 3a3edc943105aad55e643e300c1116c71d320a2a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 May 2012 11:03:57 +0300 Subject: [PATCH] KIO --- Keter/App.hs | 20 +++++++------ Keter/Prelude.hs | 74 ++++++++++++++++++++++++++++++++++++++++++++---- Keter/Process.hs | 29 ++++++++++--------- 3 files changed, 96 insertions(+), 27 deletions(-) diff --git a/Keter/App.hs b/Keter/App.hs index 4b43414..0bda135 100644 --- a/Keter/App.hs +++ b/Keter/App.hs @@ -23,7 +23,7 @@ import Control.Concurrent (forkIO, threadDelay) import System.Timeout (timeout) import qualified Network import Data.Maybe (fromMaybe) -import Control.Exception (try, SomeException, onException) +import Control.Exception (try, SomeException, onException, throwIO) import System.IO (hClose) import System.Directory (removeDirectoryRecursive) import Control.Monad (when) @@ -61,7 +61,8 @@ unpackBundle :: TempFolder -> Appname -> IO (Maybe (FilePath, Config)) unpackBundle tf bundle appname = tryM $ do - lbs <- Keter.Prelude.readFileLBS bundle + elbs <- runKIO $ Keter.Prelude.readFileLBS bundle + lbs <- either throwIO return elbs dir <- getFolder tf appname putStrLn $ "Unpacking bundle to: " ++ dir let rest = do @@ -98,7 +99,7 @@ start tf nginx postgres appname bundle removeFromList = do , ("PGDATABASE", dbiName dbi) ] else return [] - run + runKIO $ run ("config" F. configExec config) (F.decodeString dir) (configArgs config) @@ -121,7 +122,7 @@ start tf nginx postgres appname bundle removeFromList = do else do removeFromList releasePort nginx port - Keter.Process.terminate process + runKIO $ Keter.Process.terminate process loop chan dirOld processOld portOld configOld = do command <- C.readChan chan @@ -135,7 +136,7 @@ start tf nginx postgres appname bundle removeFromList = do mres <- unpackBundle tf bundle appname case mres of Nothing -> do - Keter.Prelude.log $ Keter.Prelude.InvalidBundle bundle + runKIO $ Keter.Prelude.log $ Keter.Prelude.InvalidBundle bundle loop chan dirOld processOld portOld configOld Just (dir, config) -> do port <- getPort nginx @@ -151,18 +152,21 @@ start tf nginx postgres appname bundle removeFromList = do loop chan dir process port config else do releasePort nginx port - Keter.Process.terminate process - Keter.Prelude.log $ Keter.Prelude.ProcessDidNotStart bundle + runKIO $ Keter.Process.terminate process + runKIO $ Keter.Prelude.log $ Keter.Prelude.ProcessDidNotStart bundle loop chan dirOld processOld portOld configOld where terminateOld = void $ forkIO $ do threadDelay $ 20 * 1000 * 1000 putStrLn $ "Terminating old process for: " ++ show appname - Keter.Process.terminate processOld + runKIO $ Keter.Process.terminate processOld threadDelay $ 60 * 1000 * 1000 putStrLn $ "Removing folder: " ++ dirOld removeDirectoryRecursive dirOld +runKIO :: Keter.Prelude.KIO a -> IO a -- FIXME remove this +runKIO = Keter.Prelude.runKIO print + testApp :: Port -> IO Bool testApp port = do putStrLn $ "Testing app on port: " ++ show port diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs index 01d39f8..811e444 100644 --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -11,11 +11,22 @@ module Keter.Prelude , (P..) , LogMessage (..) , log - , IO + , KIO , toString , P.map , (A.***) , readFileLBS + , P.Either (..) + , E.SomeException + , runKIO + , void + , liftIO + , forkKIO + -- * MVar + , M.MVar + , newMVar + , modifyMVar + , swapMVar ) where import qualified Filesystem.Path.CurrentOS as F @@ -23,17 +34,45 @@ import qualified Data.Text as T import qualified Prelude as P import qualified Control.Arrow as A import qualified Data.ByteString.Lazy as L +import Prelude (($), (.)) +import qualified Control.Exception as E +import qualified Control.Monad +import qualified Control.Applicative +import qualified Control.Concurrent.MVar as M +import Control.Concurrent (forkIO) type String = T.Text -type IO = P.IO -- FIXME -log :: LogMessage -> IO () -log = P.print +newtype KIO a = KIO { unKIO :: (LogMessage -> P.IO ()) -> P.IO a } + +instance P.Monad KIO where + return = KIO . P.const . P.return + KIO x >>= y = KIO $ \f -> do + x' <- x f + let KIO mz = y x' + mz f + +instance P.Functor KIO where + fmap = Control.Monad.liftM +instance Control.Applicative.Applicative KIO where + (<*>) = Control.Monad.ap + pure = P.return + +log :: LogMessage -> KIO () +log msg = do + f <- getLogger + void $ liftIO $ f msg + where + getLogger = KIO P.return + +void :: P.Monad m => m a -> m () +void f = f P.>> P.return () data LogMessage = ProcessCreated F.FilePath | InvalidBundle F.FilePath | ProcessDidNotStart F.FilePath + | ExceptionThrown E.SomeException deriving P.Show class ToString a where @@ -46,5 +85,28 @@ instance ToString T.Text where instance ToString F.FilePath where toString = F.encodeString -readFileLBS :: F.FilePath -> IO L.ByteString -readFileLBS = L.readFile P.. toString +readFileLBS :: F.FilePath -> KIO (P.Either E.SomeException L.ByteString) +readFileLBS = liftIO . L.readFile P.. toString + +liftIO :: P.IO a -> KIO (P.Either E.SomeException a) +liftIO = KIO . P.const . E.try + +liftIO_ :: P.IO a -> KIO a +liftIO_ = KIO . P.const + +runKIO :: (LogMessage -> P.IO ()) -> KIO a -> P.IO a +runKIO f (KIO g) = g f + +newMVar :: a -> KIO (M.MVar a) +newMVar = liftIO_ . M.newMVar + +modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b +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 + +forkKIO :: KIO () -> KIO () +forkKIO f = do + x <- KIO P.return + void $ liftIO $ forkIO $ unKIO f x diff --git a/Keter/Process.hs b/Keter/Process.hs index 1e845be..c1438d5 100644 --- a/Keter/Process.hs +++ b/Keter/Process.hs @@ -7,8 +7,6 @@ module Keter.Process import Keter.Prelude import qualified System.Process as SP -import Control.Concurrent (forkIO) -import qualified Control.Concurrent.MVar as M data Status = NeedsRestart | NoRestart | Running SP.ProcessHandle @@ -17,22 +15,27 @@ run :: FilePath -- ^ executable -> FilePath -- ^ working directory -> [String] -- ^ command line parameter -> [(String, String)] -- ^ environment - -> IO Process + -> KIO Process run exec dir args env = do - mstatus <- M.newMVar NeedsRestart + mstatus <- newMVar NeedsRestart let loop = do - next <- M.modifyMVar mstatus $ \status -> + next <- modifyMVar mstatus $ \status -> case status of NoRestart -> return (NoRestart, return ()) _ -> do -- FIXME put in some kind of rate limiting: if we last -- tried to restart within five second, wait an extra -- five seconds - (_, _, _, ph) <- SP.createProcess cp - log $ ProcessCreated exec - return (Running ph, SP.waitForProcess ph >> loop) + res <- liftIO $ SP.createProcess cp + case res of + Left e -> do + log $ ExceptionThrown e + return (NeedsRestart, return ()) + Right (_, _, _, ph) -> do + log $ ProcessCreated exec + return (Running ph, liftIO (SP.waitForProcess ph) >> loop) next - _ <- forkIO loop + forkKIO loop return $ Process mstatus where cp = (SP.proc (toString exec) $ map toString args) @@ -45,12 +48,12 @@ run exec dir args env = do } -- | Abstract type containing information on a process which will be restarted. -newtype Process = Process (M.MVar Status) +newtype Process = Process (MVar Status) -- | Terminate the process and prevent it from being restarted. -terminate :: Process -> IO () +terminate :: Process -> KIO () terminate (Process mstatus) = do - status <- M.swapMVar mstatus NoRestart + status <- swapMVar mstatus NoRestart case status of - Running ph -> SP.terminateProcess ph + Running ph -> void $ liftIO $ SP.terminateProcess ph _ -> return ()