X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhalcyon.git;a=blobdiff_plain;f=src%2FMain.hs;h=bd749f8ca47115b89e7f57c38301ad3f7f7f11e7;hp=53c3f905e863e9c98537e4b62d5307335b573939;hb=86efdb6afac4a7a165babba90a0a25e0e1185e5b;hpb=76af720585a173aa47e7858964b581fdbf7a01e6 diff --git a/src/Main.hs b/src/Main.hs index 53c3f90..bd749f8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,11 +3,12 @@ where import Control.Concurrent (forkIO, threadDelay) import Control.Monad (forever, when) +import Data.List ((\\)) import System.Exit (ExitCode(..), exitWith) -import System.Time (getClockTime) import System.IO (hPutStrLn, stderr) import CommandLine +import Configuration (Cfg(..)) import ExitCodes import Mail import Twitter.Http @@ -15,10 +16,6 @@ import Twitter.Status import Twitter.User --- |The length of all calls to sleep (or threadDelay), in seconds. -heartbeat :: Int -heartbeat = 600 - -- |A wrapper around threadDelay which takes seconds instead of -- microseconds as its argument. thread_sleep :: Int -> IO () @@ -27,57 +24,121 @@ thread_sleep seconds = do 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. +-- |Given a 'Message', 'Status', and default 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 :: Message -> String -> Status -> Message -message_from_status message date status = - message { subject = "Twat: " ++ (screen_name (user status)), - body = (pretty_print status), - headers = ((headers message) ++ ["Date: " ++ date])} - - --- |This is the main recursive loop. It takes 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 :: 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 +message_from_status message default_date status = + message { subject = "Twat: " ++ (screen_name (user status)), + body = (pretty_print status), + headers = ((headers message) ++ ["Date: " ++ date])} + where + -- Use the Status' created_at date if it can be coerced into + -- RFC822 format. + date = case (created_at_to_rfc822 $ created_at status) of + Nothing -> default_date + Just c -> c - -- 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 -> [] +-- | If the given Message is not Nothing, send a copy of it for every +-- Status in the list. +send_messages :: Maybe Message -> [Status] -> IO () +send_messages maybe_message statuses = + case maybe_message of + Nothing -> return () + Just message -> do + default_date <- rfc822_now + let mfs = message_from_status message (default_date) + let messages = map mfs statuses + sendmail_results <- mapM sendmail messages + _ <- mapM print_sendmail_result sendmail_results + return () - 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 - date <- getClockTime - let messages = map (message_from_status message (show date)) new_statuses - sendmail_results <- mapM sendmail messages - mapM print_sendmail_result sendmail_results - recurse username new_latest_status_id maybe_message - return () +-- | 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 retweet 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 retweet ss + + good_statuses' = case (ignore_replies cfg) of + True -> ss \\ replies + False -> ss + + good_statuses = case (ignore_retweets cfg) of + True -> good_statuses' \\ retweets + False -> 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) + 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 -> + do_recurse latest_status_id + _ -> do + + mention_replies cfg new_statuses + mention_retweets cfg new_statuses --- |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 :: String -> IO Integer -get_latest_status_id username = do + let good_statuses = filter_statuses cfg new_statuses + + _ <- mapM (putStrLn . pretty_print) good_statuses + + send_messages 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 :: Int -> String -> IO Integer +get_latest_status_id delay username = do xmldata <- get_user_timeline username let initial_statuses = case xmldata of @@ -88,24 +149,39 @@ get_latest_status_id username = do 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 + thread_sleep delay + get_latest_status_id delay 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_twat :: Maybe Message -> String -> IO () -run_twat message username = do - latest_status_id <- get_latest_status_id username - recurse username latest_status_id message +-- | 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_twat :: Cfg -> Maybe Message -> String -> IO () +run_twat cfg msg username = do + latest_status_id <- get_latest_status_id (heartbeat 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_twat' for each supplied username. After -- forking, main loops forever. @@ -122,36 +198,60 @@ main = do -- 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 + help <- help_set + when (help) $ do + putStrLn help_text + exitWith ExitSuccess + -- Get the list of usernames. usernames <- parse_usernames + -- And a Cfg object. + cfg <- get_cfg + -- 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 }) + let message = construct_message cfg -- Execute run_twat on each username in a new thread. - mapM (forkIO . (run_twat message)) usernames + let run_twat_curried = run_twat cfg message + _ <- mapM (forkIO . run_twat_curried) usernames - forever $ do + _ <- forever $ do -- 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 () + + +-- | A debugging tool that will parse, print, and email a single +-- status (given by its id). +twat_single_status :: Integer -> (Maybe Message) -> IO () +twat_single_status the_status_id maybe_message = do + xmldata <- get_status the_status_id + + -- Parsing an empty result can blow up. Just pretend there are + -- no new statuses in that case. + let statuses = case xmldata of + Just xml -> parse_status xml + Nothing -> [] + + case (length statuses) of + 0 -> do + putStrLn "No statuses returned." + return () + _ -> do + _ <- mapM (putStrLn . pretty_print) statuses + + case maybe_message of + Nothing -> do + putStrLn "No message object given." + return () + Just message -> do + default_date <- rfc822_now + let messages = map (message_from_status message (default_date)) statuses + sendmail_results <- mapM sendmail messages + _ <- mapM print_sendmail_result sendmail_results + return ()