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