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 )
14 import CommandLine ( get_args, show_help )
15 import Configuration ( Cfg(..), default_config, merge_optional )
16 import ExitCodes ( exit_no_usernames )
17 import qualified OptionalConfiguration as OC ( from_rc )
21 print_sendmail_result,
24 import Twitter.Http ( get_user_new_statuses, get_user_timeline )
25 import Twitter.Status (
31 import Twitter.User ( User(..) )
32 import Usernames ( Usernames(..) )
34 -- | A wrapper around threadDelay which takes seconds instead of
35 -- 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.
45 message_from_status :: Maybe TimeZone -> Message -> String -> Status -> Message
46 message_from_status mtz message default_date status =
47 message { subject = "Halcyon: " ++ (screen_name (user status)),
48 body = (pretty_print mtz status),
49 headers = ((headers message) ++ ["Date: " ++ date])}
52 case created_at status of
53 Nothing -> default_date
54 Just c -> utc_time_to_rfc822 mtz c
56 -- | If the given Message is not Nothing, send a copy of it for every
57 -- Status in the list.
58 send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO ()
59 send_messages cfg mtz maybe_message statuses =
63 default_date <- rfc822_now
64 let mfs = message_from_status mtz message default_date
65 let messages = map mfs statuses
66 sendmail_results <- mapM sendmail' messages
67 _ <- mapM print_sendmail_result sendmail_results
70 sendmail' = sendmail (sendmail_path cfg)
72 -- | Display the number of skipped replies if ignore_replies is true
73 -- and verbose is enabled.
74 mention_replies :: Cfg -> [Status] -> IO ()
75 mention_replies cfg ss = do
76 let replies = filter reply ss
77 when ((ignore_replies cfg) && (verbose cfg)) $ do
78 let countstr = show $ length replies
79 putStrLn $ "Ignoring " ++ countstr ++ " replies."
82 -- | Display the number of skipped retweets if ignore_retweets is true
83 -- and verbose is enabled.
84 mention_retweets :: Cfg -> [Status] -> IO ()
85 mention_retweets cfg ss = do
86 let retweets = filter retweeted ss
87 when ((ignore_retweets cfg) && (verbose cfg)) $ do
88 let countstr = show $ length retweets
89 putStrLn $ "Ignoring " ++ countstr ++ " retweets."
93 -- | Filter out replies/retweets based on the configuration.
94 filter_statuses :: Cfg -> [Status] -> [Status]
95 filter_statuses cfg ss =
98 replies = filter reply ss
99 retweets = filter retweeted ss
101 good_statuses' = if (ignore_replies cfg)
105 good_statuses = if (ignore_retweets cfg)
106 then good_statuses' \\ retweets
111 -- | This is the main recursive loop. It takes a the configuration, a
112 -- username, a latest_status_id, and optionally a 'Message' as
113 -- arguments. The latest_status_id is the last status (that we know
114 -- of) to be posted to username's Twitter account. If we find any
115 -- newer statuses when we check, they are printed and optionally
116 -- emailed (if a 'Message' was supplied). Then, the process repeats.
117 recurse :: Cfg -> String -> Integer -> (Maybe Message) -> IO ()
118 recurse cfg username latest_status_id maybe_message = do
119 thread_sleep (heartbeat cfg)
120 timeline <- get_user_new_statuses cfg username latest_status_id
122 let decoded_timeline = decode timeline :: Maybe Timeline
124 when (isNothing decoded_timeline) $
128 ++ "'s timeline. Skipping..."
130 let new_statuses = fromMaybe [] decoded_timeline
133 [] -> do_recurse latest_status_id
135 mention_replies cfg new_statuses
136 mention_retweets cfg new_statuses
138 let good_statuses = filter_statuses cfg new_statuses
140 tz <- getCurrentTimeZone
142 mapM_ (putStr . (pretty_print mtz)) good_statuses
144 send_messages cfg mtz maybe_message good_statuses
146 let new_latest_status_id = get_max_status_id new_statuses
147 do_recurse new_latest_status_id
150 -- This lets us write all of these parameters once rather
151 -- than... more than once.
152 do_recurse :: Integer -> IO ()
153 do_recurse lsi = recurse cfg username lsi maybe_message
156 -- | Try continually to download username's timeline, and determine the
157 -- latest status id to be posted once we have done so.
158 get_latest_status_id :: Cfg -> String -> IO Integer
159 get_latest_status_id cfg username = do
160 let delay = heartbeat cfg
161 timeline <- get_user_timeline cfg username
163 let decoded_timeline = decode timeline :: Maybe Timeline
165 when (isNothing decoded_timeline) $
169 ++ "'s timeline. Skipping..."
171 let initial_timeline = fromMaybe [] decoded_timeline
173 case initial_timeline of
175 -- If the HTTP part barfs, try again after a while.
177 get_latest_status_id cfg username
179 return (get_max_status_id initial_timeline)
183 -- | This function wraps two steps. First, we need to find the latest
184 -- status id posted by username. Once we have that, we can begin the
185 -- recursive loop that checks for updates forever. The message
186 -- argument is optional and is passed to recurse in case the updates
187 -- should be emailed.
188 run :: Cfg -> Maybe Message -> String -> IO ()
189 run cfg msg username = do
190 latest_status_id <- get_latest_status_id cfg username
191 recurse cfg username latest_status_id msg
196 -- | Take advantage of the Maybe monad to only return a message when
197 -- we have both a "to" and "from" address.
198 construct_message :: Cfg -> Maybe Message
199 construct_message cfg = do
200 to_addr <- to_address cfg
201 from_addr <- from_address cfg
202 return $ make_msg to_addr from_addr
204 make_msg t f = Message { headers = default_headers,
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.
219 -- Merge the config file options with the command-line ones,
220 -- prefering the command-line ones.
221 let opt_config = rc_cfg <> cmd_cfg
223 -- Finally, update a default config with any options that have been
224 -- set in either the config file or on the command-line.
225 let cfg = merge_optional default_config opt_config
227 when (null $ get_usernames (usernames cfg)) $ do
228 hPutStrLn stderr "ERROR: no usernames supplied."
230 exitWith (ExitFailure exit_no_usernames)
232 -- If we have both a "To" and "From" address, we'll create a
233 -- message object to be passed to all of our threads.
234 let message = construct_message cfg
236 -- Execute run on each username in a new thread.
237 let run_curried = run cfg message
238 _ <- mapM (forkIO . run_curried) (get_usernames (usernames cfg))
241 -- This thread (the one executing main) doesn't do anything,
242 -- but when it terminates, so do all the threads we forked.
243 -- As a result, we need to keep this thread on life support.
244 thread_sleep (heartbeat cfg)