A little more cleanup debugging

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

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
 

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]