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 )
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 )
20 print_sendmail_result,
23 import Twitter.Http ( get_user_new_statuses, get_user_timeline )
24 import Twitter.Status (
30 import Twitter.User ( User(..) )
31 import Usernames ( Usernames(..) )
33 -- | A wrapper around threadDelay which takes seconds instead of
34 -- microseconds as its argument.
36 thread_sleep :: Int -> IO ()
37 thread_sleep seconds = do
38 let microseconds = seconds * (10 ^ (6 :: Int))
39 threadDelay microseconds
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.
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])}
53 default_date -- default
54 (utc_time_to_rfc822 mtz) -- function to apply if not Nothing
55 (created_at status) -- the Maybe thing
58 -- | If the given 'Message' is not 'Nothing', send a copy of it for
59 -- every 'Status' in the @statuses@ list.
61 send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO ()
62 send_messages cfg mtz maybe_message statuses =
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
72 sendmail' = sendmail (sendmail_path cfg)
75 -- | Display the number of skipped replies if ignore_replies is true
76 -- and verbose is enabled.
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."
86 -- | Display the number of skipped retweets if ignore_retweets is true
87 -- and verbose is enabled.
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."
98 -- | Filter out replies/retweets based on the configuration.
100 filter_statuses :: Cfg -> [Status] -> [Status]
101 filter_statuses cfg statuses =
102 (reply_filter . retweet_filter) statuses
104 reply_filter = if ignore_replies cfg
105 then filter (not . reply)
108 retweet_filter = if ignore_retweets cfg
109 then filter (not . retweeted)
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.
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
125 let decoded_timeline = decode timeline :: Maybe Timeline
127 when (isNothing decoded_timeline) $
131 ++ "'s timeline. Skipping..."
133 let new_statuses = fromMaybe [] decoded_timeline
136 [] -> do_recurse latest_status_id
138 mention_replies cfg new_statuses
139 mention_retweets cfg new_statuses
141 let good_statuses = filter_statuses cfg new_statuses
143 tz <- getCurrentTimeZone
145 mapM_ (putStr . (pretty_print mtz)) good_statuses
147 send_messages cfg mtz maybe_message good_statuses
149 let new_latest_status_id = get_max_status_id new_statuses
150 do_recurse new_latest_status_id
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
159 -- | Try continually to download username's timeline, and determine the
160 -- latest status id to be posted once we have done so.
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
167 let decoded_timeline = decode timeline :: Maybe Timeline
169 when (isNothing decoded_timeline) $
173 ++ "'s timeline. Skipping..."
175 let initial_timeline = fromMaybe [] decoded_timeline
177 case initial_timeline of
179 -- If the HTTP part barfs, try again after a while.
181 get_latest_status_id cfg username
183 return (get_max_status_id initial_timeline)
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.
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
200 -- | Take advantage of the Maybe monad to only return a message when
201 -- we have both a \"to\" and \"from\" address.
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 }
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.
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
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
228 when (null $ get_usernames (usernames cfg)) $ do
229 hPutStrLn stderr "ERROR: no usernames supplied."
231 exitWith (ExitFailure exit_no_usernames)
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
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))
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)