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
|