X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhalcyon.git;a=blobdiff_plain;f=src%2FMain.hs;fp=src%2FMain.hs;h=1d82ee4d5c6125653ac449fa10e3a65d84354318;hp=3c33d1d8aadcc0274e933c8ce3d68bca1ee296b0;hb=c9a905e0ab69317448f261377ab9031fb83443b4;hpb=15fd6f764f88f79424d7caaba564e57df564b532

diff --git a/src/Main.hs b/src/Main.hs
index 3c33d1d..1d82ee4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,19 +1,24 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+
 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 System.Directory ( doesFileExist )
 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 ExitCodes ( exit_no_usernames )
+import ExitCodes ( exit_no_usernames, exit_pidfile_exists )
 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(..) )
+import Unix ( full_daemonize )
 import Usernames ( Usernames(..) )
 
+
 -- | 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_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)
@@ -230,18 +237,47 @@ main = do
     _ <- 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
-
-  -- Execute run on each username in a new thread.
   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)