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