src/Main.hs

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