Fix two unsafe casts.
[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
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 ()