src/Main.hs

   1 module Main
   2 where
   3
   4 import Control.Concurrent (forkIO, threadDelay)
   5 import Control.Monad (forever, when)
   6 import Data.Maybe (fromJust)
   7 import System.Exit (ExitCode(..), exitWith)
   8 import System.IO (hPutStrLn, stderr)
   9
  10 import CommandLine
  11 import ExitCodes
  12 import Mail
  13 import Twitter.Http
  14 import Twitter.Status
  15 import Twitter.User
  16
  17
  18 -- |A wrapper around threadDelay which takes seconds instead of
  19 -- microseconds as its argument.
  20 thread_sleep :: Int -> IO ()
  21 thread_sleep seconds = do
  22   let microseconds = seconds * (10 ^ (6 :: Int))
  23   threadDelay microseconds
  24
  25
  26 -- |Given a 'Message', 'Status', and date, update that message's body
  27 -- and subject with the information contained in the status. Adds a
  28 -- /Date: / header, and returns the updated message.
  29 message_from_status :: Message -> String -> Status -> Message
  30 message_from_status message date status =
  31     message { subject = "Twat: " ++ (screen_name (user status)),
  32               body    = (pretty_print status),
  33               headers = ((headers message) ++ ["Date: " ++ date])}
  34
  35
  36 -- |This is the main recursive loop. It takes a length of time to
  37 -- delay (in seconds), a username, a latest_status_id, and optionally
  38 -- a 'Message' as arguments. The latest_status_id is the last status
  39 -- (that we know of) to be posted to username's Twitter account. If we
  40 -- find any newer statuses when we check, they are printed and
  41 -- optionally emailed (if a 'Message' was supplied). Then, the process
  42 -- repeats.
  43 recurse :: Int -> String -> Integer -> (Maybe Message) -> IO ()
  44 recurse delay username latest_status_id maybe_message = do
  45     thread_sleep delay
  46     xmldata <- get_user_new_statuses username latest_status_id
  47
  48     -- Parsing an empty result can blow up. Just pretend there are
  49     -- no new statuses in that case.
  50     let new_statuses = case xmldata of
  51                          Just xml -> parse_statuses xml
  52                          Nothing  -> []
  53
  54     case (length new_statuses) of
  55       0 ->
  56         recurse delay username latest_status_id maybe_message
  57       _ -> do
  58         let new_latest_status_id = get_max_status_id new_statuses
  59         _ <- mapM (putStrLn . pretty_print) new_statuses
  60
  61         case maybe_message of
  62           Nothing -> do
  63              recurse delay username new_latest_status_id maybe_message
  64              return ()
  65           Just message -> do
  66              date_header <- construct_date_header
  67              let messages = map (message_from_status message (date_header)) new_statuses
  68              sendmail_results <- mapM sendmail messages
  69              _ <- mapM print_sendmail_result sendmail_results
  70              recurse delay username new_latest_status_id maybe_message
  71              return ()
  72
  73
  74 -- |Try continually to download username's timeline, and determine the
  75 -- latest status id to be posted once we have done so.
  76 get_latest_status_id :: Int -> String -> IO Integer
  77 get_latest_status_id delay username = do
  78   xmldata <- get_user_timeline username
  79
  80   let initial_statuses = case xmldata of
  81                            Just xml -> parse_statuses xml
  82                            Nothing -> []
  83
  84   case (length initial_statuses) of
  85     0 -> do
  86       -- If the HTTP part barfs, try again after a while.
  87       putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...")
  88       thread_sleep delay
  89       get_latest_status_id delay username
  90     _ -> return (get_max_status_id initial_statuses)
  91
  92
  93
  94 -- |This function wraps two steps. First, we need to find the latest
  95 -- status id posted by username. Once we have that, we can begin the
  96 -- recursive loop that checks for updates forever. The message
  97 -- argument is optional and is passed to recurse in case the updates
  98 -- should be emailed.
  99 run_twat :: Int -> Maybe Message -> String -> IO ()
 100 run_twat delay message username = do
 101   latest_status_id <- get_latest_status_id delay username
 102   recurse delay username latest_status_id message
 103   return ()
 104
 105
 106 -- |The main function just parses the command-line arguments and then
 107 -- forks off calls to 'run_twat' for each supplied username. After
 108 -- forking, main loops forever.
 109 main :: IO ()
 110 main = do
 111   errors <- parse_errors
 112
 113   -- If there  were errors parsing the command-line options,
 114   -- print them and exit.
 115   when (not (null errors)) $ do
 116       hPutStrLn stderr (concat errors)
 117       putStrLn help_text
 118       exitWith (ExitFailure exit_args_parse_failed)
 119
 120   -- Next, check to see if the 'help' option was passed to the
 121   -- program. If it was, display the help, and exit successfully.
 122   help_opt_set <- help_set
 123   when help_opt_set $ do
 124       putStrLn help_text
 125       exitWith ExitSuccess
 126
 127   usernames <- parse_usernames
 128
 129   -- If we have both a "To" and "From" address, we'll create a
 130   -- message object to be passed to all of our threads.
 131   to_address <- to_email_address
 132   from_address <- from_email_address
 133   let message = case to_address of
 134                   Nothing -> Nothing
 135                   Just toaddr ->
 136                       case from_address of
 137                         Nothing -> Nothing
 138                         Just fromaddr ->
 139                             Just (Message { headers = default_headers,
 140                                             body = "",
 141                                             subject = "",
 142                                             to = toaddr,
 143                                             from = fromaddr })
 144
 145   -- This should be safe since we checked for parse errors earlier.
 146   delay <- fmap fromJust heartbeat
 147
 148   -- Execute run_twat on each username in a new thread.
 149   _ <- mapM (forkIO . (run_twat delay message)) usernames
 150
 151   _ <- forever $ do
 152     -- This thread (the one executing main) doesn't do anything,
 153     -- but when it terminates, so do all the threads we forked.
 154     -- As a result, we need to keep this thread on life support.
 155     thread_sleep delay
 156
 157   return ()
 158
 159
 160 -- |A debugging tool that will parse, print, and email a single status
 161 -- (given by its id).
 162 twat_single_status :: Integer -> (Maybe Message) -> IO ()
 163 twat_single_status the_status_id maybe_message = do
 164     xmldata <- get_status the_status_id
 165
 166     -- Parsing an empty result can blow up. Just pretend there are
 167     -- no new statuses in that case.
 168     let statuses = case xmldata of
 169                      Just xml -> parse_status xml
 170                      Nothing  -> []
 171
 172     case (length statuses) of
 173       0 -> do
 174         putStrLn "No statuses returned."
 175         return ()
 176       _ -> do
 177         _ <- mapM (putStrLn . pretty_print) statuses
 178
 179         case maybe_message of
 180           Nothing -> do
 181              putStrLn "No message object given."
 182              return ()
 183           Just message -> do
 184              date_header <- construct_date_header
 185              let messages = map (message_from_status message (date_header)) statuses
 186              sendmail_results <- mapM sendmail messages
 187              _ <- mapM print_sendmail_result sendmail_results
 188              return ()