src/Main.hs

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