{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ImplicitParams #-}
module Monitor.Entry where

import GHC.Conc (labelThread, atomically)

import System.FilePath
import System.FSNotify

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM.TVar

import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM

import Monitor.Configuration.Options (Options(..))
import Monitor.Configuration.Config
import Monitor.Configuration.Read
import Monitor.Queue
import Monitor.DataModel

watchTower :: (?mutex :: Mutexes)
           => MVar () -> FilePath -> String -> Settings
           -> TVar (HashMap FilePath (MVar ())) -> Event -> IO ()
watchTower :: MVar ()
-> FilePath
-> FilePath
-> Settings
-> TVar (HashMap FilePath (MVar ()))
-> Event
-> IO ()
watchTower MVar ()
monitorHolder FilePath
dir FilePath
tgvar Settings
cfg TVar (HashMap FilePath (MVar ()))
locksTVar Event
event = do
  let path :: FilePath
path = Event -> FilePath
eventPath Event
event
      filename :: FilePath
filename = FilePath -> FilePath
takeFileName FilePath
path
  if FilePath -> Bool
isCheck FilePath
filename
    then do
      FilePath -> IO (Async ()) -> IO ()
label FilePath
path (IO (Async ()) -> IO ())
-> (Monitor () -> IO (Async ())) -> Monitor () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async
                 (IO () -> IO (Async ()))
-> (Monitor () -> IO ()) -> Monitor () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Settings IO () -> Settings -> IO ())
-> Settings -> ReaderT Settings IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Settings IO () -> Settings -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Settings
cfg
                 (ReaderT Settings IO () -> IO ())
-> (Monitor () -> ReaderT Settings IO ()) -> Monitor () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Monitor () -> ReaderT Settings IO ()
forall a. Monitor a -> ReaderT Settings IO a
getMonitor (Monitor () -> IO ()) -> Monitor () -> IO ()
forall a b. (a -> b) -> a -> b
$
        case Event
event of
          Modified FilePath
_ UTCTime
_ Bool
False -> (?mutex::Mutexes) => FilePath -> Monitor ()
FilePath -> Monitor ()
restartJob FilePath
path
          Removed FilePath
_ UTCTime
_ Bool
False -> (?mutex::Mutexes) => FilePath -> Monitor ()
FilePath -> Monitor ()
removeJob FilePath
path
          Added FilePath
_ UTCTime
_ Bool
False -> (?mutex::Mutexes) => FilePath -> Monitor ()
FilePath -> Monitor ()
startJob FilePath
path
          Event
_ -> () -> Monitor ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
representsConfigName FilePath
filename) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
monitorHolder ()
      (ReaderT Settings IO () -> Settings -> IO ())
-> Settings -> ReaderT Settings IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Settings IO () -> Settings -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Settings
cfg (ReaderT Settings IO () -> IO ())
-> (Monitor () -> ReaderT Settings IO ()) -> Monitor () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Monitor () -> ReaderT Settings IO ()
forall a. Monitor a -> ReaderT Settings IO a
getMonitor (Monitor () -> IO ()) -> Monitor () -> IO ()
forall a b. (a -> b) -> a -> b
$ Monitor ()
destroyQueue
      FilePath -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
FilePath -> m ()
logMessage (FilePath
"Monitor at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
dir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is stopped due to configuration change. All jobs are removed, monitor will be restarted.")
      (?mutex::Mutexes) =>
FilePath -> FilePath -> TVar (HashMap FilePath (MVar ())) -> IO ()
FilePath -> FilePath -> TVar (HashMap FilePath (MVar ())) -> IO ()
trackDatabase FilePath
tgvar FilePath
dir TVar (HashMap FilePath (MVar ()))
locksTVar

trackDatabase :: (?mutex :: Mutexes) => String -> FilePath
              -> TVar (HashMap FilePath (MVar ())) -> IO ()
trackDatabase :: FilePath -> FilePath -> TVar (HashMap FilePath (MVar ())) -> IO ()
trackDatabase FilePath
tgvar FilePath
dbDir TVar (HashMap FilePath (MVar ()))
locksTVar = do
  (Settings
cfg, [FilePath]
checks) <- (?mutex::Mutexes) =>
FilePath -> FilePath -> IO (Settings, [FilePath])
FilePath -> FilePath -> IO (Settings, [FilePath])
readMonitor FilePath
dbDir FilePath
tgvar
  FilePath -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
FilePath -> m ()
logMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Monitor at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
dbDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is started."
  (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \WatchManager
monitorManager -> do
      MVar ()
lock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap FilePath (MVar ()))
-> (HashMap FilePath (MVar ()) -> HashMap FilePath (MVar ()))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap FilePath (MVar ()))
locksTVar (FilePath
-> MVar ()
-> HashMap FilePath (MVar ())
-> HashMap FilePath (MVar ())
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert FilePath
dbDir MVar ()
lock)
      IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchManager
-> FilePath -> ActionPredicate -> (Event -> IO ()) -> IO (IO ())
watchTree WatchManager
monitorManager FilePath
dbDir (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True)
             ((?mutex::Mutexes) =>
MVar ()
-> FilePath
-> FilePath
-> Settings
-> TVar (HashMap FilePath (MVar ()))
-> Event
-> IO ()
MVar ()
-> FilePath
-> FilePath
-> Settings
-> TVar (HashMap FilePath (MVar ()))
-> Event
-> IO ()
watchTower MVar ()
lock FilePath
dbDir FilePath
tgvar Settings
cfg TVar (HashMap FilePath (MVar ()))
locksTVar)
      (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\FilePath
f -> IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ())
-> (IO () -> IO (Async ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Settings IO () -> Settings -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Monitor () -> ReaderT Settings IO ()
forall a. Monitor a -> ReaderT Settings IO a
getMonitor (Monitor () -> ReaderT Settings IO ())
-> Monitor () -> ReaderT Settings IO ()
forall a b. (a -> b) -> a -> b
$ (?mutex::Mutexes) => FilePath -> Monitor ()
FilePath -> Monitor ()
startJob FilePath
f) Settings
cfg) [FilePath]
checks
      MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock

