keter/Keter/Main.hs

81 lines
3.0 KiB
Haskell
Raw Normal View History

2012-05-14 12:18:09 +04:00
{-# LANGUAGE OverloadedStrings #-}
2012-05-11 12:29:25 +04:00
module Keter.Main
( keter
) where
import qualified Keter.Nginx as Nginx
import qualified Keter.TempFolder as TempFolder
import qualified Keter.App as App
2012-05-11 12:42:56 +04:00
import qualified Keter.Postgres as Postgres
2012-05-14 12:18:09 +04:00
import qualified Keter.Prelude
2012-05-11 12:29:25 +04:00
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)
2012-05-14 11:15:50 +04:00
import qualified Filesystem.Path.CurrentOS as F
2012-05-14 12:18:09 +04:00
import Control.Exception (throwIO)
2012-05-11 12:29:25 +04:00
keter :: FilePath -- ^ root directory, with incoming, temp, and etc folders
-> IO ()
keter dir = do
nginx <- Nginx.start def
2012-05-14 12:18:09 +04:00
etf <- Keter.Prelude.runKIO print $ TempFolder.setup $ F.decodeString dir F.</> "temp"
tf <- either throwIO return etf
2012-05-14 13:26:20 +04:00
epostgres <- Keter.Prelude.runKIO print $ Postgres.load def $ F.decodeString $ dir </> "etc" </> "postgres.yaml"
postgres <- either throwIO return epostgres
2012-05-11 12:29:25 +04:00
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
2012-05-14 11:15:50 +04:00
(app, rest) <- App.start
tf
nginx
postgres
appname
(F.decodeString bundle)
(removeApp appname)
2012-05-11 12:29:25 +04:00
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