mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-14 17:12:46 +03:00
113 lines
4.6 KiB
Haskell
113 lines
4.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
module Keter.Main
|
|
( keter
|
|
) where
|
|
|
|
import Keter.Prelude hiding (getCurrentTime)
|
|
import qualified Keter.Nginx as Nginx
|
|
import qualified Keter.TempFolder as TempFolder
|
|
import qualified Keter.App as App
|
|
import qualified Keter.Postgres as Postgres
|
|
import qualified Keter.LogFile as LogFile
|
|
import qualified Keter.Logger as Logger
|
|
|
|
import qualified Control.Concurrent.MVar as M
|
|
import qualified Data.Map as Map
|
|
import qualified System.INotify as I
|
|
import Control.Monad (forever)
|
|
import qualified Filesystem.Path.CurrentOS as F
|
|
import Control.Exception (throwIO)
|
|
import qualified Prelude as P
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Time (getCurrentTime)
|
|
import qualified Data.Text as T
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
keter :: P.FilePath -- ^ root directory, with incoming, temp, and etc folders
|
|
-> P.IO ()
|
|
keter dir' = do
|
|
nginx <- runThrow $ Nginx.start def
|
|
tf <- runThrow $ TempFolder.setup $ dir </> "temp"
|
|
postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"
|
|
mainlog <- runThrow $ LogFile.start $ dir </> "log" </> "keter"
|
|
|
|
let runKIO' = runKIO $ \ml -> do
|
|
now <- getCurrentTime
|
|
let bs = encodeUtf8 $ T.concat
|
|
[ T.take 22 $ show now
|
|
, ": "
|
|
, show ml
|
|
, "\n"
|
|
]
|
|
runKIOPrint $ LogFile.addChunk mainlog bs
|
|
runKIOPrint = runKIO P.print
|
|
|
|
mappMap <- M.newMVar Map.empty
|
|
let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname
|
|
addApp bundle = do
|
|
let appname = getAppname bundle
|
|
rest <- modifyMVar mappMap $ \appMap ->
|
|
case Map.lookup appname appMap of
|
|
Just app -> do
|
|
App.reload app
|
|
return (appMap, return ())
|
|
Nothing -> do
|
|
mlogger <- do
|
|
let dirout = dir </> "log" </> fromText ("app-" ++ appname)
|
|
direrr = dirout </> "err"
|
|
elfout <- LogFile.start dirout
|
|
case elfout of
|
|
Left e -> do
|
|
$logEx e
|
|
return Nothing
|
|
Right lfout -> do
|
|
elferr <- LogFile.start direrr
|
|
case elferr of
|
|
Left e -> do
|
|
$logEx e
|
|
LogFile.close lfout
|
|
return Nothing
|
|
Right lferr -> fmap Just $ Logger.start lfout lferr
|
|
let logger = fromMaybe Logger.dummy mlogger
|
|
(app, rest) <- App.start
|
|
tf
|
|
nginx
|
|
postgres
|
|
logger
|
|
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 -> runKIO' $ App.terminate app
|
|
|
|
let incoming = dir </> "incoming"
|
|
isKeter fp = hasExtension fp "keter"
|
|
isKeter' = isKeter . F.decodeString
|
|
bundles <- fmap (filter isKeter) $ listDirectory incoming
|
|
runKIO' $ mapM_ addApp bundles
|
|
|
|
let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite]
|
|
i <- I.initINotify
|
|
_ <- I.addWatch i events (toString incoming) $ \e -> do
|
|
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) $ runKIO' $ addApp $ incoming </> F.decodeString fp
|
|
I.MovedIn _ fp _ -> when (isKeter' fp) $ runKIO' $ addApp $ incoming </> F.decodeString fp
|
|
_ -> runKIO' $ log $ ReceivedInotifyEvent $ show e
|
|
|
|
runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000
|
|
where
|
|
getAppname = either id id . toText . basename
|
|
getAppname' = getAppname . F.decodeString
|
|
runThrow f = runKIO P.print f >>= either throwIO return
|
|
dir = F.decodeString dir'
|