src/Main.hs

   1 module Main
   2 where
   3
   4 import Control.Concurrent (forkIO, threadDelay)
   5 import Control.Monad (forever, when)
   6 import Data.Aeson (decode)
   7 import Data.List ((\\))
   8 import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
   9 import System.Exit (ExitCode(..), 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' = case (ignore_replies cfg) of
  89                          True  -> ss \\ replies
  90                          False -> ss
  91
  92   good_statuses = case (ignore_retweets cfg) of
  93                     True  -> good_statuses' \\ retweets
  94                     False -> 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 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 :: Int -> String -> IO Integer
 141 get_latest_status_id delay username = do
 142   timeline <- get_user_timeline username
 143   let Just initial_timeline = decode timeline :: Maybe Timeline
 144
 145   case (length initial_timeline) of
 146     0 -> do
 147       -- If the HTTP part barfs, try again after a while.
 148       putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...")
 149       thread_sleep delay
 150       get_latest_status_id delay username
 151     _ -> return (get_max_status_id initial_timeline)
 152
 153
 154
 155 -- | This function wraps two steps. First, we need to find the latest
 156 --   status id posted by username. Once we have that, we can begin the
 157 --   recursive loop that checks for updates forever. The message
 158 --   argument is optional and is passed to recurse in case the updates
 159 --   should be emailed.
 160 run_twat :: Cfg -> Maybe Message -> String -> IO ()
 161 run_twat cfg msg username = do
 162   latest_status_id <- get_latest_status_id (heartbeat cfg) username
 163   recurse cfg username latest_status_id msg
 164   return ()
 165
 166
 167
 168 -- | Take advantage of the Maybe monad to only return a message when
 169 --   we have both a "to" and "from" address.
 170 construct_message :: Cfg -> Maybe Message
 171 construct_message cfg = do
 172   to_addr <- to_address cfg
 173   from_addr <- from_address cfg
 174   return $ make_msg to_addr from_addr
 175   where
 176     make_msg t f = Message { headers = default_headers,
 177                              body = "",
 178                              subject = "",
 179                              to = t,
 180                              from = f }
 181
 182 -- |The main function just parses the command-line arguments and then
 183 -- forks off calls to 'run_twat' for each supplied username. After
 184 -- forking, main loops forever.
 185 main :: IO ()
 186 main = do
 187   errors <- parse_errors
 188
 189   -- If there  were errors parsing the command-line options,
 190   -- print them and exit.
 191   when (not (null errors)) $ do
 192       hPutStrLn stderr (concat errors)
 193       putStrLn help_text
 194       exitWith (ExitFailure exit_args_parse_failed)
 195
 196   -- Next, check to see if the 'help' option was passed to the
 197   -- program. If it was, display the help, and exit successfully.
 198   help <- help_set
 199   when (help) $ do
 200     putStrLn help_text
 201     exitWith ExitSuccess
 202
 203   -- Get the list of usernames.
 204   usernames <- parse_usernames
 205
 206   -- And a Cfg object.
 207   cfg <- get_cfg
 208
 209   -- If we have both a "To" and "From" address, we'll create a
 210   -- message object to be passed to all of our threads.
 211   let message = construct_message cfg
 212
 213   -- Execute run_twat on each username in a new thread.
 214   let run_twat_curried = run_twat cfg message
 215   _ <- mapM (forkIO . run_twat_curried) usernames
 216
 217   _ <- forever $ do
 218     -- This thread (the one executing main) doesn't do anything,
 219     -- but when it terminates, so do all the threads we forked.
 220     -- As a result, we need to keep this thread on life support.
 221     thread_sleep (heartbeat cfg)
 222
 223   return ()