diff --git a/Application.hs b/Application.hs index d197e16..eace2ff 100644 --- a/Application.hs +++ b/Application.hs @@ -130,9 +130,10 @@ makeFoundation conf = do -- Start the cabal file loader void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do - $logInfo "Cleaning up /tmp" + $logInfoS "CLEANUP" "Cleaning up /tmp" now <- liftIO getCurrentTime runResourceT $ sourceDirectory "/tmp" $$ mapM_C (cleanupTemp now) + $logInfoS "CLEANUP" "Cleaning up complete" --when development $ liftIO $ threadDelay $ 5 * 60 * 1000000 eres <- tryAny $ flip runReaderT foundation $ do @@ -164,11 +165,13 @@ cleanupTemp :: UTCTime -> FilePath -> ResourceT (LoggingT IO) () cleanupTemp now fp | any (`isPrefixOf` name) prefixes = handleAny ($logError . tshow) $ do modified <- liftIO $ getModified fp - when (diffUTCTime now modified > 60 * 60) $ do - $logInfo $ "Removing temp directory: " ++ fpToText fp + if (diffUTCTime now modified > 60 * 60) + then do + $logInfoS "CLEANUP" $ "Removing temp directory: " ++ fpToText fp liftIO $ removeTree fp - $logInfo $ "Temp directory deleted: " ++ fpToText fp - | otherwise = return () + $logInfoS "CLEANUP" $ "Temp directory deleted: " ++ fpToText fp + else $logInfoS "CLEANUP" $ "Ignoring recent entry: " ++ fpToText fp + | otherwise = $logInfoS "CLEANUP" $ "Ignoring unmatched path: " ++ fpToText fp where name = fpToText $ filename fp prefixes = asVector $ pack diff --git a/Foundation.hs b/Foundation.hs index ad22829..912a8bf 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -125,8 +125,8 @@ instance Yesod App where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ _source level = - development || level == LevelWarn || level == LevelError + shouldLog _ source level = + development || level == LevelWarn || level == LevelError || source == "CLEANUP" makeLogger = return . appLogger diff --git a/Handler/System.hs b/Handler/System.hs index 473f52f..c5848a2 100644 --- a/Handler/System.hs +++ b/Handler/System.hs @@ -4,4 +4,7 @@ import Import import System.Process (readProcess) getSystemR :: Handler String -getSystemR = liftIO $ readProcess "df" ["-ih"] "" +getSystemR = liftIO $ do + x <- readProcess "df" ["-ih"] "" + y <- readProcess "ls" ["-lh", "/tmp"] "" + return $ unlines [x, y]