b7d7f716a32722431b6d27eee617e9aaa69b31a1
[dead/halcyon.git] / 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 ( 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 )
18 import Mail (
19 Message(..),
20 default_headers,
21 print_sendmail_result,
22 rfc822_now,
23 sendmail )
24 import Twitter.Http ( get_user_new_statuses, get_user_timeline )
25 import Twitter.Status (
26 Status(..),
27 Timeline,
28 get_max_status_id,
29 pretty_print,
30 utc_time_to_rfc822 )
31 import Twitter.User ( User(..) )
32 import Usernames ( Usernames(..) )
33
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
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 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])}
50 where
51 date =
52 case created_at status of
53 Nothing -> default_date
54 Just c -> utc_time_to_rfc822 mtz c
55
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 =
60 case maybe_message of
61 Nothing -> return ()
62 Just message -> do
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
68 return ()
69 where
70 sendmail' = sendmail (sendmail_path cfg)
71
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."
80
81
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."
90
91
92
93 -- | Filter out replies/retweets based on the configuration.
94 filter_statuses :: Cfg -> [Status] -> [Status]
95 filter_statuses cfg ss =
96 good_statuses
97 where
98 replies = filter reply ss
99 retweets = filter retweeted ss
100
101 good_statuses' = if (ignore_replies cfg)
102 then ss \\ replies
103 else ss
104
105 good_statuses = if (ignore_retweets cfg)
106 then good_statuses' \\ retweets
107 else good_statuses'
108
109
110
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
121
122 let decoded_timeline = decode timeline :: Maybe Timeline
123
124 when (isNothing decoded_timeline) $
125 hPutStrLn stderr $
126 "Couldn't retrieve "
127 ++ username
128 ++ "'s timeline. Skipping..."
129
130 let new_statuses = fromMaybe [] decoded_timeline
131
132 case new_statuses of
133 [] -> do_recurse latest_status_id
134 _ -> do
135 mention_replies cfg new_statuses
136 mention_retweets cfg new_statuses
137
138 let good_statuses = filter_statuses cfg new_statuses
139
140 tz <- getCurrentTimeZone
141 let mtz = Just tz
142 mapM_ (putStr . (pretty_print mtz)) good_statuses
143
144 send_messages cfg mtz maybe_message good_statuses
145
146 let new_latest_status_id = get_max_status_id new_statuses
147 do_recurse new_latest_status_id
148
149 where
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
154
155
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
162
163 let decoded_timeline = decode timeline :: Maybe Timeline
164
165 when (isNothing decoded_timeline) $
166 hPutStrLn stderr $
167 "Couldn't retrieve "
168 ++ username
169 ++ "'s timeline. Skipping..."
170
171 let initial_timeline = fromMaybe [] decoded_timeline
172
173 case initial_timeline of
174 [] -> do
175 -- If the HTTP part barfs, try again after a while.
176 thread_sleep delay
177 get_latest_status_id cfg username
178 _ ->
179 return (get_max_status_id initial_timeline)
180
181
182
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
192 return ()
193
194
195
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
203 where
204 make_msg t f = Message { headers = default_headers,
205 body = "",
206 subject = "",
207 to = t,
208 from = f }
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 main :: IO ()
214 main = do
215 -- And a Cfg object.
216 rc_cfg <- OC.from_rc
217 cmd_cfg <- get_args
218
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
222
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
226
227 when (null $ get_usernames (usernames cfg)) $ do
228 hPutStrLn stderr "ERROR: no usernames supplied."
229 _ <- show_help
230 exitWith (ExitFailure exit_no_usernames)
231
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
235
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))
239
240 _ <- forever $
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)
245
246 return ()