mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-15 09:33:06 +03:00
KIO
This commit is contained in:
Michael Snoyman
parent
3837c68c44
commit
3a3edc9431
20
Keter/App.hs
20
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user