module Main where import Control.Concurrent (forkIO, threadDelay) import Control.Monad (forever, when) import Data.Aeson (decode) import Data.List ((\\)) import Data.Monoid ((<>)) import Data.Time.LocalTime (TimeZone, getCurrentTimeZone) import System.Exit (ExitCode(..), exitWith) import System.IO (hPutStrLn, stderr) import CommandLine import Configuration (Cfg(..), default_config, merge_optional) import ExitCodes (exit_no_usernames) import qualified OptionalConfiguration as OC import Mail ( Message(..), default_headers, print_sendmail_result, rfc822_now, sendmail ) import Twitter.Http import Twitter.Status import Twitter.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 = case created_at status of Nothing -> default_date Just c -> utc_time_to_rfc822 mtz c -- | If the given Message is not Nothing, send a copy of it for every -- Status in the 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 return () 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 ss = good_statuses 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' -- | 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 -- FIXME let Just new_statuses = decode timeline :: Maybe Timeline case (length new_statuses) of 0 -> 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_ (putStrLn . (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 Just initial_timeline = decode timeline :: Maybe Timeline case (length initial_timeline) of 0 -> do -- If the HTTP part barfs, try again after a while. putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...") thread_sleep delay get_latest_status_id cfg username _ -> return (get_max_status_id initial_timeline) -- | 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 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 $ 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. main :: IO () main = do -- And a Cfg object. rc_cfg <- OC.from_rc cmd_cfg <- apply_args -- Merge the config file options with the command-line ones, -- prefering the command-line ones. let opt_config = rc_cfg <> cmd_cfg -- 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 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. 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) return ()