Add the Unix module and enable daemonization.

[dead/halcyon.git] / src / Main.hs

diff --git a/src/Main.hs b/src/Main.hs
index 3c33d1d8aadcc0274e933c8ce3d68bca1ee296b0..1d82ee4d5c6125653ac449fa10e3a65d84354318 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,19 +1,24 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+

 module Main
 where
 
 import Control.Concurrent ( forkIO, threadDelay )
 module Main
 where
 
 import Control.Concurrent ( forkIO, threadDelay )

+import Control.Exception ( throw )

 import Control.Monad ( forever, when )
 import Data.Aeson ( decode )
 import Data.Maybe ( fromMaybe, isNothing )
 import Data.Monoid ( (<>) )
 import Data.Time.LocalTime ( TimeZone, getCurrentTimeZone )
 import System.Console.CmdArgs.Default ( Default(..) )
 import Control.Monad ( forever, when )
 import Data.Aeson ( decode )
 import Data.Maybe ( fromMaybe, isNothing )
 import Data.Monoid ( (<>) )
 import Data.Time.LocalTime ( TimeZone, getCurrentTimeZone )
 import System.Console.CmdArgs.Default ( Default(..) )

+import System.Directory ( doesFileExist )

 import System.Exit ( ExitCode(..), exitWith )
 import System.IO ( hPutStrLn, stderr )
 import System.Exit ( ExitCode(..), exitWith )
 import System.IO ( hPutStrLn, stderr )

+import System.IO.Error ( catchIOError )

 
 import CommandLine ( get_args, show_help )
 import Configuration ( Cfg(..), merge_optional )
 
 import CommandLine ( get_args, show_help )
 import Configuration ( Cfg(..), merge_optional )

-import ExitCodes ( exit_no_usernames )
+import ExitCodes ( exit_no_usernames, exit_pidfile_exists )

 import qualified OptionalConfiguration as OC ( from_rc )
 import Mail (
   Message(..),
 import qualified OptionalConfiguration as OC ( from_rc )
 import Mail (
   Message(..),


@@ -28,8 +33,10 @@ import Twitter.Status (
   pretty_print,
   utc_time_to_rfc822 )
 import Twitter.User ( User(..) )
   pretty_print,
   utc_time_to_rfc822 )
 import Twitter.User ( User(..) )

+import Unix ( full_daemonize )

 import Usernames ( Usernames(..) )
 
 import Usernames ( Usernames(..) )
 

+

 -- | A wrapper around threadDelay which takes seconds instead of
 --   microseconds as its argument.
 --
 -- | A wrapper around threadDelay which takes seconds instead of
 --   microseconds as its argument.
 --


@@ -98,8 +105,8 @@ mention_retweets cfg ss = do
 -- | Filter out replies/retweets based on the configuration.
 --
 filter_statuses :: Cfg -> [Status] -> [Status]
 -- | Filter out replies/retweets based on the configuration.
 --
 filter_statuses :: Cfg -> [Status] -> [Status]

-filter_statuses cfg statuses =
-  (reply_filter . retweet_filter) statuses
+filter_statuses cfg =
+  reply_filter . retweet_filter

   where
     reply_filter = if ignore_replies cfg
                    then filter (not . reply)
   where
     reply_filter = if ignore_replies cfg
                    then filter (not . reply)


@@ -230,18 +237,47 @@ main = do
     _ <- show_help
     exitWith (ExitFailure exit_no_usernames)
 
     _ <- show_help
     exitWith (ExitFailure exit_no_usernames)
 

+
+  when (daemonize cfg) $ do
+    -- Old PID files can be left around after an unclean shutdown. We
+    -- only care if we're running as a daemon.
+    pidfile_exists <- doesFileExist (pidfile cfg)
+    when pidfile_exists $ do
+      hPutStrLn stderr $ "ERROR: PID file " ++ (pidfile cfg) ++
+                         " already exists. Refusing to start."
+      exitWith (ExitFailure exit_pidfile_exists)
+
+

   -- If we have both a "To" and "From" address, we'll create a
   -- message object to be passed to all of our threads.
   let message = construct_message cfg
   -- If we have both a "To" and "From" address, we'll create a
   -- message object to be passed to all of our threads.
   let message = construct_message cfg

-
-  -- Execute run on each username in a new thread.

   let run_curried = run cfg message
   let run_curried = run cfg message

-  _ <- mapM (forkIO . run_curried) (get_usernames (usernames cfg))

 
 

-  _ <- forever $
-    -- This thread (the one executing main) doesn't do anything,
-    -- but when it terminates, so do all the threads we forked.
-    -- As a result, we need to keep this thread on life support.
-    thread_sleep (heartbeat cfg)
+  let run_program = (mapM_ -- Execute run on each username in a new thread.
+                      (forkIO . run_curried)
+                      (get_usernames (usernames cfg)))
+                    >>
+                    -- This thread (the one executing main) doesn't do
+                    -- anything, but when it terminates, so do all the
+                    -- threads we forked.  As a result, we need to
+                    -- keep this thread on life support.  If we were
+                    -- asked to daemonize, do that; otherwise just run
+                    -- the thing.
+                    forever (thread_sleep (heartbeat cfg))
+
+  if (daemonize cfg)
+  then try_daemonize cfg run_program
+  else run_program

 
 

-  return ()
+  where
+    -- | A exception handler around full_daemonize. If full_daemonize
+    --   doesn't work, we report the error and crash. This is fine; we
+    --   only need the program to be resilient once it actually starts.
+    --
+    try_daemonize :: Cfg -> IO () -> IO ()
+    try_daemonize cfg program =
+      catchIOError
+        (full_daemonize cfg program)
+        (\e -> do
+          hPutStrLn stderr ("ERROR: " ++ (show e))
+          throw e)