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.Maybe ( fromMaybe, isNothing )
   8 import Data.Monoid ( (<>) )
   9 import Data.Time.LocalTime ( TimeZone, getCurrentTimeZone )
  10 import System.Console.CmdArgs.Default ( Default(..) )
  11 import System.Exit ( ExitCode(..), exitWith )
  12 import System.IO ( hPutStrLn, stderr )
  13
  14 import CommandLine ( get_args, show_help )
  15 import Configuration ( Cfg(..), merge_optional )
  16 import ExitCodes ( exit_no_usernames )
  17 import qualified OptionalConfiguration as OC ( from_rc )
  18 import Mail (
  19   Message(..),
  20   print_sendmail_result,
  21   rfc822_now,
  22   sendmail )
  23 import Twitter.Http ( get_user_new_statuses, get_user_timeline )
  24 import Twitter.Status (
  25   Status(..),
  26   Timeline,
  27   get_max_status_id,
  28   pretty_print,
  29   utc_time_to_rfc822 )
  30 import Twitter.User ( User(..) )
  31 import Usernames ( Usernames(..) )
  32
  33 -- | A wrapper around threadDelay which takes seconds instead of
  34 --   microseconds as its argument.
  35 --
  36 thread_sleep :: Int -> IO ()
  37 thread_sleep seconds = do
  38   let microseconds = seconds * (10 ^ (6 :: Int))
  39   threadDelay microseconds
  40
  41
  42 -- | Given a 'Message', 'Status', and date, update that message's body
  43 --   and subject with the information contained in the status. Adds a
  44 --   /Date: / header, and returns the updated message.
  45 --
  46 message_from_status :: Maybe TimeZone -> Message -> String -> Status -> Message
  47 message_from_status mtz message default_date status =
  48   message { subject = "Halcyon: " ++ (screen_name (user status)),
  49             body    = (pretty_print mtz status),
  50             headers = ((headers message) ++ ["Date: " ++ date])}
  51   where
  52     date = maybe
  53              default_date -- default
  54              (utc_time_to_rfc822 mtz) -- function to apply if not Nothing
  55              (created_at status) -- the Maybe thing
  56
  57
  58 -- | If the given 'Message' is not 'Nothing', send a copy of it for
  59 --   every 'Status' in the @statuses@ list.
  60 --
  61 send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO ()
  62 send_messages cfg mtz maybe_message statuses =
  63   case maybe_message of
  64     Nothing -> return ()
  65     Just message -> do
  66       default_date <- rfc822_now
  67       let mfs = message_from_status mtz message default_date
  68       let messages = map mfs statuses
  69       sendmail_results <- mapM sendmail' messages
  70       mapM_ print_sendmail_result sendmail_results
  71   where
  72     sendmail' = sendmail (sendmail_path cfg)
  73
  74
  75 -- | Display the number of skipped replies if ignore_replies is true
  76 --   and verbose is enabled.
  77 --
  78 mention_replies :: Cfg -> [Status] -> IO ()
  79 mention_replies cfg ss = do
  80   let replies  = filter reply ss
  81   when ((ignore_replies cfg) && (verbose cfg)) $ do
  82     let countstr = show $ length replies
  83     putStrLn $ "Ignoring " ++ countstr ++ " replies."
  84
  85
  86 -- | Display the number of skipped retweets if ignore_retweets is true
  87 --   and verbose is enabled.
  88 --
  89 mention_retweets :: Cfg -> [Status] -> IO ()
  90 mention_retweets cfg ss = do
  91   let retweets = filter retweeted ss
  92   when ((ignore_retweets cfg) && (verbose cfg)) $ do
  93     let countstr = show $ length retweets
  94     putStrLn  $ "Ignoring " ++ countstr ++ " retweets."
  95
  96
  97
  98 -- | Filter out replies/retweets based on the configuration.
  99 --
 100 filter_statuses :: Cfg -> [Status] -> [Status]
 101 filter_statuses cfg statuses =
 102   (reply_filter . retweet_filter) statuses
 103   where
 104     reply_filter = if ignore_replies cfg
 105                    then filter (not . reply)
 106                    else id
 107
 108     retweet_filter = if ignore_retweets cfg
 109                      then filter (not . retweeted)
 110                      else id
 111
 112
 113 -- | This is the main recursive loop. It takes a the configuration, a
 114 --   username, a latest_status_id, and optionally a 'Message' as
 115 --   arguments. The @latest_status_id@ is the last status (that we know
 116 --   of) to be posted to username's Twitter account. If we find any
 117 --   newer statuses when we check, they are printed and optionally
 118 --   emailed (if a 'Message' was supplied). Then, the process repeats.
 119 --
 120 recurse :: Cfg -> String -> Integer -> (Maybe Message) -> IO ()
 121 recurse cfg username latest_status_id maybe_message = do
 122   thread_sleep (heartbeat cfg)
 123   timeline <- get_user_new_statuses cfg username latest_status_id
 124
 125   let decoded_timeline = decode timeline :: Maybe Timeline
 126
 127   when (isNothing decoded_timeline) $
 128     hPutStrLn stderr $
 129       "Couldn't retrieve "
 130       ++ username
 131       ++ "'s timeline. Skipping..."
 132
 133   let new_statuses = fromMaybe [] decoded_timeline
 134
 135   case new_statuses of
 136     [] -> do_recurse latest_status_id
 137     _  -> do
 138       mention_replies cfg new_statuses
 139       mention_retweets cfg new_statuses
 140
 141       let good_statuses = filter_statuses cfg new_statuses
 142
 143       tz <- getCurrentTimeZone
 144       let mtz = Just tz
 145       mapM_ (putStr . (pretty_print mtz)) good_statuses
 146
 147       send_messages cfg mtz maybe_message good_statuses
 148
 149       let new_latest_status_id = get_max_status_id new_statuses
 150       do_recurse new_latest_status_id
 151
 152   where
 153     -- This lets us write all of these parameters once rather
 154     -- than... more than once.
 155     do_recurse :: Integer -> IO ()
 156     do_recurse lsi = recurse cfg username lsi maybe_message
 157
 158
 159 -- | Try continually to download username's timeline, and determine the
 160 --   latest status id to be posted once we have done so.
 161 --
 162 get_latest_status_id :: Cfg -> String -> IO Integer
 163 get_latest_status_id cfg username = do
 164   let delay = heartbeat cfg
 165   timeline <- get_user_timeline cfg username
 166
 167   let decoded_timeline = decode timeline :: Maybe Timeline
 168
 169   when (isNothing decoded_timeline) $
 170     hPutStrLn stderr $
 171       "Couldn't retrieve "
 172       ++ username
 173       ++ "'s timeline. Skipping..."
 174
 175   let initial_timeline = fromMaybe [] decoded_timeline
 176
 177   case initial_timeline of
 178     [] -> do
 179       -- If the HTTP part barfs, try again after a while.
 180       thread_sleep delay
 181       get_latest_status_id cfg username
 182     _  ->
 183       return (get_max_status_id initial_timeline)
 184
 185
 186
 187 -- | This function wraps two steps. First, we need to find the latest
 188 --   status id posted by username. Once we have that, we can begin the
 189 --   recursive loop that checks for updates forever. The message
 190 --   argument is optional and is passed to recurse in case the updates
 191 --   should be emailed.
 192 --
 193 run :: Cfg -> Maybe Message -> String -> IO ()
 194 run cfg msg username = do
 195   latest_status_id <- get_latest_status_id cfg username
 196   recurse cfg username latest_status_id msg
 197
 198
 199
 200 -- | Take advantage of the Maybe monad to only return a message when
 201 --   we have both a \"to\" and \"from\" address.
 202 --
 203 construct_message :: Cfg -> Maybe Message
 204 construct_message cfg = do
 205   to_addr <- to_address cfg
 206   from_addr <- from_address cfg
 207   return $ def { to = to_addr, from = from_addr }
 208
 209
 210 -- | The main function just parses the command-line arguments and then
 211 --   forks off calls to 'run' for each supplied username. After
 212 --   forking, main loops forever.
 213 --
 214 main :: IO ()
 215 main = do
 216   -- And a Cfg object.
 217   rc_cfg  <- OC.from_rc
 218   cmd_cfg <- get_args
 219
 220   -- Merge the config file options with the command-line ones,
 221   -- prefering the command-line ones.
 222   let opt_config = rc_cfg <> cmd_cfg
 223
 224   -- Finally, update a default config with any options that have been
 225   -- set in either the config file or on the command-line.
 226   let cfg = merge_optional (def :: Cfg) opt_config
 227
 228   when (null $ get_usernames (usernames cfg)) $ do
 229     hPutStrLn stderr "ERROR: no usernames supplied."
 230     _ <- show_help
 231     exitWith (ExitFailure exit_no_usernames)
 232
 233   -- If we have both a "To" and "From" address, we'll create a
 234   -- message object to be passed to all of our threads.
 235   let message = construct_message cfg
 236
 237   -- Execute run on each username in a new thread.
 238   let run_curried = run cfg message
 239   _ <- mapM (forkIO . run_curried) (get_usernames (usernames cfg))
 240
 241   _ <- forever $
 242     -- This thread (the one executing main) doesn't do anything,
 243     -- but when it terminates, so do all the threads we forked.
 244     -- As a result, we need to keep this thread on life support.
 245     thread_sleep (heartbeat cfg)
 246
 247   return ()