X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhalcyon.git;a=blobdiff_plain;f=src%2FMain.hs;h=3c33d1d8aadcc0274e933c8ce3d68bca1ee296b0;hp=84536d757e3389319f5edb875965b5871e053342;hb=1b72ed45ef890ed1329a32457b4d7f3a7fb37788;hpb=94484087fbfe98d6735aa82798a9bf506f97fd19 diff --git a/src/Main.hs b/src/Main.hs index 84536d7..3c33d1d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,133 +1,247 @@ module Main where -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad (forever, when) -import System.Exit (ExitCode(..), exitWith) -import System.IO (hPutStrLn, stderr) - -import CommandLine -import Mail -import Twitter.Http -import Twitter.Status -import Twitter.User +import Control.Concurrent ( forkIO, threadDelay ) +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.Exit ( ExitCode(..), exitWith ) +import System.IO ( hPutStrLn, stderr ) + +import CommandLine ( get_args, show_help ) +import Configuration ( Cfg(..), merge_optional ) +import ExitCodes ( exit_no_usernames ) +import qualified OptionalConfiguration as OC ( from_rc ) +import Mail ( + Message(..), + print_sendmail_result, + rfc822_now, + sendmail ) +import Twitter.Http ( get_user_new_statuses, get_user_timeline ) +import Twitter.Status ( + Status(..), + Timeline, + get_max_status_id, + pretty_print, + utc_time_to_rfc822 ) +import Twitter.User ( User(..) ) +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)) + threadDelay microseconds + + +-- | 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. +-- +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 = 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 @statuses@ list. +-- +send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO () +send_messages cfg mtz maybe_message statuses = + case maybe_message of + Nothing -> return () + Just message -> do + default_date <- rfc822_now + 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 + 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 + when ((ignore_replies cfg) && (verbose cfg)) $ do + let countstr = show $ length replies + putStrLn $ "Ignoring " ++ countstr ++ " replies." + + +-- | 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 + when ((ignore_retweets cfg) && (verbose cfg)) $ do + let countstr = show $ length retweets + putStrLn $ "Ignoring " ++ countstr ++ " retweets." + + + +-- | Filter out replies/retweets based on the configuration. +-- +filter_statuses :: Cfg -> [Status] -> [Status] +filter_statuses cfg statuses = + (reply_filter . retweet_filter) statuses + where + 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 +-- 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) + timeline <- get_user_new_statuses cfg username latest_status_id + + let decoded_timeline = decode timeline :: Maybe Timeline + + when (isNothing decoded_timeline) $ + hPutStrLn stderr $ + "Couldn't retrieve " + ++ username + ++ "'s timeline. Skipping..." + + let new_statuses = fromMaybe [] decoded_timeline + + case new_statuses of + [] -> do_recurse latest_status_id + _ -> do + mention_replies cfg new_statuses + mention_retweets cfg new_statuses + + let good_statuses = filter_statuses cfg new_statuses + + tz <- getCurrentTimeZone + let mtz = Just tz + mapM_ (putStr . (pretty_print mtz)) good_statuses + + send_messages cfg mtz maybe_message good_statuses + + let new_latest_status_id = get_max_status_id new_statuses + do_recurse new_latest_status_id + + where + -- This lets us write all of these parameters once rather + -- than... more than once. + do_recurse :: Integer -> IO () + do_recurse lsi = recurse cfg username lsi maybe_message + + +-- | 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 + timeline <- get_user_timeline cfg username + + let decoded_timeline = decode timeline :: Maybe Timeline + + when (isNothing decoded_timeline) $ + hPutStrLn stderr $ + "Couldn't retrieve " + ++ username + ++ "'s timeline. Skipping..." + + let initial_timeline = fromMaybe [] decoded_timeline + + case initial_timeline of + [] -> do + -- If the HTTP part barfs, try again after a while. + thread_sleep delay + get_latest_status_id cfg username + _ -> + return (get_max_status_id initial_timeline) -exit_args_parse_failed :: Int -exit_args_parse_failed = 1 --- The length of all calls to sleep, in seconds. -heartbeat :: Int -heartbeat = 600 -thread_sleep :: Int -> IO () -thread_sleep microseconds = do - let seconds = microseconds * (10 ^ (6 :: Int)) - threadDelay seconds - - -message_from_status :: Message -> Status -> Message -message_from_status message status = - message { subject = "Twat: " ++ (screen_name (user status)), - body = (pretty_print status) } - -recurse :: String -> Integer -> (Maybe Message) -> IO () -recurse username latest_status_id maybe_message = do - thread_sleep heartbeat - xmldata <- get_user_new_statuses username latest_status_id - - -- Parsing an empty result can blow up. Just pretend there are - -- no new statuses in that case. - let new_statuses = case xmldata of - Just xml -> parse_statuses xml - Nothing -> [] - - case (length new_statuses) of - 0 -> - recurse username latest_status_id maybe_message - _ -> do - let new_latest_status_id = get_max_status_id new_statuses - mapM (putStrLn . pretty_print) new_statuses - - case maybe_message of - Nothing -> do - recurse username new_latest_status_id maybe_message - return () - Just message -> do - let messages = map (message_from_status message) new_statuses - sendmail_results <- mapM sendmail messages - mapM print_sendmail_result sendmail_results - recurse username new_latest_status_id maybe_message - return () - - -get_latest_status_id :: String -> IO Integer -get_latest_status_id username = do - xmldata <- get_user_timeline username - - let initial_statuses = case xmldata of - Just xml -> parse_statuses xml - Nothing -> [] - - case (length initial_statuses) of - 0 -> do - -- If the HTTP part barfs, try again after a while. - putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...") - thread_sleep heartbeat - get_latest_status_id username - _ -> return (get_max_status_id initial_statuses) +-- | This function wraps two steps. First, we need to find the latest +-- status id posted by username. Once we have that, we can begin the +-- 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 -run_twat :: Maybe Message -> String -> IO () -run_twat message username = do - latest_status_id <- get_latest_status_id username - recurse username latest_status_id message - return () +-- | Take advantage of the Maybe monad to only return a message when +-- 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 $ 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 - errors <- parse_errors + -- And a Cfg object. + rc_cfg <- OC.from_rc + cmd_cfg <- get_args - -- If there were errors parsing the command-line options, - -- print them and exit. - when (not (null errors)) $ do - hPutStrLn stderr (concat errors) - putStrLn help_text - exitWith (ExitFailure exit_args_parse_failed) + -- Merge the config file options with the command-line ones, + -- prefering the command-line ones. + let opt_config = rc_cfg <> cmd_cfg - -- Next, check to see if the 'help' option was passed to the - -- program. If it was, display the help, and exit successfully. - help_opt_set <- help_set - when help_opt_set $ do - putStrLn help_text - exitWith ExitSuccess + -- 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 (def :: Cfg) opt_config - usernames <- parse_usernames + when (null $ get_usernames (usernames cfg)) $ do + hPutStrLn stderr "ERROR: no usernames supplied." + _ <- show_help + exitWith (ExitFailure exit_no_usernames) -- If we have both a "To" and "From" address, we'll create a -- message object to be passed to all of our threads. - to_address <- to_email_address - from_address <- from_email_address - let message = case to_address of - Nothing -> Nothing - Just toaddr -> - case from_address of - Nothing -> Nothing - Just fromaddr -> - Just (Message { headers = [], - body = "", - subject = "", - to = toaddr, - from = fromaddr }) - - -- Execute run_twat on each username in a new thread. - mapM (forkIO . (run_twat message)) usernames - - forever $ do + 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 + thread_sleep (heartbeat cfg) return ()