src/Main.hs

   1 module Main
   2 where
   3
   4 import Control.Concurrent (forkIO, threadDelay)
   5 import Control.Monad (forever, when)
   6 import Data.List ((\\))
   7 import System.Exit (ExitCode(..), exitWith)
   8 import System.IO (hPutStrLn, stderr)
   9
  10 import CommandLine
  11 import Configuration (Cfg(..))
  12 import ExitCodes
  13 import Mail
  14 import Twitter.Http
  15 import Twitter.Status
  16 import Twitter.User
  17
  18
  19 -- |A wrapper around threadDelay which takes seconds instead of
  20 -- microseconds as its argument.
  21 thread_sleep :: Int -> IO ()
  22 thread_sleep seconds = do
  23   let microseconds = seconds * (10 ^ (6 :: Int))
  24   threadDelay microseconds
  25
  26
  27 -- |Given a 'Message', 'Status', and default date, update that
  28 -- message's body and subject with the information contained in the
  29 -- status. Adds a /Date: / header, and returns the updated message.
  30 message_from_status :: Message -> String -> Status -> Message
  31 message_from_status message default_date status =
  32   message { subject = "Twat: " ++ (screen_name (user status)),
  33             body    = (pretty_print status),
  34             headers = ((headers message) ++ ["Date: " ++ date])}
  35   where
  36     -- Use the Status' created_at date if it can be coerced into
  37     -- RFC822 format.
  38     date = case (created_at_to_rfc822 $ created_at status) of
  39              Nothing -> default_date
  40              Just c  -> c
  41
  42 -- | If the given Message is not Nothing, send a copy of it for every
  43 -- Status in the list.
  44 send_messages :: Cfg -> Maybe Message -> [Status] -> IO ()
  45 send_messages cfg maybe_message statuses =
  46   case maybe_message of
  47     Nothing -> return ()
  48     Just message -> do
  49       default_date <- rfc822_now
  50       let mfs = message_from_status message (default_date)
  51       let messages = map mfs statuses
  52       sendmail_results <- mapM sendmail' messages
  53       _ <- mapM print_sendmail_result sendmail_results
  54       return ()
  55   where
  56     sendmail' = sendmail (sendmail_path cfg)
  57
  58 -- | Display the number of skipped replies if ignore_replies is true
  59 --   and verbose is enabled.
  60 mention_replies :: Cfg -> [Status] -> IO ()
  61 mention_replies cfg ss = do
  62   let replies  = filter reply ss
  63   when ((ignore_replies cfg) && (verbose cfg)) $ do
  64     let countstr = show $ length replies
  65     putStrLn $ "Ignoring " ++ countstr ++ " replies."
  66
  67
  68 -- | Display the number of skipped retweets if ignore_retweets is true
  69 --   and verbose is enabled.
  70 mention_retweets :: Cfg -> [Status] -> IO ()
  71 mention_retweets cfg ss = do
  72   let retweets = filter retweet ss
  73   when ((ignore_retweets cfg) && (verbose cfg)) $ do
  74     let countstr = show $ length retweets
  75     putStrLn  $ "Ignoring " ++ countstr ++ " retweets."
  76
  77
  78
  79 -- | Filter out replies/retweets based on the configuration.
  80 filter_statuses :: Cfg -> [Status] -> [Status]
  81 filter_statuses cfg ss =
  82   good_statuses
  83   where
  84   replies  = filter reply ss
  85   retweets = filter retweet ss
  86
  87   good_statuses' = case (ignore_replies cfg) of
  88                          True  -> ss \\ replies
  89                          False -> ss
  90
  91   good_statuses = case (ignore_retweets cfg) of
  92                     True  -> good_statuses' \\ retweets
  93                     False -> good_statuses'
  94
  95
  96
  97 -- | This is the main recursive loop. It takes a the configuration, a
  98 --   username, a latest_status_id, and optionally a 'Message' as
  99 --   arguments. The latest_status_id is the last status (that we know
 100 --   of) to be posted to username's Twitter account. If we find any
 101 --   newer statuses when we check, they are printed and optionally
 102 --   emailed (if a 'Message' was supplied). Then, the process repeats.
 103 recurse :: Cfg -> String -> Integer -> (Maybe Message) -> IO ()
 104 recurse cfg username latest_status_id maybe_message = do
 105   thread_sleep (heartbeat cfg)
 106   xmldata <- get_user_new_statuses username latest_status_id
 107
 108   -- Parsing an empty result can blow up. Just pretend there are
 109   -- no new statuses in that case.
 110   let new_statuses = case xmldata of
 111                        Just xml -> parse_statuses xml
 112                        Nothing  -> []
 113
 114   case (length new_statuses) of
 115     0 ->
 116       do_recurse latest_status_id
 117     _ -> do
 118
 119       mention_replies cfg new_statuses
 120       mention_retweets cfg new_statuses
 121
 122       let good_statuses = filter_statuses cfg new_statuses
 123
 124       _ <- mapM (putStrLn . pretty_print) good_statuses
 125
 126       send_messages cfg maybe_message good_statuses
 127
 128       let new_latest_status_id = get_max_status_id new_statuses
 129       do_recurse new_latest_status_id
 130
 131   where
 132     -- This lets us write all of these parameters once rather
 133     -- than... more than once.
 134     do_recurse :: Integer -> IO ()
 135     do_recurse lsi = recurse cfg username lsi maybe_message
 136
 137
 138 -- | Try continually to download username's timeline, and determine the
 139 --   latest status id to be posted once we have done so.
 140 get_latest_status_id :: Int -> String -> IO Integer
 141 get_latest_status_id delay username = do
 142   xmldata <- get_user_timeline username
 143
 144   let initial_statuses = case xmldata of
 145                            Just xml -> parse_statuses xml
 146                            Nothing -> []
 147
 148   case (length initial_statuses) of
 149     0 -> do
 150       -- If the HTTP part barfs, try again after a while.
 151       putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...")
 152       thread_sleep delay
 153       get_latest_status_id delay username
 154     _ -> return (get_max_status_id initial_statuses)
 155
 156
 157
 158 -- | This function wraps two steps. First, we need to find the latest
 159 --   status id posted by username. Once we have that, we can begin the
 160 --   recursive loop that checks for updates forever. The message
 161 --   argument is optional and is passed to recurse in case the updates
 162 --   should be emailed.
 163 run_twat :: Cfg -> Maybe Message -> String -> IO ()
 164 run_twat cfg msg username = do
 165   latest_status_id <- get_latest_status_id (heartbeat cfg) username
 166   recurse cfg username latest_status_id msg
 167   return ()
 168
 169
 170
 171 -- | Take advantage of the Maybe monad to only return a message when
 172 --   we have both a "to" and "from" address.
 173 construct_message :: Cfg -> Maybe Message
 174 construct_message cfg = do
 175   to_addr <- to_address cfg
 176   from_addr <- from_address cfg
 177   return $ make_msg to_addr from_addr
 178   where
 179     make_msg t f = Message { headers = default_headers,
 180                              body = "",
 181                              subject = "",
 182                              to = t,
 183                              from = f }
 184
 185 -- |The main function just parses the command-line arguments and then
 186 -- forks off calls to 'run_twat' for each supplied username. After
 187 -- forking, main loops forever.
 188 main :: IO ()
 189 main = do
 190   errors <- parse_errors
 191
 192   -- If there  were errors parsing the command-line options,
 193   -- print them and exit.
 194   when (not (null errors)) $ do
 195       hPutStrLn stderr (concat errors)
 196       putStrLn help_text
 197       exitWith (ExitFailure exit_args_parse_failed)
 198
 199   -- Next, check to see if the 'help' option was passed to the
 200   -- program. If it was, display the help, and exit successfully.
 201   help <- help_set
 202   when (help) $ do
 203     putStrLn help_text
 204     exitWith ExitSuccess
 205
 206   -- Get the list of usernames.
 207   usernames <- parse_usernames
 208
 209   -- And a Cfg object.
 210   cfg <- get_cfg
 211
 212   -- If we have both a "To" and "From" address, we'll create a
 213   -- message object to be passed to all of our threads.
 214   let message = construct_message cfg
 215
 216   -- Execute run_twat on each username in a new thread.
 217   let run_twat_curried = run_twat cfg message
 218   _ <- mapM (forkIO . run_twat_curried) usernames
 219
 220   _ <- forever $ do
 221     -- This thread (the one executing main) doesn't do anything,
 222     -- but when it terminates, so do all the threads we forked.
 223     -- As a result, we need to keep this thread on life support.
 224     thread_sleep (heartbeat cfg)
 225
 226   return ()
 227
 228
 229 -- | A debugging tool that will parse, print, and email a single
 230 --   status (given by its id).
 231 twat_single_status :: Cfg -> Integer -> (Maybe Message) -> IO ()
 232 twat_single_status cfg the_status_id maybe_message = do
 233     xmldata <- get_status the_status_id
 234
 235     -- Parsing an empty result can blow up. Just pretend there are
 236     -- no new statuses in that case.
 237     let statuses = case xmldata of
 238                      Just xml -> parse_status xml
 239                      Nothing  -> []
 240
 241     case (length statuses) of
 242       0 -> do
 243         putStrLn "No statuses returned."
 244         return ()
 245       _ -> do
 246         _ <- mapM (putStrLn . pretty_print) statuses
 247
 248         case maybe_message of
 249           Nothing -> do
 250              putStrLn "No message object given."
 251              return ()
 252           Just message -> do
 253              default_date <- rfc822_now
 254              let messages = map (message_from_status message (default_date)) statuses
 255              sendmail_results <- mapM sendmail' messages
 256              _ <- mapM print_sendmail_result sendmail_results
 257              return ()
 258     where
 259       sendmail' = sendmail (sendmail_path cfg)