watchNewTrack :: (?mutex :: Mutexes) => String
              -> TVar (HashMap FilePath (MVar ())) -> Event -> IO ()
watchNewTrack :: FilePath -> TVar (HashMap FilePath (MVar ())) -> Event -> IO ()
watchNewTrack FilePath
_ TVar (HashMap FilePath (MVar ()))
locksTVar (Removed FilePath
path UTCTime
_ Bool
True) = do
  HashMap FilePath (MVar ())
locks <- IO (HashMap FilePath (MVar ())) -> IO (HashMap FilePath (MVar ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap FilePath (MVar ()))
 -> IO (HashMap FilePath (MVar ())))
-> IO (HashMap FilePath (MVar ()))
-> IO (HashMap FilePath (MVar ()))
forall a b. (a -> b) -> a -> b
$ TVar (HashMap FilePath (MVar ()))
-> IO (HashMap FilePath (MVar ()))
forall a. TVar a -> IO a
readTVarIO TVar (HashMap FilePath (MVar ()))
locksTVar
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (HashMap FilePath (MVar ())
locks HashMap FilePath (MVar ()) -> FilePath -> MVar ()
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! FilePath
path) ()
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap FilePath (MVar ()))
-> (HashMap FilePath (MVar ()) -> HashMap FilePath (MVar ()))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap FilePath (MVar ()))
locksTVar (FilePath
-> HashMap FilePath (MVar ()) -> HashMap FilePath (MVar ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete FilePath
path)
  FilePath -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
FilePath -> m ()
logMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Monitor at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is stopped due to directory deletion."
watchNewTrack FilePath
tgvar TVar (HashMap FilePath (MVar ()))
locksTVar (Added FilePath
path UTCTime
_ Bool
True) =
  (?mutex::Mutexes) =>
FilePath -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
FilePath -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
spawnMonitorThread FilePath
tgvar TVar (HashMap FilePath (MVar ()))
locksTVar FilePath
path
watchNewTrack FilePath
_ TVar (HashMap FilePath (MVar ()))
_ Event
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

label :: String -> IO (Async ()) -> IO ()
label :: FilePath -> IO (Async ()) -> IO ()
label FilePath
lab IO (Async ())
action = do
  Async ()
asyn <- IO (Async ())
action
  ThreadId -> FilePath -> IO ()
labelThread (Async () -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async ()
asyn) FilePath
lab

spawnMonitorThread :: (?mutex :: Mutexes) => String
                   -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
spawnMonitorThread :: FilePath -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
spawnMonitorThread FilePath
tgvar TVar (HashMap FilePath (MVar ()))
locksTVar FilePath
dir =
  FilePath -> IO (Async ()) -> IO ()
label FilePath
dir (IO (Async ()) -> IO ())
-> (IO () -> IO (Async ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (?mutex::Mutexes) =>
FilePath -> FilePath -> TVar (HashMap FilePath (MVar ())) -> IO ()
FilePath -> FilePath -> TVar (HashMap FilePath (MVar ())) -> IO ()
trackDatabase FilePath
tgvar FilePath
dir TVar (HashMap FilePath (MVar ()))
locksTVar

runApp :: Options -> IO ()
runApp :: Options -> IO ()
runApp Options{FilePath
optionsToken :: Options -> FilePath
optionsDir :: Options -> FilePath
optionsToken :: FilePath
optionsDir :: FilePath
..} = do
  MVar ()
stdoutMutex <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  let ?mutex = Mutexes{..} in do
    FilePath -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
FilePath -> m ()
logMessage FilePath
"dbmonitor process started."
    [FilePath]
databaseDirs <- FilePath -> IO [FilePath]
collectMonitors FilePath
optionsDir
    Chan Event
eventChannel <- IO (Chan Event)
forall a. IO (Chan a)
newChan
    TVar (HashMap FilePath (MVar ()))
locksTVar <- HashMap FilePath (MVar ())
-> IO (TVar (HashMap FilePath (MVar ())))
forall a. a -> IO (TVar a)
newTVarIO HashMap FilePath (MVar ())
forall k v. HashMap k v
HM.empty
    (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mainWatcher -> do
      IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchManager
-> FilePath -> ActionPredicate -> Chan Event -> IO (IO ())
watchTreeChan WatchManager
mainWatcher FilePath
optionsDir (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) Chan Event
eventChannel
      [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
databaseDirs ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (?mutex::Mutexes) =>
FilePath -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
FilePath -> TVar (HashMap FilePath (MVar ())) -> FilePath -> IO ()
spawnMonitorThread FilePath
optionsToken TVar (HashMap FilePath (MVar ()))
locksTVar
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Event
event <- Chan Event -> IO Event
forall a. Chan a -> IO a
readChan Chan Event
eventChannel
        (?mutex::Mutexes) =>
FilePath -> TVar (HashMap FilePath (MVar ())) -> Event -> IO ()
FilePath -> TVar (HashMap FilePath (MVar ())) -> Event -> IO ()
watchNewTrack FilePath
optionsToken TVar (HashMap FilePath (MVar ()))
locksTVar Event
event