rss2irc 0.3 → 0.4
raw patch · 2 files changed
+443/−130 lines, 2 filesdep +haskell98dep +irc
Dependencies added: haskell98, irc
Files
- rss2irc.cabal +65/−5
- rss2irc.hs +378/−125
rss2irc.cabal view
@@ -1,5 +1,5 @@ name: rss2irc-version: 0.3+version: 0.4 homepage: http://hackage.haskell.org/package/rss2irc license: BSD3 license-file: LICENSE@@ -13,10 +13,35 @@ aims to be a simple, dependable bot that does its job and creates no problems. .- > Usage: rss2irc [OPTS] FEEDURL [irc://]BOTNAME@IRCSERVER/#CHANNEL- > or: rss2irc [OPTS] FEEDURL (same as --debug)+ > Usage: rss2irc FEEDURL [BOTNAME@IRCSERVER/#CHANNEL] [OPTS] > Options: >+ > -p PORT --port=PORT irc server port (default 6667)+ > --ident=STR set the bot's identity string (useful for contact info)+ > --delay=N wait for N minutes before starting (helps avoid mass joins)+ > -i N --interval=N polling interval in minutes (default 5)+ > --idle=N announce only when channel has been idle N minutes (default 0)+ > -m N --max-items=N announce at most N items per polling interval (default 5)+ > -r N --recent=N announce up to N recent items at startup (default 0)+ > --announce=topnew|allnew|top which items to announce (default: topnew)+ > --no-title don't show title (title is announced by default, up to 100 chars)+ > -a --author show author (up to 50 chars)+ > -d --description show description (up to 300 chars)+ > -l --link show link URL (up to 200 chars)+ > -t --time show timestamp (up to 50 chars)+ > -e --email show email addresses (stripped by default)+ > -h --html show HTML tags and entities (stripped by default)+ > --dupe-descriptions show identical consecutive descriptions (elided by default)+ > --replace="OLD/NEW" replace OLD with NEW (regexpr patterns)+ > -n N --num-iterations=N exit after N iterations+ > -q --quiet silence normal console output+ > --debug do not connect to irc (same as no irc argument)+ > --debug-irc show irc activity+ > --debug-feed show feed items and polling stats+ > --debug-xml show feed content+ > --debug-http show feed fetching progress+ > Options:+ > > -p PORT --port=PORT irc server port (default 6667) > --ident=STR set the bot's identity string (useful for contact info) > --delay=N wait for N seconds before starting (helps avoid mass joins)@@ -41,8 +66,41 @@ . For example, to announce Hackage updates: .- > rss2irc irc.freenode.org '#haskell' mybot http://hackage.haskell.org/packages/archive/recent.rss-+ > rss2irc http://hackage.haskell.org/packages/archive/recent.rss mybot@irc.freenode.org/#haskell+ .+ Release notes for 0.4, 2009/09/25:+ .+ * wait for server connection confirmation before JOIN command.+ Problem was observed on irc.quakenet.org since it refuses+ to join or any commands before connection is confirmed by server. (Radoslav Dorcik)+ .+ * feed polling now recovers from transient failures+ .+ * can poll a local file: uri as well as remote uris+ Works if the uri is of the form "file:FILE", at least. Useful for testing+ and eg for announcing a feed generated from a darcs posthook.+ .+ * more robust new item detection, with some alternate strategies+ available via the --announce option. The choices are:+ topnew - new unseen items at the top (default, good for most feeds);+ allnew - new unseen items anywhere+ top - any items above the previous top item.+ .+ * --idle option, waits for N minutes of channel idle time before announcing+ .+ * --delay now takes minutes, not seconds+ .+ * limit individual field sizes, preventing too many irc messages per item+ Most announcements should now fit in one irc message, and pretty much all+ should fit in two.+ .+ * misc. announcement output improvements: elide identical consecutive+ item descriptions, split long announcements on a word boundary, try+ to complete a split announcement within a batch, better whitespace+ handling+ .+ * logging improvements+ . stability: experimental tested-with: GHC==6.8, GHC==6.10 cabal-version: >= 1.6@@ -55,7 +113,9 @@ base >= 3 && < 5, extensible-exceptions >= 0.1 && < 0.2, feed >= 0.3 && < 0.4,+ haskell98, HTTP >= 4000.0.3 && < 4000.1,+ irc >= 0.4 && < 0.5, mtl >= 1.1 && < 1.2, network >= 2.2 && < 2.3, parallel >= 1.1 && < 1.2,
rss2irc.hs view
@@ -10,23 +10,30 @@ import Control.Concurrent (forkIO,threadDelay) import Control.Concurrent.Chan (Chan,newChan,writeList2Chan,readChan,unGetChan)+import Control.Concurrent.SampleVar (SampleVar,newSampleVar,writeSampleVar,readSampleVar) import Control.Monad (when,unless,forever) import Data.List (isPrefixOf,foldl',stripPrefix,intercalate) import Data.List.Split (splitOn) import Data.Either (either)-import Data.Maybe (fromMaybe,fromJust,isJust)-import Data.Time.Clock (getCurrentTime)+import Data.Maybe (fromMaybe,fromJust,isJust,isNothing)+import Data.Time.Clock (UTCTime,getCurrentTime,diffUTCTime)+import Data.Time.Format (parseTime) import Data.Time.LocalTime (LocalTime,getCurrentTimeZone,utcToLocalTime)-import Network.HTTP (Response,getRequest,rspBody,rspCode)-import Network.Browser (browse,request,setAllowRedirects,setOutHandler)+import Locale (defaultTimeLocale) import Network (PortID(PortNumber), connectTo)-import qualified Control.Exception.Extensible as E (bracket,bracket_,catch,fromException)+import Network.Browser (browse,request,setAllowRedirects,setOutHandler)+import Network.HTTP (Response,getRequest,rspBody,rspCode)+import Network.IRC (Message(Message),msg_command,msg_params,decode,encode,nick,user,joinChan,privmsg) -- part,quit)+import Network.URI (URI(URI),uriScheme,parseURI)+import qualified Control.Exception.Extensible as E (bracket,catch)+import Control.Exception.Extensible (fromException) import Control.Parallel.Strategies (NFData) --(rnf),($|)) import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg,NoArg), ArgOrder(Permute), getOpt, usageInfo) import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(ExitSuccess), exitFailure) import System.IO (Handle, BufferMode(NoBuffering),stdout,hSetBuffering,hFlush,hClose,hGetLine) import Text.Feed.Import (parseFeedString)+import Text.Feed.Constructor (withItemDescription) import Text.Feed.Query (feedItems ,getItemTitle ,getItemLink@@ -49,31 +56,52 @@ -- strace :: Show a => a -> a -- strace a = trace (show a) a -defaultport, defaultinterval, defaultmaxitems, maxmessagelength :: Int-defaultport = 6667-defaultinterval = 5 -- minutes-defaultmaxitems = 5 -- items-maxmessagelength = 400 -- characters+defaultport, defaultinterval, defaultidle, defaultmaxitems, maxmessagelength, maxtitlelength, maxdesclength, maxauthorlength, maxdatelength, maxlinklength :: Int+defaultport = 6667 -- default irc port+defaultinterval = 5 -- default polling interval in minutes+defaultidle = 0 -- default required silent time before announcing+defaultmaxitems = 5 -- default max items to announce per interval+maxmessagelength = 400 -- max characters per irc message+-- max field sizes. Max announcement length will be the sum of these+-- plus typically 15 due to prettification plus any length increase+-- due to --replace. The below should keep most announcements within+-- maxmessagelength and all announcements within maxmessagelength * 2 or so.+maxtitlelength = 100+maxdesclength = 300+maxauthorlength = 50+maxdatelength = 50+maxlinklength = 200+announcestrategies :: [String] -- how to detect announceable items:+announcestrategies =+ ["topnew" -- new unseen items at the top (good for most feeds)+ ,"allnew" -- new unseen items anywhere (announces items of a feed newly added to a planet)+ ,"top" -- any items above the previous top item+ ]+defaultannouncestrategy :: String+defaultannouncestrategy = head announcestrategies options :: [OptDescr Opt] options = [Option ['p'] ["port"] (ReqArg Port "PORT") "irc server port (default 6667)" ,Option [] ["ident"] (ReqArg Ident "STR") "set the bot's identity string (useful for contact info)"- ,Option [] ["delay"] (ReqArg Delay "N") "wait for N seconds before starting (helps avoid mass joins)"+ ,Option [] ["delay"] (ReqArg Delay "N") "wait for N minutes before starting (helps avoid mass joins)" ,Option ['i'] ["interval"] (ReqArg Interval "N") ("polling interval in minutes (default "++(show defaultinterval)++")")- ,Option ['r'] ["recent"] (ReqArg Recent "N") "announce up to N recent items at startup (default 0)"+ ,Option [] ["idle"] (ReqArg Idle "N") ("announce only when channel has been idle N minutes (default "++(show defaultidle)++")") ,Option ['m'] ["max-items"] (ReqArg MaxItems "N") ("announce at most N items per polling interval (default "++(show defaultmaxitems)++")")- ,Option [] ["no-title"] (NoArg NoTitle) "don't show title (title is announced by default)"- ,Option ['a'] ["author"] (NoArg Author) "show author"- ,Option ['d'] ["description"] (NoArg Description) "show description"- ,Option ['l'] ["link"] (NoArg Link) "show link URL"- ,Option ['t'] ["time"] (NoArg Time) "show timestamp"- ,Option ['e'] ["email"] (NoArg Email) "show email addresses (these are stripped by default)"- ,Option ['h'] ["html"] (NoArg Html) "show HTML tags and entities (these are stripped by default)"+ ,Option ['r'] ["recent"] (ReqArg Recent "N") "announce up to N recent items at startup (default 0)"+ ,Option [] ["announce"] (ReqArg Announce $ intercalate "|" announcestrategies) ("which items to announce (default: "++defaultannouncestrategy++")")+ ,Option [] ["no-title"] (NoArg NoTitle) ("don't show title (title is announced by default, up to "++(show maxtitlelength)++" chars)")+ ,Option ['a'] ["author"] (NoArg Author) ("show author (up to "++(show maxauthorlength)++" chars)")+ ,Option ['d'] ["description"] (NoArg Description) ("show description (up to "++(show maxdesclength)++" chars)")+ ,Option ['l'] ["link"] (NoArg Link) ("show link URL (up to "++(show maxlinklength)++" chars)")+ ,Option ['t'] ["time"] (NoArg Time) ("show timestamp (up to "++(show maxdatelength)++" chars)")+ ,Option ['e'] ["email"] (NoArg Email) "show email addresses (stripped by default)"+ ,Option ['h'] ["html"] (NoArg Html) "show HTML tags and entities (stripped by default)"+ ,Option [] ["dupe-descriptions"] (NoArg DupeDescriptions) "show identical consecutive descriptions (elided by default)" ,Option [] ["replace"] (ReqArg Replace "\"OLD/NEW\"") "replace OLD with NEW (regexpr patterns)" ,Option ['n'] ["num-iterations"] (ReqArg NumIterations "N") "exit after N iterations" ,Option ['q'] ["quiet"] (NoArg Quiet) "silence normal console output"- ,Option [] ["debug"] (NoArg Debug) "do not connect to irc"+ ,Option [] ["debug"] (NoArg Debug) "do not connect to irc (same as no irc argument)" ,Option [] ["debug-irc"] (NoArg DebugIrc) "show irc activity" ,Option [] ["debug-feed"] (NoArg DebugFeed) "show feed items and polling stats" ,Option [] ["debug-xml"] (NoArg DebugXml) "show feed content"@@ -82,8 +110,7 @@ help :: IO a help = do- putStrLn "Usage: rss2irc [OPTS] FEEDURL [irc://]BOTNAME@IRCSERVER/#CHANNEL"- putStrLn " or: rss2irc [OPTS] FEEDURL (same as --debug)"+ putStrLn "Usage: rss2irc FEEDURL [BOTNAME@IRCSERVER/#CHANNEL] [OPTS]" putStrLn "Options:" putStrLn (usageInfo "" options) exitWith ExitSuccess@@ -95,6 +122,8 @@ | Interval {value::String} | MaxItems {value::String} | Recent {value::String}+ | Announce {value::String}+ | Idle {value::String} | Author | Description | Time@@ -102,6 +131,7 @@ | NoTitle | Email | Html+ | DupeDescriptions | Replace {value::String} | NumIterations {value::String} | Quiet@@ -116,9 +146,10 @@ , server :: String , port :: !Int , channel :: String- , nick :: String+ , botnick :: String , botopts :: ![Opt] , outputqueue :: Chan String+ , lastmsgtime :: UTCTime } instance NFData Item@@ -128,68 +159,90 @@ (opts, args, errs) <- getOpt Permute options `fmap` getArgs let delay = optIntValue Delay 0 opts interval = optIntValue Interval defaultinterval opts- errs' = errs ++ if (interval > 0 || (isJust $ numIterations opts)) then [] else ["Eh.. no."]+ announcestrategy = optValue Announce defaultannouncestrategy opts+ errs' = errs+ ++ if (interval > 0 || (isJust $ numIterations opts)) then [] else ["Eh.. no."]+ ++ if announcestrategy `elem` announcestrategies then [] else ["--announce should be one of "++intercalate ", " announcestrategies] when (not . null $ errs') $ mapM_ putStrLn errs' >> help -- force early failure if there is a bad regexp. XXX Don't know how to catch this yet. seq (applyReplacements opts "") $ return ()- when (delay > 0) $ threadDelay $ delay * 1000000+ when (delay > 0) $ threadDelay $ delay * minutes q <- newChan+ t <- getCurrentTime (feed,bot) <- case args of [f,nsc] -> case map (splitOn "@") $ splitOn "/" $ maybe nsc id (stripPrefix "irc://" nsc) of [[n,s],[c]] -> return (f, Bot{ socket = stdout , server = s , port = optIntValue Port defaultport opts , channel = c- , nick = n+ , botnick = n , botopts = opts , outputqueue = q+ , lastmsgtime = t }) _ -> help [f] -> return (f, Bot{ socket = stdout , server = "" , port = 0 , channel = ""- , nick = ""+ , botnick = "" , botopts = Debug:opts , outputqueue = q+ , lastmsgtime = t }) _ -> help + -- XXX error handling needs review. run tries to handle some errors by+ -- restarting its threads, but does not reconnect the bot. Some errors+ -- might be caught but not propagated here, in which case the thread+ -- exits. Errors which do propagate here cause a program exit. E.bracket (connect bot) (disconnect)- (\b -> run b feed `E.catch` exit b)+ (\b -> run b feed `E.catch` exit) where - exit b e = case E.fromException e of- Just ExitSuccess -> exitWith ExitSuccess- _ -> printf "Error, %s died with: %s\n" (nick b) (show e) >> exitFailure+ exit e = case fromException e of+ Just ExitSuccess -> exitWith ExitSuccess+ _ -> getTimeStamp >>= \t -> printf "%s: rss2irc error: run died with: %s, exiting\n" t (show e) >> exitFailure -- | Connect to the irc server. connect :: Bot -> IO Bot connect b | Debug `elem` (botopts b) = do unless (Quiet `elem` botopts b) $ printf "Skipping IRC connection due to --debug\n" return b-connect b = do- let opts = botopts b- E.bracket_- (unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: %s connecting to %s, channel %s... " t (nick b) (server b) (channel b) >> hFlush stdout)- (unless (Quiet `elem` opts) $ printf "connected.\n" >> hFlush stdout)- (do- h <- connectTo (server b) (PortNumber (fromIntegral (port b)))- hSetBuffering h NoBuffering- return b{socket=h})+connect b@(Bot{server=s,port=p,channel=c,botnick=n,botopts=opts}) = do+ let ident = optValue Ident "rss2irc gateway" opts+ unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: %s connecting to %s, channel %s...\n" t n s c >> hFlush stdout+ h <- connectTo s (PortNumber $ fromIntegral p)+ hSetBuffering h NoBuffering+ let b' = b{socket=h}+ ircWrite b' $ encode $ nick n+ ircWrite b' $ encode $ user n "0" "*" ident+ (connected,err) <- ircWaitForServerResp b' -- some servers require this, eg quakenet+ if not connected+ then fail $ printf "rss2irc error: irc connection failed with %s\n" err+ else do+ ircWrite b' $ encode $ joinChan c+ unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: connected.\n" t >> hFlush stdout+ return b' --- | Join a channel, and start processing commands.+-- | Given a connected bot, start various threads to poll and announce,+-- restarting them if they fail. run :: Bot -> String -> IO ()-run b@(Bot{nick=n,channel=c,botopts=opts}) f = do- let ident = optValue Ident "rss2irc gateway" opts- ircWrite b $ "NICK " ++ n- ircWrite b $ printf "USER %s 0 * :%s" n ident- ircWrite b $ "JOIN " ++ c- forkIO $ feedReaderThread b f- forkIO $ ircWriterThread b- ircResponderThread b+run b@(Bot{botopts=opts}) f = do+ -- XXX do errors in forked threads propagate to the bracket above ? I think not.+ forkIO $ forever $ do+ feedReaderThread b f+ `catch` \e -> (unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: rss2irc error: feed reader thread died with %s, restarting\n" t (show e) >> hFlush stdout)+ bv <- newSampleVar b+ -- XXX reconnect bot when these fail (?)+ -- forkIO $ forever $ do+ forkIO $ ircWriterThread bv 0+ -- `E.catch` \e -> (unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: rss2irc error: irc writer thread died with %s, restarting\n" t (show $ fromException e) >> hFlush stdout)+ -- forever $ do+ ircResponderThread bv+ -- `E.catch` \e -> (unless (Quiet `elem` opts) $ getTimeStamp >>= \t -> printf "%s: rss2irc error: irc responder thread died with %s, restarting\n" t (show $ fromException e) >> hFlush stdout) -- | Disconnect from the irc server. disconnect :: Bot -> IO ()@@ -198,67 +251,110 @@ -- feed stuff --- | Poll the feed every interval minutes and announce any new items to irc.+-- | Poll the feed every interval minutes and send announceable items+-- to the announcer thread. ----- Here's the approach that seems most robust for now:--- Feeds are assumed to provide items sorted newest first.--- Announceable items are detected by taking unseen items from the top.--- "Seen" is implemented by keeping a rolling cache of likely-unique item ids.+-- Some smartness is needed to be robust with real-world feeds, which+-- may have jitter due to http caching, unreliable feed order,+-- unpredictable or missing item dates, etc. The most robust approach+-- seems to be: assume that feeds provide items sorted newest+-- first. Then, announceable items are the new (newer pub date than+-- the last announced item) and unseen (id not among the last N ids+-- seen since startup) items which appear at the top of the feed. This+-- is the default "topnew" strategy. We support some other strategies+-- which may be useful in some cases: "allnew" (announce new unseen+-- items appearing anywhere in the feed) and "top" (announce items+-- appearing about the previous top item, new or not). -- feedReaderThread :: Bot -> String -> IO () feedReaderThread b@(Bot{botopts=opts,outputqueue=q}) url = do when (iterations == Just 0) $ exitIterations unless (Quiet `elem` opts) $ printf "Polling %s every %s\n" url m >> hFlush stdout (is,polls,failedpolls) <- pollUntilFetchItems url delay opts 0 0 -- go no further until we have baseline items+ let seen = map itemId is recent = take (optIntValue Recent 0 opts) is announceable = reverse recent- (announcenow,toannounce) = splitAt maxitems announceable- numannounced = fromIntegral $ length announcenow+ announceable' = (if DupeDescriptions `elem` opts then id else elideDuplicateDescriptions) announceable+ lastpubdate = if null announceable' then Nothing else getItemPublishDate $ last announceable'+ numannounced = fromIntegral $ length announceable' when (DebugFeed `elem` opts) $ do getTimeStamp >>= printf ("\n%s: polled " ++ url ++ "\n")- printItemDetails "initial feed items, in feed order" is+ printItemDetails "feed items, in feed order" is printItemDetails "announceable items, oldest first" announceable printf "total polls, failed polls, items announced: %10d %10d %10d\n" polls failedpolls numannounced hFlush stdout- writeList2Chan q $ map (announce b) announcenow- go seen toannounce iterations numannounced polls failedpolls+ writeList2Chan q $ map (announcement b) announceable' + go seen lastpubdate iterations numannounced polls failedpolls+ where- go :: [String] -> [Item] -> Maybe Int -> Integer -> Integer -> Integer -> IO ()- go !seen !toannounce !iterationsleft !numannounced !polls !failedpolls = do+ go :: [String] -> Maybe String -> Maybe Int -> Integer -> Integer -> Integer -> IO ()+ go !seen !lastpubdate !iterationsleft !numannounced !polls !failedpolls = do when (iterationsleft == Just 0) $ exitIterations threadDelay delay when (DebugFeed `elem` opts) $ do getTimeStamp >>= \t -> printf "\n%s: polling %s\n" t url+ fetched <- fetchItems url opts let polls' = polls + 1 failedpolls' | isLeft fetched = failedpolls+1 | otherwise = failedpolls fetched' = either (const []) id fetched+ announcestrategy = optValue Announce defaultannouncestrategy opts+ isprevioustop = ((== head seen).itemId)+ isunseen = ((`notElem` seen).itemId)+ isnew = (`notOlderThan` lastpubdate)+ isnewunseen i = isnew i && isunseen i+ new = case announcestrategy of+ "top" -> takeWhile (not.isprevioustop) fetched'+ "allnew" -> filter isnewunseen fetched'+ _ -> takeWhile isnewunseen fetched' -- "topnew" seen' = take windowsize $ (map itemId new) ++ seen- new = takeWhile (not.(`elem` seen).itemId) fetched'- announceable = toannounce ++ reverse new- (announcenow,toannounce') = splitAt maxitems announceable- numannounced' = numannounced + (fromIntegral $ length announcenow)+ announceable = reverse new+ announceable' = (if DupeDescriptions `elem` opts then id else elideDuplicateDescriptions) announceable+ lastpubdate' = if null announceable' then lastpubdate else getItemPublishDate $ last announceable'+ numannounced' = numannounced + (fromIntegral $ length announceable') iterationsleft' = maybe Nothing (Just . pred) iterationsleft when (DebugFeed `elem` opts) $ do- printItemDetails "current feed items, in feed order" fetched'- printItemDetails "new unseen items, in feed order" new+ printItemDetails "feed items, in feed order" fetched' printItemDetails "announceable items, oldest first" announceable printf "total polls, failed polls, items announced: %10d %10d %10d\n" polls' failedpolls' numannounced' hFlush stdout- writeList2Chan q $ map (announce b) announcenow- go seen' toannounce' iterationsleft' numannounced' polls' failedpolls'+ writeList2Chan q $ map (announcement b) announceable' + go seen' lastpubdate' iterationsleft' numannounced' polls' failedpolls'+ iterations = numIterations opts exitIterations = unless (Quiet `elem` opts) (printf "Exiting after %d iterations.\n" (fromJust iterations)) >> exitWith ExitSuccess interval = optIntValue Interval defaultinterval opts m = if interval==1 then "minute" else show interval ++ " minutes" delay = interval * minutes- maxitems = optIntValue MaxItems defaultmaxitems opts windowsize = 200 +-- | Check if an item's publish date is older than another date.+-- Either date may be Nothing, a parseable date string or unparseable.+-- In the (likely) event we can't parse two dates, return True.+notOlderThan :: Item -> Maybe String -> Bool+notOlderThan _ Nothing = True+notOlderThan i (Just s1) =+ case getItemPublishDate i of+ Nothing -> True+ Just s2 -> case (parseDateTime s1, parseDateTime s2) of+ (Just d1, Just d2) -> d2 >= d1+ _ -> True++-- | Elide any identical consecutive item descriptions.+elideDuplicateDescriptions :: [Item] -> [Item]+elideDuplicateDescriptions = elidedupes Nothing+ where+ elidedupes :: Maybe String -> [Item] -> [Item]+ elidedupes _ [] = []+ elidedupes (Just lastdesc) (i:is)+ | getItemDescription i==Just lastdesc = [withItemDescription ditto i] ++ elidedupes (Just lastdesc) is+ where ditto = "''" -- or http://en.wikipedia.org/wiki/Ditto_mark : 〃+ elidedupes _ (i:is) = [i] ++ elidedupes (getItemDescription i) is+ -- | Get the best available unique identifier for a feed item. itemId :: Item -> String itemId i = case getItemId i of @@ -301,28 +397,29 @@ Just (XMLFeed _) -> noparse Just f -> return $ Right f where- noparse = fail "could not parse feed" -- fatal or not ? return $ Left + noparse = return $ Left "could not parse feed" -- | Fetch the contents of a uri, with redirects and authentication allowed, or an error string, -- or throw an IO error if the error looks permanent. Also show the http transaction progress--- as debug output if that option is in effect.+-- as debug output if that option is in effect. "file:..." uris are also allowed. readUri :: String -> [Opt] -> IO (Either String String)-readUri url opts = do- (_url',rsp) <- browse $ do- if (DebugHttp `elem` opts)- then setOutHandler (\s -> getTimeStamp >>= \t -> printf "\n%s: %s\n" t s)- else setOutHandler (const $ return ())- setAllowRedirects True- request $ getRequest url- case rspCode rsp of- (2,_,_) -> return $ Right $ rspBody rsp- code -> do- getTimeStamp >>= \t -> printf "%s: Error fetching %s: %s\n" t url (show code) >> hFlush stdout- case permanent code of- False -> return $ Left $ show code- True -> fail $ show code- where permanent c | c `elem` [(4,0,4)] = True -- http://en.wikipedia.org/wiki/List_of_HTTP_status_codes- | otherwise = False+readUri uri opts =+ case parseURI uri of+ Just URI{uriScheme="file:"} -> do+ Right `fmap` readFile (drop 5 uri)+ `catch` \e -> return $ Left $ show e+ _ -> do+ (_uri',rsp) <- browse $ do+ if (DebugHttp `elem` opts)+ then setOutHandler (\s -> getTimeStamp >>= \t -> printf "\n%s: %s\n" t s)+ else setOutHandler (const $ return ())+ setAllowRedirects True+ request $ getRequest uri+ case rspCode rsp of+ (2,_,_) -> return $ Right $ rspBody rsp+ code -> do+ getTimeStamp >>= \t -> printf "%s: rss2irc error fetching %s: %s\n" t uri (show code) >> hFlush stdout+ return $ Left $ show code -- | Dump item details to the console for debugging. printItemDetails :: String -> [Item] -> IO ()@@ -358,61 +455,143 @@ && match getItemEnclosure && match getItemId --- | Convert this item to an announcement string for the bot.-announce :: Bot -> Item -> String-announce (Bot{botopts=opts}) item = msg'+-- | Convert a feed item to a string for the bot to announce on irc.+-- The announcement is likely but not guaranteed to fit within a+-- single irc message.+announcement:: Bot -> Item -> String+announcement (Bot{botopts=opts}) i = applyReplacements opts $ printf "%s%s%s%s%s" title desc author date link where- msg' = applyReplacements opts msg- msg = printf "%s%s%s%s%s" title desc author date link- title = if elem NoTitle opts then "" else clean $ fromMaybe "" (getItemTitle item)- author = ifopt Author $ clean $ maybe "" ((" "++).parenthesise) (getItemAuthor item)- desc = ifopt Description $ oneline $ clean $ maybe "" (" - "++) (getItemDescription item)- date = ifopt Time $ maybe "" (" "++) (getItemDate item)- link = ifopt Link $ maybe "" (" "++) (getItemLink item)+ title = if elem NoTitle opts then "" else maybe "" (truncateWordsAt maxtitlelength "..." . clean) (getItemTitle i)+ desc = ifopt Description $ maybe "" ((" - "++) . truncateWordsAt maxdesclength "..." . clean) (getItemDescription i)+ author = ifopt Author $ maybe "" ((" "++) . parenthesise . truncateWordsAt maxauthorlength "..." . clean) (getItemAuthor i)+ date = ifopt Time $ maybe "" ((" "++) . truncateAt maxdatelength "..." . clean) (getItemDate i)+ link = ifopt Link $ maybe "" ((" "++) . truncateAt maxlinklength "..." . clean) (getItemLink i)++ clean = oneline . trimwhitespace . striphtml . stripemail ifopt o = if elem o opts then id else const ""- oneline = intercalate " " . lines- clean = striphtml . stripemail- striphtml = if elem Html opts then id else stripHtml+ oneline = intercalate " " . map strip . lines -- two spaces to hint at newlines & brs+ trimwhitespace = gsubRegexPR "[ \t][ \t]+" " "+ striphtml = if elem Html opts then id else stripHtml . brtonewline+ brtonewline = gsubRegexPR "(<|<) *br */?(>|>)" "\n" stripemail = if elem Email opts then id else stripEmails parenthesise = (++")").("("++) -- irc stuff --- | Print strings which appear in the bot's output queue to its irc channel,+-- | Wait for server connection confirmation.+ircWaitForServerResp :: Bot -> IO (Bool,String)+ircWaitForServerResp b@(Bot{socket=h,botopts=opts}) = do+ if (Debug `elem` opts)+ then return (True,"")+ else do+ s <- hGetLine h+ when (DebugIrc `elem` opts) $ getTimeStamp >>= \t -> printf "%s: <-%s\n" t s >> hFlush stdout+ if isping s then pong b s >> ircWaitForServerResp b else do+ if isResponseOK s then return (True, s) else+ if isNotice s then ircWaitForServerResp b else return (False, s) + where+ parseRespCode x = if length (words x) > 1 then (words x) !! 1 else "000" + isResponseOK x = (parseRespCode x) `elem` [ "001", "002", "003", "004" ]+ isNotice x = (head $ parseRespCode x) `elem` ('0':['a'..'z']++['A'..'Z'])+ +-- | Print announcements appearing in the bot's announce queue to its irc channel, -- complying with bot and irc server policies.-ircWriterThread :: Bot -> IO ()-ircWriterThread b@(Bot{outputqueue=q}) = forever $ do- -- simple policy: no more than one message per 2s, no more than 400 chars per message- msg <- readChan q- case splitAt maxmessagelength msg of- (s,[]) -> ircPrivmsgH b s- (s,rest) -> do unGetChan q ("..."++(reverse $ take 3 $ reverse s)++rest)- ircPrivmsgH b ((take (length s - 3) s) ++ "...")- threadDelay $ 2 * seconds+ircWriterThread :: SampleVar Bot -> Int -> IO ()+ircWriterThread bv batchindex = do+ b'@(Bot{outputqueue=q,botopts=opts}) <- readSampleVar bv+ writeSampleVar bv b'+ ann <- readChan q + -- policy:+ -- if specified, wait for --idle minutes of silence before sending messages+ -- no more than 400 chars per message+ -- no more than one message per 2s+ -- XXX on freenode, 6 such messages still cause a flood. Try limiting chars-per-period, or do a ping-pong+ -- no more than --max-items items per polling interval+ -- ditto for messages, except a final multi-message item will be completed.++ -- reread the samplevar to get an accurate idle time+ b <- readSampleVar bv+ writeSampleVar bv b+ idle <- channelIdleTime b++ let maxitems = optIntValue MaxItems defaultmaxitems opts+ requiredidle = optIntValue Idle defaultidle opts -- minutes+ pollinterval = optIntValue Interval defaultinterval opts -- minutes+ idleinterval = max (requiredidle-idle) 1 -- minutes+ sendinterval = if Debug `elem` opts then 0 else 2 -- seconds+ iscontinuation = continuationprefix `isPrefixOf` ann+ act | batchindex >= maxitems && not iscontinuation = (do+ when (DebugIrc `elem` opts) $+ getTimeStamp >>= \t -> printf "%s: sent %d messages in this batch, max is %d, sleeping for %dm\n" t batchindex maxitems pollinterval >> hFlush stdout+ threadDelay $ pollinterval * minutes+ ircWriterThread bv 0)+ | idle < requiredidle = (do+ when (DebugIrc `elem` opts) $+ getTimeStamp >>= \t -> printf "%s: channel has been idle %dm, %dm required, sleeping for %dm\n" t idle requiredidle idleinterval >> hFlush stdout+ unGetChan q ann+ threadDelay $ idleinterval * minutes+ ircWriterThread bv batchindex)+ | otherwise = (do+ when (DebugIrc `elem` opts) $+ getTimeStamp >>= \t -> printf "%s: sent %d messages in this batch and channel has been idle %dm, sending next\n" t batchindex idle >> hFlush stdout+ let (msg,rest) = splitAnnouncement ann+ unless (null rest) $ unGetChan q rest+ ircPrivmsgH b msg+ threadDelay $ sendinterval * seconds+ ircWriterThread bv (batchindex+1))+ act++-- | The time in minutes since the last message on this bot's channel, or+-- otherwise since joining the channel. Leap seconds are ignored.+channelIdleTime :: Bot -> IO Int+channelIdleTime (Bot{lastmsgtime=t1}) = do+ t <- getCurrentTime+ return $ round (diffUTCTime t t1) `div` 60+ -- | Handle any incoming commands from the bot's irc channel. -- The following commands are supported: PING.-ircResponderThread :: Bot -> IO ()-ircResponderThread b@(Bot{socket=h,botopts=opts}) = forever $ do+-- Also track the last message time.+ircResponderThread :: SampleVar Bot -> IO ()+ircResponderThread bv = do+ b@(Bot{socket=h,botopts=opts}) <- readSampleVar bv+ writeSampleVar bv b if (Debug `elem` opts)- then threadDelay $ 60 * minutes+ then threadDelay $ 1 * hours else do- s <- init `fmap` hGetLine h- when (DebugIrc `elem` opts) $ getTimeStamp >>= \t -> printf "%s: <-%s\n" t s- if isping s then pong s else return ()- where- isping x = "PING :" `isPrefixOf` x- pong x = ircWrite b $ "PONG :"++drop 6 x+ s <- hGetLine h+ let s' = init s+ when (DebugIrc `elem` opts) $ (getTimeStamp >>= \t -> printf "%s: <-%s\n" t s') >> hFlush stdout+ let respond | ismessage s = do t <- getCurrentTime+ writeSampleVar bv b{lastmsgtime=t}+ | isping s = pong b s'+ | otherwise = return ()+ respond+ ircResponderThread bv +ismessage :: String -> Bool+ismessage s = isprivmsg s && not ("VERSION" `elem` (msg_params $ fromJust $ decode s))++isprivmsg :: String -> Bool+isprivmsg s = case decode s of Just Message{msg_command="PRIVMSG"} -> True+ _ -> False++isping :: String -> Bool+isping s = case decode s of Just Message{msg_command="PING"} -> True+ _ -> False++pong :: Bot -> String -> IO ()+pong b x = ircWrite b $ printf "PONG :%s" (drop 6 x)+ -- | Send a privmsg to the bot's irc server & channel. ircPrivmsgH :: Bot -> String -> IO ()-ircPrivmsgH b@(Bot{channel=c}) msg = ircWrite b (printf "PRIVMSG %s :%s" c msg::String)+ircPrivmsgH b@(Bot{channel=c}) msg = ircWrite b $ encode $ privmsg c msg -- | Send a string to the bot's irc server unless --debug is in effect, -- and to the console if --debug-irc is in effect. ircWrite :: Bot -> String -> IO () ircWrite (Bot{socket=h,botopts=opts}) s = do- when (not $ Debug `elem` opts) $ hPrintf h "%s\r\n" s+ when (not $ Debug `elem` opts) $ hPrintf h (s++"\r\n") debugoutput where debugoutput@@ -422,6 +601,55 @@ -- utils +-- | Split an announcement into one or more suitably truncated and+-- formatted irc messages. Each call returns the next message and+-- the remainder of the announcement.+-- XXX n must be > length continuationsuffix+splitAnnouncement :: String -> (String,String)+splitAnnouncement a+ | length a <= maxmessagelength = (a,"")+ | otherwise =+ case splitAtWordBefore n a of+ (m,rest@(_:_)) -> (m++continuationsuffix, continuationprefix++rest)+ (m,"") -> (m, "")+ where+ n = maxmessagelength - length continuationsuffix++continuationprefix, continuationsuffix :: String+continuationprefix = "... "+continuationsuffix = " ..."++-- | Truncate a string, if possible at a word boundary, at or before+-- the specified position, and indicate truncation with the specified+-- suffix. The length of the returned string will be in the range+-- n, n+length suffix.+truncateWordsAt :: Int -> String -> String -> String+truncateWordsAt n suffix s+ | s' == s = s+ | otherwise = s' ++ suffix+ where+ s' = fst $ splitAtWordBefore n s++-- | Truncate a string at the specified position, and indicate+-- truncation with the specified suffix. The length of the returned+-- string will be in the range n, n+length suffix.+truncateAt :: Int -> String -> String -> String+truncateAt n suffix s+ | s' == s = s+ | otherwise = s' ++ suffix+ where+ s' = take n s++-- | Split a string at or before the specified position, on a word boundary if possible.+splitAtWordBefore :: Int -> String -> (String,String)+splitAtWordBefore n s+ | null a || (null b) = (rstrip a, lstrip b)+ | last a == ' ' || (head b == ' ') || (not $ ' ' `elem` a) = (rstrip a, lstrip b)+ | otherwise = (rstrip $ take (length a - length partialword) a, partialword ++ lstrip b)+ where (a,b) = splitAt n s+ partialword = reverse $ takeWhile (/= ' ') $ reverse a++ -- | Apply all --replace substitutions to a string, in turn. -- Warning, will fail at runtime if there is a bad regexp. applyReplacements :: [Opt] -> String -> String@@ -446,8 +674,8 @@ optIntValue oc def opts = fromMaybe def $ maybeRead $ optValue oc "" opts optValues :: (String -> Opt) -> [Opt] -> [String]-optValues oc opts = concatMap get opts- where get o = if oc v == o then [v] else [] where v = value o+optValues oc opts = concatMap getval opts+ where getval o = if oc v == o then [v] else [] where v = value o numIterations :: [Opt] -> Maybe Int numIterations opts = case optIntValue NumIterations (-1) opts of@@ -459,6 +687,24 @@ [(x, _)] -> Just x _ -> Nothing +-- | Parse a datetime string if possible, trying at least the formats+-- likely to be used in RSS/Atom feeds.+parseDateTime :: String -> Maybe UTCTime+parseDateTime s = firstJust [parseTime defaultTimeLocale f s' | f <- formats]+ where+ s' = adaptForParseTime s+ adaptForParseTime = gsubRegexPR "(....-..-..T..:..:..[\\+\\-]..):(..)" "\\1\\2" -- 2009-09-22T13:10:56+00:00+ formats = -- http://hackage.haskell.org/packages/archive/time/1.1.4/doc/html/Data-Time-Format.html#v%3AformatTime+ [+ "%a, %d %b %Y %T %z" -- Fri, 18 Sep 2009 12:42:07 -0400+ ,"%a, %d %b %Y %T %Z" -- Fri, 25 Sep 2009 11:01:23 UTC+ ,"%Y-%m-%dT%T%z" -- 2009-09-22T13:10:56+0000+ ]++firstJust :: [Maybe a] -> Maybe a+firstJust ms = case dropWhile isNothing ms of (m:_) -> m+ _ -> Nothing+ getCurrentLocalTime :: IO LocalTime getCurrentLocalTime = do t <- getCurrentTime@@ -478,6 +724,13 @@ -- strict :: NFData a => a -> a -- strict = id $| rnf -minutes, seconds :: Int+hours, minutes, seconds :: Int+hours = 60 * minutes minutes = 60 * seconds seconds = 10^(6::Int)++strip, lstrip, rstrip, dropws :: String -> String+strip = lstrip . rstrip+lstrip = dropws+rstrip = reverse . dropws . reverse+dropws = dropWhile (`elem` " \t")