From ccfadfcee2fb1070a478e4f2f65d588541f4588e Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 14 May 2014 08:28:00 +0300
Subject: [PATCH] System monitor and /tmp cleanup

---
 Application.hs        | 25 +++++++++++++++++++++++++
 Handler/System.hs     |  7 +++++++
 config/routes         |  1 +
 stackage-server.cabal |  1 +
 4 files changed, 34 insertions(+)
 create mode 100644 Handler/System.hs

diff --git a/Application.hs b/Application.hs
index c8bcec5..d197e16 100644
--- a/Application.hs
+++ b/Application.hs
@@ -30,6 +30,8 @@ import Control.Monad.Catch (MonadCatch (..))
 import Database.Persist.Sql (SqlPersistT (..))
 import Control.Monad.Trans.Resource.Internal (ResourceT (..))
 import Control.Monad.Reader (MonadReader (..))
+import Filesystem (getModified, removeTree)
+import Data.Time (diffUTCTime)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -46,6 +48,7 @@ import Handler.HackageViewSdist
 import Handler.Aliases
 import Handler.Alias
 import Handler.Progress
+import Handler.System
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -127,6 +130,10 @@ makeFoundation conf = do
 
     -- Start the cabal file loader
     void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
+        $logInfo "Cleaning up /tmp"
+        now <- liftIO getCurrentTime
+        runResourceT $ sourceDirectory "/tmp" $$ mapM_C (cleanupTemp now)
+
         --when development $ liftIO $ threadDelay $ 5 * 60 * 1000000
         eres <- tryAny $ flip runReaderT foundation $ do
             let runDB' :: SqlPersistT (ResourceT (ReaderT App (LoggingT IO))) a
@@ -153,6 +160,24 @@ makeFoundation conf = do
 
     return foundation
 
+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
+            liftIO $ removeTree fp
+            $logInfo $ "Temp directory deleted: " ++ fpToText fp
+    | otherwise = return ()
+  where
+    name = fpToText $ filename fp
+    prefixes = asVector $ pack
+        [ "hackage-index"
+        , "createview"
+        , "build00index."
+        , "newindex"
+        ]
+
 instance MonadActive m => MonadActive (SqlPersistT m) where -- FIXME orphan upstream
     monadActive = lift monadActive
 instance MonadReader env m => MonadReader env (SqlPersistT m) where
diff --git a/Handler/System.hs b/Handler/System.hs
new file mode 100644
index 0000000..473f52f
--- /dev/null
+++ b/Handler/System.hs
@@ -0,0 +1,7 @@
+module Handler.System where
+
+import Import
+import System.Process (readProcess)
+
+getSystemR :: Handler String
+getSystemR = liftIO $ readProcess "df" ["-ih"] ""
diff --git a/config/routes b/config/routes
index 0b31b81..16c9f92 100644
--- a/config/routes
+++ b/config/routes
@@ -17,3 +17,4 @@
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR
 /progress/#Int ProgressR GET
+/system SystemR GET
diff --git a/stackage-server.cabal b/stackage-server.cabal
index 23e93a3..ff649f6 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -37,6 +37,7 @@ library
                      Handler.Aliases
                      Handler.Alias
                      Handler.Progress
+                     Handler.System
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT