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