{-# 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