From 3054f5f81d54f52a0011f93ffe3a9026651881d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 May 2012 07:38:05 +0300 Subject: [PATCH] Keter.App --- .gitignore | 6 ++ Keter/App.hs | 171 +++++++++++++++++++++++++++++++++ Keter/Nginx.hs | 24 +++-- Keter/Process.hs | 1 + incoming/foo/bundle.sh | 4 + incoming/foo/config/keter.yaml | 4 + incoming/foo/hello.hs | 13 +++ keter.cabal | 4 + test/app.hs | 22 +++++ 9 files changed, 243 insertions(+), 6 deletions(-) create mode 100644 Keter/App.hs create mode 100755 incoming/foo/bundle.sh create mode 100644 incoming/foo/config/keter.yaml create mode 100644 incoming/foo/hello.hs create mode 100644 test/app.hs diff --git a/.gitignore b/.gitignore index 06747f3..a8e5092 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,9 @@ dist/ process.txt process2.txt postgres.yaml +*.o +*.hi +temp/ +*.keter +test/app +incoming/foo/hello diff --git a/Keter/App.hs b/Keter/App.hs new file mode 100644 index 0000000..58213b2 --- /dev/null +++ b/Keter/App.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Keter.App + ( App + , start + , reload + , Keter.App.terminate + ) where + +import Keter.TempFolder +import Keter.Postgres +import Keter.Process +import Keter.Nginx hiding (start) +import qualified Codec.Archive.Tar as Tar +import qualified Data.ByteString.Lazy as L +import Codec.Compression.GZip (decompress) +import qualified System.FilePath as F +import Data.Text (pack) +import Data.Yaml +import Control.Applicative ((<$>), (<*>)) +import qualified Data.IORef as I +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) +import System.IO (hClose) +import System.Directory (removeDirectoryRecursive) +import Control.Monad (when) + +data Config = Config + { configExec :: FilePath + , configArgs :: [String] + , configHost :: String + } + +instance FromJSON Config where + parseJSON (Object o) = Config + <$> o .: "exec" + <*> o .:? "args" .!= [] + <*> o .: "host" + 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 + +unpackBundle :: TempFolder + -> FilePath + -> Appname + -> IO (Maybe (FilePath, Config)) +unpackBundle tf bundle appname = tryM $ do + lbs <- L.readFile bundle + dir <- getFolder tf appname + putStrLn $ "Unpacking bundle to: " ++ dir + let rest = do + Tar.unpack dir $ Tar.read $ decompress lbs + let configFP = dir F. "config" F. "keter.yaml" + Just config <- decodeFile configFP + return (dir, config) + rest `onException` removeDirectoryRecursive dir + +start :: TempFolder + -> Nginx + -> FilePath -- ^ app bundle + -> IO () -- ^ action to perform to remove this App from list of actives + -> IO (App, IO ()) +start tf nginx bundle removeFromList = do + chan <- C.newChan + return (App $ C.writeChan chan, rest chan) + where + appname = pack $ F.takeBaseName bundle + void f = f >> return () + + runApp port dir config = do + setFileMode (dir F. "config" F. configExec config) ownerExecuteMode + run + ("config" F. configExec config) + dir + (configArgs config) + [ ("PORT", show port) + ] + + rest chan = void $ forkIO $ do + mres <- unpackBundle tf bundle appname + case mres of + Nothing -> removeFromList + Just (dir, config) -> do + port <- getPort nginx + process <- runApp port dir config + b <- testApp port + if b + then do + addEntry nginx (configHost config) $ AppEntry port + loop chan dir process port config + else do + removeFromList + releasePort nginx port + Keter.Process.terminate process + + loop chan dirOld processOld portOld configOld = do + command <- C.readChan chan + case command of + Terminate -> do + removeFromList + removeEntry nginx $ configHost configOld + terminateOld + Reload -> do + mres <- unpackBundle tf bundle appname + case mres of + Nothing -> do + putStrLn $ "Invalid bundle: " ++ bundle + loop chan dirOld processOld portOld configOld + Just (dir, config) -> do + port <- getPort nginx + process <- runApp port dir config + b <- testApp port + if b + then do + addEntry nginx (configHost config) $ AppEntry port + when (configHost config /= configHost configOld) $ + removeEntry nginx $ configHost configOld + terminateOld + loop chan dir process port config + else do + releasePort nginx port + Keter.Process.terminate process + putStrLn $ "Processing didn't start correctly: " ++ 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 + threadDelay $ 60 * 1000 * 1000 + putStrLn $ "Removing folder: " ++ dirOld + removeDirectoryRecursive dirOld + +testApp :: Port -> IO 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 + case eres of + Left (e :: SomeException) -> do + putStrLn $ "Connection failed: " ++ show e + testApp' + Right handle -> do + putStrLn $ "App is running on port: " ++ show port + hClose handle + return True + +reload :: App -> IO () +reload (App f) = f Reload + +terminate :: App -> IO () +terminate (App f) = f Terminate diff --git a/Keter/Nginx.hs b/Keter/Nginx.hs index 3c9337a..e9908da 100644 --- a/Keter/Nginx.hs +++ b/Keter/Nginx.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Keter.Nginx ( -- * Types Port @@ -36,6 +37,8 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow) import Data.Monoid (Monoid, mappend, mconcat) import Data.ByteString.Char8 () import System.Directory (renameFile) +import qualified Network +import Control.Exception (SomeException, try) (<>) :: Monoid m => m -> m -> m (<>) = mappend @@ -90,15 +93,24 @@ start Settings{..} = do command <- lift $ C.readChan chan case command of GetPort f -> do - ns <- S.get - let (port, ns') = + ns0 <- S.get + let loop ns = case nsAvail ns of - p:ps -> (p, ns { nsAvail = ps }) + p:ps -> do + res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p + case res of + Left (_ :: SomeException) -> do + putStrLn $ "Removing port from use: " ++ show p + loop ns { nsAvail = ps } + Right socket -> do + Network.sClose socket + return (p, ns { nsAvail = ps }) [] -> case reverse $ nsRecycled ns of - [] -> (error "No ports available", ns) - p:ps -> (p, ns { nsAvail = ps, nsRecycled = [] }) - S.put ns' + [] -> return (error "No ports available", ns) + ps -> loop ns { nsAvail = ps, nsRecycled = [] } + (port, ns) <- lift $ loop ns0 + S.put ns lift $ f port ReleasePort p -> S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns } diff --git a/Keter/Process.hs b/Keter/Process.hs index ff1aa64..2ff2159 100644 --- a/Keter/Process.hs +++ b/Keter/Process.hs @@ -24,6 +24,7 @@ run exec dir args env = do NoRestart -> return (NoRestart, return ()) _ -> do (_, _, _, ph) <- SP.createProcess cp + putStrLn "Process created" return (Running ph, SP.waitForProcess ph >> loop) next _ <- forkIO loop diff --git a/incoming/foo/bundle.sh b/incoming/foo/bundle.sh new file mode 100755 index 0000000..039e5ed --- /dev/null +++ b/incoming/foo/bundle.sh @@ -0,0 +1,4 @@ +#!/bin/bash -ex + +ghc --make hello.hs +tar czfv ../foo.keter * diff --git a/incoming/foo/config/keter.yaml b/incoming/foo/config/keter.yaml new file mode 100644 index 0000000..b3015cb --- /dev/null +++ b/incoming/foo/config/keter.yaml @@ -0,0 +1,4 @@ +exec: ../hello +args: + - Hello World 1 +host: tealc-mint diff --git a/incoming/foo/hello.hs b/incoming/foo/hello.hs new file mode 100644 index 0000000..2ad97a0 --- /dev/null +++ b/incoming/foo/hello.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +import System.Environment +import qualified Data.ByteString.Lazy.Char8 as L8 +import Network.Wai +import Network.Wai.Handler.Warp +import Network.HTTP.Types + +main :: IO () +main = do + [msg] <- getArgs + portS <- getEnv "PORT" + let port = read portS + run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack msg diff --git a/keter.cabal b/keter.cabal index ebed241..5f63431 100644 --- a/keter.cabal +++ b/keter.cabal @@ -21,12 +21,16 @@ Library , process , random , data-default + , filepath + , zlib + , tar , blaze-builder >= 0.3 && < 0.4 , yaml >= 0.7 && < 0.8 Exposed-Modules: Keter.Nginx Keter.Process Keter.Postgres Keter.TempFolder + Keter.App ghc-options: -Wall -Werror Executable keter diff --git a/test/app.hs b/test/app.hs new file mode 100644 index 0000000..c28db99 --- /dev/null +++ b/test/app.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +import Keter.TempFolder +import Keter.App +import qualified Keter.Nginx as N +import Data.Default +import Control.Concurrent +import System.Directory (copyFile) + +main :: IO () +main = do + tf <- setup "temp" + nginx <- N.start def + copyFile "incoming/foo1.keter" "incoming/foo.keter" + (app, toRun) <- start tf nginx "incoming/foo.keter" $ putStrLn "It's dead Jim" + toRun + threadDelay $ 2 * 1000 * 1000 + copyFile "incoming/foo2.keter" "incoming/foo.keter" + reload app + threadDelay $ 2 * 1000 * 1000 + putStrLn "Terminating..." + terminate app + threadDelay $ 120 * 1000 * 1000