rss2irc 0.2 → 0.3
raw patch · 4 files changed
+547/−228 lines, 4 filesdep +HTTPdep +extensible-exceptionsdep +regexprdep ~basedep ~feeddep ~mtlnew-uploader
Dependencies added: HTTP, extensible-exceptions, regexpr, split, time
Dependency ranges changed: base, feed, mtl, network, parallel, strict-concurrency, tagsoup
Files
- LICENSE +2/−2
- Main.hs +0/−201
- rss2irc.cabal +62/−25
- rss2irc.hs +483/−0
LICENSE view
@@ -1,5 +1,5 @@-Copyright (c) 2008 Don Stewart-+Copyright (c) 2008, 2009 Don Stewart, 2009 Simon Michael+ All rights reserved. Redistribution and use in source and binary forms, with or without
− Main.hs
@@ -1,201 +0,0 @@-{-# LANGUAGE PatternGuards #-}------------------------------------------------------------------------ |--- Module: Subscribe to an RSS feed and write it to an IRC channel--- Copyright : (c) Don Stewart, 2008--- License : BSD3------ Maintainer: Don Stewart <dons@galois.com>--- Stability : provisional--- Portability:--------------------------------------------------------------------------import System.Environment-import System.IO-import System.Exit-import Data.Char-import Data.List-import Data.Maybe--import Text.HTML.Download-import Text.HTML.TagSoup--import Text.Feed.Import-import Text.RSS.Syntax-import Text.Feed.Types--import Control.Monad.Reader-import Control.Monad-import qualified Control.Exception as C-import Control.Concurrent.Chan.Strict-import Control.Concurrent (forkIO,threadDelay)-import qualified Control.Parallel.Strategies as Par (NFData(..))--import System.Console.GetOpt-import Text.Printf-import Network----------------------------------------------------------------------------type Net = ReaderT Bot IO--data Bot = Bot { socket :: Handle- , server :: String- , port :: !Int- , channel :: String- , nick :: String- , links :: !Bool- }--{--server = "irc.freenode.org"-port = 6667-chan = "#arch-haskell"-nick = "archrss"--}--data Flag = Links deriving Eq--main :: IO ()-main = do- (flags, args, errs) <- getOpt Permute [Option ['l'] ["links"] (NoArg Links) "include link URLs"] `fmap` getArgs- when (not . null $ errs) help- let l = Links `elem` flags- (st, feed, prefix) <- case args of- [s,p,c,n,f,z] | Just intp <- maybeRead p ->- return (Bot { socket = stdout- , server = s- , port = intp- , channel = c- , nick = n- , links = l }- ,f, z)-- _ -> help-- C.bracket (connect st)- (hClose . socket)- (\st' -> C.catch- (runReaderT (run feed prefix) st')- (const $ return ()))------- connect to the server----connect :: Bot -> IO Bot-connect st = notify $ do- h <- connectTo (server st) (PortNumber (fromIntegral (port st)))- hSetBuffering h NoBuffering- return st { socket = h }- where- notify a = C.bracket_- (printf "Connecting to %s ... " (server st) >> hFlush stdout)- (putStrLn "done.")- a------- We're in the Net monad now, so we've connected successfully--- Join a channel, and start processing commands----run :: String -> String -> Net ()-run feed prefix = do- n <- asks nick- c <- asks channel- h <- asks socket- l <- asks links-- write "NICK" n- write "USER" (n++" 0 * :rss2irc gateway")- write "JOIN" c-- -- run RSS thread- -- main thread just listens on commands- liftIO $ forkIO $ reader c h l feed prefix- listen h------- handle commands from the channel----listen :: Handle -> Net ()-listen h = forever $ do- s <- init `fmap` io (hGetLine h)- io (putStrLn s)- if ping s then pong s else return () -- (io . print) (clean s)- where--- clean = drop 1 . dropWhile (/= ':') . drop 1- ping x = "PING :" `isPrefixOf` x- pong x = write "PONG" (':' : drop 6 x)--------------------------------------------------------------------------------- wait on an RSS thread, updating every 60 minutes.----reader :: String -> Handle -> Bool -> String -> String -> IO ()-reader c h l url prefix = go []- where- go old = do- RSSFeed f <- (fromJust . parseFeedString) `fmap` openURL url- let new = nubBy k . rssItems . rssChannel $ f- diff = (foldl' (flip (deleteBy k)) new old)-- forM_ (take 5 diff) $ \item -> do- case rssItemTitle item of- Nothing -> return ()- Just t -> privmsgH h c $ prefix ++ t ++ if l then linkText else ""- where linkText = maybe "" (" " ++) (rssItemLink item)-- threadDelay (60 * minutes)- go new-- seconds = 10^6- minutes = 60 * seconds-- k x y = let a = fromJust $ rssItemTitle x- b = fromJust $ rssItemTitle y- in a == b -- title--instance Par.NFData RSSItem----------------------------------------------------------------------------io :: IO a -> Net a-io = liftIO------- Send a privmsg to the current chan + server----privmsg :: String -> Net ()-privmsg s = do- h <- asks socket- c <- asks channel- io $ privmsgH h c s--write :: String -> String -> Net ()-write s t = do- h <- asks socket- io $ hWrite h s t------- Send a message out to the server we're currently connected to----hWrite :: Handle -> String -> String -> IO ()-hWrite h s t = do- hPrintf h "%s %s\r\n" s t- printf "> %s %s\n" s t---privmsgH :: Handle -> String -> String -> IO ()-privmsgH h c s = hWrite h "PRIVMSG" (c ++ " :" ++ s)----------------------------------------------------------------------------help = do- putStrLn "rss2irc [--links] <server> <port> <channel> <nick> <feed-url> <msg-prefix>"- exitWith ExitSuccess--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of- [(x, _)] -> Just x- _ -> Nothing
rss2irc.cabal view
@@ -1,33 +1,70 @@ name: rss2irc-version: 0.2-homepage: http://code.haskell.org/~dons/code/rss2irc+version: 0.3+homepage: http://hackage.haskell.org/package/rss2irc license: BSD3 license-file: LICENSE-author: Don Stewart-maintainer: dons@galois.com+author: Don Stewart <dons@galois.com>, Simon Michael <simon@joyful.com>+maintainer: Simon Michael <simon@joyful.com> category: Network-synopsis: Subscribe to an RSS feed and write it to an IRC channel-description: Subscribe to an RSS feed and write it to an IRC channel- .- Example, announce Hackage updates in channel:- .- > rss2irc irc.freenode.org 6667 #zid39kd3 rss2irc http://hackage.haskell.org/packages/archive/recent.rss "New package: "- .-cabal-version: >= 1.2-build-type: Simple+synopsis: Watch an RSS/Atom feed and write it to an IRC channel+description: + This bot polls a single RSS or Atom feed and announces updates to an+ IRC channel, with options for customizing output and behavior. It+ 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)+ > 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)+ > -i N --interval=N polling interval in minutes (default 5)+ > -r N --recent=N announce up to N recent items at startup (default 0)+ > -m N --max-items=N announce at most N items per polling interval (default 5)+ > --no-title don't show title (title is announced by default)+ > -a --author show author+ > -d --description show description+ > -l --link show link URL+ > -t --time show timestamp+ > -e --email show email addresses (these are stripped by default)+ > -h --html show HTML tags and entities (these are stripped 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+ > --debug-irc show irc activity+ > --debug-feed show feed items and polling stats+ > --debug-xml show feed content+ > --debug-http show feed fetching progress+ .+ For example, to announce Hackage updates:+ .+ > rss2irc irc.freenode.org '#haskell' mybot http://hackage.haskell.org/packages/archive/recent.rss -flag small_base- description: Choose the new smaller, split-up base package.+stability: experimental+tested-with: GHC==6.8, GHC==6.10+cabal-version: >= 1.6+build-type: Simple executable rss2irc- main-is: Main.hs+ main-is: rss2irc.hs+ ghc-options: -Wall -fno-warn-orphans+ build-depends:+ base >= 3 && < 5,+ extensible-exceptions >= 0.1 && < 0.2,+ feed >= 0.3 && < 0.4,+ HTTP >= 4000.0.3 && < 4000.1,+ mtl >= 1.1 && < 1.2,+ network >= 2.2 && < 2.3,+ parallel >= 1.1 && < 1.2,+ regexpr >= 0.5 && < 0.6,+ split >= 0.1 && < 0.2,+ strict-concurrency >= 0.2 && < 0.3,+ tagsoup >= 0.6 && < 0.7,+ time >= 1.1 && < 1.2 - build-depends: feed,- tagsoup,- strict-concurrency,- mtl,- network- if flag(small_base)- build-depends: base >= 3, parallel- else- build-depends: base < 3+source-repository head+ type: darcs+ location: http://joyful.com/repos/rss2irc
+ rss2irc.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE PatternGuards,BangPatterns #-}+--------------------------------------------------------------------+-- |+-- Module: Watch an RSS/Atom feed and write it to an IRC channel+-- Copyright : (c) Don Stewart 2008-2009, Simon Michael 2009+-- License : BSD3+-- More info : rss2irc.cabal+--+--------------------------------------------------------------------++import Control.Concurrent (forkIO,threadDelay)+import Control.Concurrent.Chan (Chan,newChan,writeList2Chan,readChan,unGetChan)+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.Time.LocalTime (LocalTime,getCurrentTimeZone,utcToLocalTime)+import Network.HTTP (Response,getRequest,rspBody,rspCode)+import Network.Browser (browse,request,setAllowRedirects,setOutHandler)+import Network (PortID(PortNumber), connectTo)+import qualified Control.Exception.Extensible as E (bracket,bracket_,catch,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.Query (feedItems+ ,getItemTitle+ ,getItemLink+ ,getItemPublishDate+ ,getItemDate+ ,getItemAuthor+ ,getItemCommentLink+ ,getItemEnclosure+ ,getItemFeedLink+ ,getItemId+ ,getItemCategories+ ,getItemRights+ ,getItemSummary+ ,getItemDescription+ )+import Text.Feed.Types (Feed(XMLFeed),Item)+import Text.Printf (printf,hPrintf)+import Text.RegexPR (splitRegexPR,gsubRegexPR)+-- import Debug.Trace+-- 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++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 ['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 ['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 [] ["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-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"+ ,Option [] ["debug-http"] (NoArg DebugHttp) "show feed fetching progress"+ ]++help :: IO a+help = do+ putStrLn "Usage: rss2irc [OPTS] FEEDURL [irc://]BOTNAME@IRCSERVER/#CHANNEL"+ putStrLn " or: rss2irc [OPTS] FEEDURL (same as --debug)"+ putStrLn "Options:"+ putStrLn (usageInfo "" options)+ exitWith ExitSuccess++data Opt =+ Port {value::String}+ | Ident {value::String}+ | Delay {value::String}+ | Interval {value::String}+ | MaxItems {value::String}+ | Recent {value::String}+ | Author+ | Description+ | Time+ | Link+ | NoTitle+ | Email+ | Html+ | Replace {value::String}+ | NumIterations {value::String}+ | Quiet+ | Debug+ | DebugHttp+ | DebugXml+ | DebugFeed+ | DebugIrc+ deriving (Eq, Show)++data Bot = Bot { socket :: Handle+ , server :: String+ , port :: !Int+ , channel :: String+ , nick :: String+ , botopts :: ![Opt]+ , outputqueue :: Chan String+ }++instance NFData Item++main :: IO ()+main = do+ (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."]+ 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++ q <- newChan+ (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+ , botopts = opts+ , outputqueue = q+ })+ _ -> help+ [f] -> return (f, Bot{ socket = stdout+ , server = ""+ , port = 0+ , channel = ""+ , nick = ""+ , botopts = Debug:opts+ , outputqueue = q+ })+ _ -> help++ E.bracket+ (connect bot)+ (disconnect)+ (\b -> run b feed `E.catch` exit b)+ 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++-- | 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})++-- | Join a channel, and start processing commands.+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++-- | Disconnect from the irc server.+disconnect :: Bot -> IO ()+disconnect b | Debug `elem` (botopts b) = return ()+disconnect b = hClose $ socket b++-- feed stuff++-- | Poll the feed every interval minutes and announce any new items to irc.+--+-- 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.+--+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+ when (DebugFeed `elem` opts) $ do+ getTimeStamp >>= printf ("\n%s: polled " ++ url ++ "\n")+ printItemDetails "initial 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++ where+ go :: [String] -> [Item] -> Maybe Int -> Integer -> Integer -> Integer -> IO ()+ go !seen !toannounce !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+ 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)+ 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 "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'++ 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++-- | Get the best available unique identifier for a feed item.+itemId :: Item -> String+itemId i = case getItemId i of + Just (_,s) -> s+ Nothing -> case getItemTitle i of+ Just s -> s+ Nothing -> case getItemDate i of+ Just s -> s+ Nothing -> show i++-- | Like fetchItems, but if it fails with a transient error, keep+-- retrying at the specified interval. Returns a tuple of items, poll+-- and failed poll counts, or throws an IO error.+pollUntilFetchItems :: String -> Int -> [Opt] -> Integer -> Integer -> IO ([Item],Integer,Integer)+pollUntilFetchItems url delay opts polls failedpolls = do+ is <- fetchItems url opts+ case is of Right is' -> return (is',polls+1,failedpolls)+ Left _ -> do+ threadDelay delay+ pollUntilFetchItems url delay opts (polls+1) (failedpolls+1)++-- | Get the items from the feed at the specified url, with redirects+-- and authentication allowed, or an error string, or throw an IO+-- error if the error looks permanent.+fetchItems :: String -> [Opt] -> IO (Either String [Item])+fetchItems url opts = either Left (Right . feedItems) `fmap` readFeed url opts++-- | Fetch a feed, with redirects and authentication allowed, or an error string,+-- or throw an IO error if the error looks permanent. Also show the raw content+-- as debug output if that option is in effect.+readFeed :: String -> [Opt] -> IO (Either String Feed)+readFeed url opts = do+ s <- readUri url opts+ case s of Left e -> return $ Left e+ Right s' -> do+ when (DebugXml `elem` opts) $ do+ getTimeStamp >>= \t -> printf "\n%s: feed content:\n%s\n" t s'+ case parseFeedString s' of+ Nothing -> noparse+ Just (XMLFeed _) -> noparse+ Just f -> return $ Right f+ where+ noparse = fail "could not parse feed" -- fatal or not ? return $ Left ++-- | 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.+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++-- | Dump item details to the console for debugging.+printItemDetails :: String -> [Item] -> IO ()+printItemDetails hdr is = printf "%s: %d\n%s" hdr count items >> hFlush stdout+ where+ items = unlines [printf " %-29s%s %-*s" d p twidth t | (d,p,t,_) <- fields]+ twidth = maximum $ map (length.fromMaybe "".getItemTitle) is+ -- subhdr = "(date, (publish date if different), title)\n"+ -- subhdr' = if null is then "" else subhdr+ count = length is+ fields = [(d, if p==d then "" else printf " pubdate:%-29s" p, t, i) | item <- is+ ,let d = fromMaybe "" $ getItemDate item+ ,let p = fromMaybe "" $ getItemPublishDate item+ ,let t = fromMaybe "" $ getItemTitle item+ ,let i = maybe "" show $ getItemId item+ ]++-- deriving instance Eq Item+instance Eq Item where+ (==) a b = let match f = f a == f b in+ all match [getItemTitle+ ,getItemLink+ ,getItemPublishDate+ ,getItemDate+ ,getItemAuthor+ ,getItemCommentLink+ ,getItemFeedLink+ ,getItemRights+ ,getItemSummary+ ,getItemDescription+ ]+ && match getItemCategories+ && match getItemEnclosure+ && match getItemId++-- | Convert this item to an announcement string for the bot.+announce :: Bot -> Item -> String+announce (Bot{botopts=opts}) item = msg'+ 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)+ 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+ 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,+-- 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++-- | 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+ if (Debug `elem` opts)+ then threadDelay $ 60 * minutes+ 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++-- | 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)++-- | 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+ debugoutput+ where+ debugoutput+ | DebugIrc `elem` opts = getTimeStamp >>= \t -> printf "%s: ->%s\n" t s >> hFlush stdout+ | not (Quiet `elem` opts) && ("PRIVMSG" `isPrefixOf` s) = (printf "%s\n" $ drop 1 $ dropWhile (/=':') s) >> hFlush stdout+ | otherwise = return ()++-- utils++-- | Apply all --replace substitutions to a string, in turn.+-- Warning, will fail at runtime if there is a bad regexp.+applyReplacements :: [Opt] -> String -> String+applyReplacements opts = foldl' (.) id (reverse substitutions)+ where substitutions = map make $ optValues Replace opts+ make s = case splitRegexPR "(?<!\\\\)/" s of+ (pat:sub:[]) -> gsubRegexPR pat sub+ _ -> id++-- | Replace any HTML tags or entities in a string with a single space.+stripHtml :: String -> String+stripHtml = gsubRegexPR "(&[^ \t]*?;|<.*?>)" " "++-- | Remove any email addresses from a string.+stripEmails :: String -> String+stripEmails = gsubRegexPR "(?i) ?(<|<)?\\b[-._%+a-z0-9]+@[-.a-z0-9]+\\.[a-z]{2,4}\\b(>|>)?" ""++optValue :: (String -> Opt) -> String -> [Opt] -> String+optValue oc def = head . optValues oc . (++[oc def])++optIntValue :: (String -> Opt) -> Int -> [Opt] -> Int+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++numIterations :: [Opt] -> Maybe Int+numIterations opts = case optIntValue NumIterations (-1) opts of+ (-1) -> Nothing+ n -> Just n++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+ [(x, _)] -> Just x+ _ -> Nothing++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+ t <- getCurrentTime+ tz <- getCurrentTimeZone+ return $ utcToLocalTime tz t++getTimeStamp :: IO String+getTimeStamp = do+ t <- getCurrentLocalTime+ tz <- getCurrentTimeZone+ return $ printf "%s %s" (take 19 $ show t) (show tz)++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++-- strict :: NFData a => a -> a+-- strict = id $| rnf++minutes, seconds :: Int+minutes = 60 * seconds+seconds = 10^(6::Int)