diff --git a/Keter/App.hs b/Keter/App.hs index 021a1dc..c492e24 100644 --- a/Keter/App.hs +++ b/Keter/App.hs @@ -15,7 +15,6 @@ 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 System.PosixCompat.Files @@ -71,14 +70,14 @@ unpackBundle tf bundle appname = tryM $ do start :: TempFolder -> Nginx + -> Appname -> FilePath -- ^ app bundle -> IO () -- ^ action to perform to remove this App from list of actives -> IO (App, IO ()) -start tf nginx bundle removeFromList = do +start tf nginx appname 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 @@ -113,6 +112,7 @@ start tf nginx bundle removeFromList = do Terminate -> do removeFromList removeEntry nginx $ configHost configOld + putStrLn $ "Received terminate signal for app: " ++ show appname terminateOld Reload -> do mres <- unpackBundle tf bundle appname @@ -129,6 +129,7 @@ start tf nginx bundle removeFromList = do addEntry nginx (configHost config) $ AppEntry port when (configHost config /= configHost configOld) $ removeEntry nginx $ configHost configOld + putStrLn $ "Finished reloading: " ++ show appname terminateOld loop chan dir process port config else do diff --git a/Keter/Main.hs b/Keter/Main.hs new file mode 100644 index 0000000..7c6ebf9 --- /dev/null +++ b/Keter/Main.hs @@ -0,0 +1,66 @@ +module Keter.Main + ( keter + ) where + +import qualified Keter.Nginx as Nginx +import qualified Keter.TempFolder as TempFolder +import qualified Keter.App as App + +import Data.Default (def) +import System.FilePath ((), takeBaseName) +import qualified Control.Concurrent.MVar as M +import qualified Data.Map as Map +import Data.Text (pack) +import System.Directory (getDirectoryContents) +import Control.Concurrent (threadDelay) +import qualified System.INotify as I +import Control.Monad (forever, when) +import Data.List (isSuffixOf) + +keter :: FilePath -- ^ root directory, with incoming, temp, and etc folders + -> IO () +keter dir = do + nginx <- Nginx.start def + tf <- TempFolder.setup $ dir "temp" + + mappMap <- M.newMVar Map.empty + let removeApp appname = M.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 + return (appMap, return ()) + Nothing -> do + (app, rest) <- App.start tf nginx appname bundle $ removeApp appname + let appMap' = Map.insert appname app appMap + return (appMap', rest) + rest + terminateApp appname = do + appMap <- M.readMVar mappMap + case Map.lookup appname appMap of + Nothing -> return () + Just app -> App.terminate app + + let incoming = dir "incoming" + let hidden ('.':_) = True + hidden _ = False + isKeter = isSuffixOf ".keter" + bundles <- fmap (map (incoming ) . filter isKeter . filter (not . hidden)) + $ getDirectoryContents incoming + mapM_ addApp bundles + + let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite] + i <- I.initINotify + _ <- I.addWatch i events incoming $ \e -> + case e of + I.Deleted _ fp -> when (isKeter fp) $ terminateApp $ getAppname fp + I.MovedOut _ fp _ -> when (isKeter fp) $ terminateApp $ getAppname fp + I.Closed _ (Just fp) _ -> when (isKeter fp) $ addApp $ incoming fp + I.MovedIn _ fp _ -> when (isKeter fp) $ addApp $ incoming fp + _ -> print e + + forever $ threadDelay $ 60 * 1000 * 1000 + where + getAppname = pack . takeBaseName diff --git a/Keter/Nginx.hs b/Keter/Nginx.hs index e9908da..3acb618 100644 --- a/Keter/Nginx.hs +++ b/Keter/Nginx.hs @@ -30,7 +30,7 @@ import Control.Concurrent (forkIO) import qualified Control.Monad.Trans.State as S import Control.Monad.Trans.Class (lift) import qualified Data.Map as Map -import Control.Monad (forever) +import Control.Monad (forever, unless) import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (copyByteString, toLazyByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow) @@ -39,6 +39,8 @@ import Data.ByteString.Char8 () import System.Directory (renameFile) import qualified Network import Control.Exception (SomeException, try) +import qualified Data.ByteString as S +import System.Exit (ExitCode (ExitSuccess)) (<>) :: Monoid m => m -> m -> m (<>) = mappend @@ -79,15 +81,25 @@ data Settings = Settings instance Default Settings where def = Settings { configFile = "/etc/nginx/sites-enabled/keter" - , reloadAction = rawSystem "/etc/init.d/nginx" ["reload"] >> return () - , startAction = rawSystem "/etc/init.d/nginx" ["start"] >> return () + , reloadAction = rawSystem' "/etc/init.d/nginx" ["reload"] + , startAction = rawSystem' "/etc/init.d/nginx" ["start"] , portRange = [4000..4999] } +rawSystem' :: FilePath -> [String] -> IO () +rawSystem' fp args = do + ec <- rawSystem fp args + unless (ec == ExitSuccess) $ error $ "Received exit failure when running: " ++ show (fp:args) + -- | Start running a separate thread which will accept commands and modify -- Nginx's behavior accordingly. start :: Settings -> IO Nginx start Settings{..} = do + -- Start off by ensuring we can read and write the config file and reload + config0 <- S.readFile configFile + S.writeFile configFile config0 + reloadAction + chan <- C.newChan _ <- forkIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do command <- lift $ C.readChan chan diff --git a/incoming/foo/hello.hs b/incoming/foo/hello.hs index 2ad97a0..389835e 100644 --- a/incoming/foo/hello.hs +++ b/incoming/foo/hello.hs @@ -4,10 +4,15 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import Network.Wai import Network.Wai.Handler.Warp import Network.HTTP.Types +import System.Directory main :: IO () main = do + fp <- canonicalizePath "." [msg] <- getArgs portS <- getEnv "PORT" let port = read portS - run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack msg + run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines + [ "Message: " ++ msg + , "Path: " ++ fp + ] diff --git a/keter.cabal b/keter.cabal index b389430..e37a4b0 100644 --- a/keter.cabal +++ b/keter.cabal @@ -28,17 +28,20 @@ Library , blaze-builder >= 0.3 && < 0.4 , yaml >= 0.7 && < 0.8 , unix-compat >= 0.3 && < 0.4 + , hinotify >= 0.3 && < 0.4 Exposed-Modules: Keter.Nginx Keter.Process Keter.Postgres Keter.TempFolder Keter.App + Keter.Main ghc-options: -Wall -Werror Executable keter Main-is: ../keter.hs hs-source-dirs: dist Build-depends: base, keter + ghc-options: -threaded -Wall -Werror source-repository head type: git diff --git a/keter.hs b/keter.hs index 0d9bb80..f5d1647 100644 --- a/keter.hs +++ b/keter.hs @@ -1,4 +1,11 @@ -import Keter.Nginx () +import System.Environment (getArgs, getProgName) +import Keter.Main (keter) main :: IO () -main = putStrLn "Nothing here yet" +main = do + args <- getArgs + case args of + [dir] -> keter dir + _ -> do + pn <- getProgName + error $ "Usage: " ++ pn ++ " "