X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhalcyon.git;a=blobdiff_plain;f=src%2FMain.hs;h=1d82ee4d5c6125653ac449fa10e3a65d84354318;hp=b7d7f716a32722431b6d27eee617e9aaa69b31a1;hb=c9a905e0ab69317448f261377ab9031fb83443b4;hpb=d7c6b5499c0969b6e488d9fc583f93bbb4e3d4c7 diff --git a/src/Main.hs b/src/Main.hs index b7d7f71..1d82ee4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,23 +1,27 @@ +{-# 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.List ( (\\) ) 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(..), default_config, merge_optional ) -import ExitCodes ( exit_no_usernames ) +import Configuration ( Cfg(..), merge_optional ) +import ExitCodes ( exit_no_usernames, exit_pidfile_exists ) import qualified OptionalConfiguration as OC ( from_rc ) import Mail ( Message(..), - default_headers, print_sendmail_result, rfc822_now, sendmail ) @@ -29,10 +33,13 @@ 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. +-- thread_sleep :: Int -> IO () thread_sleep seconds = do let microseconds = seconds * (10 ^ (6 :: Int)) @@ -40,21 +47,24 @@ thread_sleep seconds = do -- | Given a 'Message', 'Status', and date, update that message's body --- and subject with the information contained in the status. Adds a --- /Date: / header, and returns the updated message. +-- and subject with the information contained in the status. Adds a +-- /Date: / header, and returns the updated message. +-- message_from_status :: Maybe TimeZone -> Message -> String -> Status -> Message message_from_status mtz message default_date status = message { subject = "Halcyon: " ++ (screen_name (user status)), body = (pretty_print mtz status), headers = ((headers message) ++ ["Date: " ++ date])} where - date = - case created_at status of - Nothing -> default_date - Just c -> utc_time_to_rfc822 mtz c + date = maybe + default_date -- default + (utc_time_to_rfc822 mtz) -- function to apply if not Nothing + (created_at status) -- the Maybe thing --- | If the given Message is not Nothing, send a copy of it for every --- Status in the list. + +-- | If the given 'Message' is not 'Nothing', send a copy of it for +-- every 'Status' in the @statuses@ list. +-- send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO () send_messages cfg mtz maybe_message statuses = case maybe_message of @@ -64,13 +74,14 @@ send_messages cfg mtz maybe_message statuses = let mfs = message_from_status mtz message default_date let messages = map mfs statuses sendmail_results <- mapM sendmail' messages - _ <- mapM print_sendmail_result sendmail_results - return () + mapM_ print_sendmail_result sendmail_results where sendmail' = sendmail (sendmail_path cfg) + -- | Display the number of skipped replies if ignore_replies is true -- and verbose is enabled. +-- mention_replies :: Cfg -> [Status] -> IO () mention_replies cfg ss = do let replies = filter reply ss @@ -81,6 +92,7 @@ mention_replies cfg ss = do -- | Display the number of skipped retweets if ignore_retweets is true -- and verbose is enabled. +-- mention_retweets :: Cfg -> [Status] -> IO () mention_retweets cfg ss = do let retweets = filter retweeted ss @@ -91,29 +103,27 @@ mention_retweets cfg ss = do -- | Filter out replies/retweets based on the configuration. +-- filter_statuses :: Cfg -> [Status] -> [Status] -filter_statuses cfg ss = - good_statuses +filter_statuses cfg = + reply_filter . retweet_filter where - replies = filter reply ss - retweets = filter retweeted ss - - good_statuses' = if (ignore_replies cfg) - then ss \\ replies - else ss - - good_statuses = if (ignore_retweets cfg) - then good_statuses' \\ retweets - else good_statuses' + reply_filter = if ignore_replies cfg + then filter (not . reply) + else id + retweet_filter = if ignore_retweets cfg + then filter (not . retweeted) + else id -- | This is the main recursive loop. It takes a the configuration, a -- username, a latest_status_id, and optionally a 'Message' as --- arguments. The latest_status_id is the last status (that we know +-- arguments. The @latest_status_id@ is the last status (that we know -- of) to be posted to username's Twitter account. If we find any -- newer statuses when we check, they are printed and optionally -- emailed (if a 'Message' was supplied). Then, the process repeats. +-- recurse :: Cfg -> String -> Integer -> (Maybe Message) -> IO () recurse cfg username latest_status_id maybe_message = do thread_sleep (heartbeat cfg) @@ -155,6 +165,7 @@ recurse cfg username latest_status_id maybe_message = do -- | Try continually to download username's timeline, and determine the -- latest status id to be posted once we have done so. +-- get_latest_status_id :: Cfg -> String -> IO Integer get_latest_status_id cfg username = do let delay = heartbeat cfg @@ -185,31 +196,28 @@ get_latest_status_id cfg username = do -- recursive loop that checks for updates forever. The message -- argument is optional and is passed to recurse in case the updates -- should be emailed. +-- run :: Cfg -> Maybe Message -> String -> IO () run cfg msg username = do latest_status_id <- get_latest_status_id cfg username recurse cfg username latest_status_id msg - return () -- | Take advantage of the Maybe monad to only return a message when --- we have both a "to" and "from" address. +-- we have both a \"to\" and \"from\" address. +-- construct_message :: Cfg -> Maybe Message construct_message cfg = do to_addr <- to_address cfg from_addr <- from_address cfg - return $ make_msg to_addr from_addr - where - make_msg t f = Message { headers = default_headers, - body = "", - subject = "", - to = t, - from = f } - --- |The main function just parses the command-line arguments and then --- forks off calls to 'run' for each supplied username. After --- forking, main loops forever. + return $ def { to = to_addr, from = from_addr } + + +-- | The main function just parses the command-line arguments and then +-- forks off calls to 'run' for each supplied username. After +-- forking, main loops forever. +-- main :: IO () main = do -- And a Cfg object. @@ -222,25 +230,54 @@ main = do -- Finally, update a default config with any options that have been -- set in either the config file or on the command-line. - let cfg = merge_optional default_config opt_config + let cfg = merge_optional (def :: Cfg) opt_config when (null $ get_usernames (usernames cfg)) $ do hPutStrLn stderr "ERROR: no usernames supplied." _ <- 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)