rss2irc 0.4.2 → 1.0
raw patch · 6 files changed
+1073/−813 lines, 6 filesdep +bytestringdep +cabal-file-thdep +cmdargsdep −HTTPdep −extensible-exceptionsdep −haskell98dep ~basedep ~feeddep ~irc
Dependencies added: bytestring, cabal-file-th, cmdargs, containers, deepseq, http-conduit, http-types, io-storage, old-locale, parsec, safe, text, transformers, utf8-string
Dependencies removed: HTTP, extensible-exceptions, haskell98, mtl, parallel, strict-concurrency, tagsoup
Dependency ranges changed: base, feed, irc, network, split, time
Files
- Base.hs +151/−0
- Feed.hs +262/−0
- Irc.hs +195/−0
- Utils.hs +311/−0
- rss2irc.cabal +57/−89
- rss2irc.hs +97/−724
+ Base.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}+{- |++Types and settings.++Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011+License: BSD3.++-}++module Base where++import Control.Concurrent.Chan (Chan)+import Control.DeepSeq (NFData)+import Control.Exception+import Data.Time ()+import Data.Time.Clock+import Data.Typeable+import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion)+import System.Console.CmdArgs+import System.IO (Handle)+import Text.Feed.Types (Item)+import Text.Printf (printf)++ +progname = $(packageVariable (pkgName . package))+version = $(packageVariable (pkgVersion . package))+progversion = progname ++ " " ++ version :: String+defport = 6667+defusername = progname+defrealname = progname ++ " feed announcer"+definterval = 5+defidle = 0+defmaxitems = 5+maxmessagelength = 400+-- | Maximum size of each part of our irc announcements.+-- The max announcement length will be the sum of these, plus typically 15+-- due to prettification, plus any length increase due to --replace. The+-- defaults 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++progname, version, progversion, defusername, defrealname :: String+defport, definterval, defidle, defmaxitems, maxmessagelength, maxtitlelength,+ maxdesclength, maxauthorlength, maxdatelength, maxlinklength :: Int+defopts :: Opts++defopts = Opts {+ ident = defrealname &= typ "STR" &= help "set the bot's identity string (useful for contact info)"+ ,delay = def &= help "wait for N minutes before starting (helps avoid mass joins)"+ ,interval = definterval &= name "i" &= help ("polling and announcing interval in minutes (default "++(show definterval)++")")+ ,cache_control = def &= explicit &= name "cache-control" &= typ "STR" &= help ("set a HTTP cache-control header when polling")+ ,idle = defidle &= help ("announce only when channel has been idle N minutes (default "++(show defidle)++")")+ ,max_items = defmaxitems &= help ("announce at most N items per interval (default "++(show defmaxitems)++")")+ ,recent = def &= name "r" &= help "announce up to N recent items at startup (default 0)"+ ,ignore_ids_and_times = def &= help "ignore feed item IDs and timestamps (use for feeds with bad ones)"+ ,allow_duplicates = def &= help "turn off duplicate announcement protection (enabled by default)"+ ,use_actions = def &= help "use CTCP ACTIONs instead of normal IRC messages"+ ,no_title = def &= help ("don't show item title (shown by default, up to "++(show maxtitlelength)++" chars)")+ ,author = def &= name "a" &= help ("show author (up to "++(show maxauthorlength)++" chars)")+ ,description = def &= name "d" &= help ("show description (up to "++(show maxdesclength)++" chars)")+ ,link_ = def &= help ("show link URL (up to "++(show maxlinklength)++" chars)")+ ,time = def &= help ("show timestamp (up to "++(show maxdatelength)++" chars)")+ ,email = def &= help "show email addresses (stripped by default)"+ ,html = def &= help "show HTML tags and entities (stripped by default)"+ ,replace = def &= typ "OLD/NEW" &= help "replace OLD with NEW (regexpr patterns)"+ ,num_iterations = def &= name "n" &= help "exit after N iterations"+ ,quiet = def &= help "silence normal console output"+ ,debug_irc = def &= help "log irc activity"+ ,debug_feed = def &= help "log feed items and polling stats"+ ,debug_xml = def &= help "log feed content"+ ,feed = def &= argPos 0 &= typ "FEEDURL"+ ,irc_address = def &= argPos 1 &= opt ("" :: String) &= typ "IRCSERVER[:PORT]/CHANNEL/NICK"+ }+ &= program progname+ &= groupname progname+ &= summary progversion++data Opts = Opts {+ ident :: String+ ,delay :: Int+ ,interval :: Int+ ,cache_control :: String+ ,idle :: Int+ ,max_items :: Int+ ,recent :: Int+ ,ignore_ids_and_times :: Bool+ ,allow_duplicates :: Bool+ ,use_actions :: Bool+ ,no_title :: Bool+ ,author :: Bool+ ,description :: Bool+ ,link_ :: Bool+ ,time :: Bool+ ,email :: Bool+ ,html :: Bool+ ,replace :: [String]+ ,num_iterations :: (Maybe Int)+ ,quiet :: Bool+ ,debug_irc :: Bool+ ,debug_feed :: Bool+ ,debug_xml :: Bool+ ,feed :: String+ ,irc_address :: String+ } deriving (Show, Data, Typeable)++data Reader = Reader { iterationsleft :: !(Maybe Int)+ } deriving (Show)++data Bot = Bot { socket :: !Handle -- ^ the bot's active IRC connection, or stdout indicating none+ , server :: !String -- ^ the IRC server's hostname or IP address, or "" indicating none+ , port :: !Int -- ^ the IRC server's port number+ , channel :: !String -- ^ the IRC channel to join+ , botnick :: !String -- ^ the bot's IRC nickname+ , announcequeue :: !(Chan String) -- ^ a shared queue of messages to be announced+ , batchindex :: !Int -- ^ how many announcements have been made in the current batch+ , lastmsgtime :: !UTCTime -- ^ the last time somebody spoke on the IRC channel+ }+instance Show Bot where+ show Bot{socket=s,server=srv,port=p,channel=c,botnick=n,lastmsgtime=t} =+ printf "Bot{botnick=%s, socket=%s, server=%s, port=%d, channel=%s, lastmsgtime=%s}"+ n (show s) srv p c (show t)++-- | rss2irc's application state, shared by all threads.+data App = App {aOpts :: !Opts -- ^ initial command-line options+ ,aReader :: !Reader -- ^ the feed reader's state+ ,aBot :: !Bot -- ^ the irc bot's state+ } deriving (Show)++type FeedAddress = String++data FeedParseException = FeedParseException String deriving (Typeable)+instance Exception FeedParseException+instance Show FeedParseException where show (FeedParseException url) = printf "could not parse feed content from %s" url++data IrcAddress = IrcAddress {ircaddrServer :: !String,+ ircaddrPort :: !(Maybe Int),+ ircaddrChannel :: !String,+ ircaddrNick :: !String+ } deriving (Show)++data IrcException = IrcException String deriving (Typeable)+instance Exception IrcException+instance Show IrcException where show (IrcException msg) = printf "IRC error (%s)" msg++instance NFData Item+
+ Feed.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}+{- |++Feed stuff.++Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011+License: BSD3.++-}++module Feed where++import Control.Concurrent+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as LB8+import Data.Maybe+import Data.List+import System.IO.Storage+import Network.HTTP.Conduit (Request(requestHeaders),Response(responseBody),parseUrl,withManager,httpLbs)+import Network.HTTP.Types (hCacheControl)+import Network.URI+import Prelude hiding (log)+import Safe+import System.IO (stdout,hFlush)+import Text.Feed.Import+import Text.Feed.Query+import Text.Feed.Types+import Text.Printf (printf)+import Text.RegexPR++import Base+import Utils+++-- 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++-- | Poll the feed every interval minutes, ignoring transient IO+-- errors, detecting announceable items and sending them to the+-- announcer thread, forever or until the specified maximum number of+-- iterations is reached.+--+-- New item detection: this must be done carefully to avoid spamming+-- IRC users with useless messages. The content fetched from real-world+-- feeds may jitter due to http caching, unstable item ordering,+-- unpredictable or missing item dates, etc. We support several strategies:+--+-- - @topnew@: announce new unseen items at the top.+-- In more detail: 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 at the top of the feed. This is the default strategy,+-- best for most feeds.+--+-- - @allnew@: announce new unseen items appearing anywhere in the feed.+-- Good for feeds with unreliable item ordering, or to notice the items of+-- feeds newly added to a planet (aggregator).+--+-- - @top@: announce items appearing above the previous top item, new or not.+-- Good for feeds not ordered by date, eg a darcs repo's.++-- XXX none of these work for announcing recent-but-not-newest items from a blog added to a planet+feedReader :: Shared App -> IO ()+feedReader !appvar = do+ -- first poll - prime the pump+ app@App{aOpts=opts@Opts{feed=url}, aReader=Reader{iterationsleft=numleft}, aBot=Bot{announcequeue=q}} <- getSharedVar appvar+ case numleft of+ Just 0 -> return ()+ _ -> do+ unless (quiet opts) $ log $ printf "Polling %s %s" url (everyMinutesString $ interval opts)+ fetched <- fetchItems url opts+ let polls = 1+ -- with --recent N, send last N (non-duplicate) items to announcer thread+ let unique = (if allow_duplicates opts then id else (elideDuplicates [])) fetched+ announceable = take (recent opts) unique+ numannounced = fromIntegral $ length announceable+ writeList2Chan q $ map (toAnnouncement opts) $ reverse announceable+ when (debug_feed opts) $ logPoll fetched announceable polls numannounced+ -- start iterating+ let seen = map (\i -> (itemId i, fromMaybe "" $ getItemTitle i)) fetched+ lastpubdate = maybe Nothing getItemPublishDate $ headMay unique+ putSharedVar appvar $ maybeDecrementIterationsLeft app+ feedReaderPoll appvar polls seen lastpubdate numannounced++feedReaderPoll :: Shared App -> Integer -> [(String,String)] -> Maybe String -> Integer -> IO ()+feedReaderPoll !appvar !polls !seen !lastpubdate !numannounced = do+ -- second & subsequent polls - wait interval then look for new items+ app@App{aOpts=opts@Opts{feed=url}, aReader=Reader{iterationsleft=numleft}, aBot=Bot{announcequeue=q}} <- getSharedVar appvar+ case numleft of+ Just 0 -> return ()+ _ -> do+ threadDelay $ (interval opts) * minutes+ when (debug_feed opts) $ log $ printf "polling %s" url+ fetched <- fetchItems url opts+ -- detect announceable items+ let seenids = map fst seen+ hasunseenid = (`notElem` seenids).itemId+ hasnewerdate = (`isNewerThan` lastpubdate).getItemPublishDate+ isunseenandnewer i = hasnewerdate i && hasunseenid i+ isprevioustop = (== head seenids).itemId+ announceable = (if allow_duplicates opts then id else (elideDuplicates seen)) $+ reverse $+ (if ignore_ids_and_times opts then takeWhile (not . isprevioustop)+ else filter isunseenandnewer) $+ fetched+ -- send to announcer thread and iterate+ writeList2Chan q $ map (toAnnouncement opts) announceable+ let polls' = polls + 1+ seen' = take windowsize $ (map (\i -> (itemId i, fromMaybe "" $ getItemTitle i)) fetched)+ ++ seen where windowsize = 200+ lastpubdate' = maybe lastpubdate getItemPublishDate $ headMay announceable+ numannounced' = numannounced + fromIntegral (length announceable)+ putSharedVar appvar $ maybeDecrementIterationsLeft app+ when (debug_feed opts) $ logPoll fetched announceable polls' numannounced'+ feedReaderPoll appvar polls' seen' lastpubdate' numannounced'++maybeDecrementIterationsLeft :: App -> App+maybeDecrementIterationsLeft app@App{aReader=reader@Reader{iterationsleft=n}} =+ app{aReader=reader{iterationsleft=decrementMaybe n}}++-- | Log debug info for a poll.+logPoll :: [Item] -> [Item] -> Integer -> Integer -> IO ()+logPoll fetched announceable polls numannounced = do+ printItemDetails "feed items, in feed order" fetched+ printItemDetails "announceable items, oldest first" announceable+ _ <- printf "successful consecutive polls, items announced: %10d %10d\n" polls numannounced+ hFlush stdout++-- | Fetch a feed's items, or the empty list in case of transient IO+-- errors (and log those).+fetchItems :: FeedAddress -> Opts -> IO [Item]+fetchItems url opts =+ feedItems `fmap` readFeed url opts+ `catches` [+ Handler $ \(e :: IOException) -> handleIOError e,+ Handler $ \(e :: FeedParseException) -> handleIOError e+ ]+ where+ handleIOError e = do+ log $ printf "Error (%s), retrying %s" (show e) (inMinutesString $ interval opts)+ return []++-- | Fetch and parse a feed's content, or raise an exception.+readFeed :: FeedAddress -> Opts -> IO Feed+readFeed url opts = do+ s <- readUri url opts+ when (debug_xml opts) $ log $ labelledText (printf "FEED CONTENT FROM %s " url) s+ case parseFeedString s of+ Nothing -> throwIO $ FeedParseException url+ Just (XMLFeed _) -> throwIO $ FeedParseException url+ Just f -> return f++-- | Fetch the contents of a uri, which must be an ascii string.+-- Redirects, authentication, https: and file: uris are supported.+readUri :: String -> Opts -> IO String+readUri s opts =+ case parseURI' s of+ Just URI{uriScheme="file:",uriPath=f} -> readFeedFile f+ Just _ -> do+ r <- parseUrl s+ let cachecontrol = cache_control opts+ r' | null cachecontrol = r+ | otherwise = r{requestHeaders=(hCacheControl, B8.pack cachecontrol):requestHeaders r}+ rsp <- withManager (httpLbs r')+ return $ LB8.unpack $ responseBody rsp+ Nothing -> opterror $ "could not parse URI: " ++ s++-- | Parse a string to a URI, ensuring a simple filename is assigned the file: scheme.+parseURI' :: String -> Maybe URI+parseURI' s =+ case parseURIReference s of+ Just u -> Just $ u `relativeTo` nullURI{uriScheme="file:",uriPath="."}+ Nothing -> Nothing++-- | A hacky stateful readFile to assist testing: this reads one or+-- more concatenated copies of the feed from the file and returns one+-- on each call, or the empty string when there are none left.+-- Reads from stdin if the file path is "-".+readFeedFile :: FilePath -> IO String+readFeedFile f = do+ v <- getValue "globals" "feedfile"+ case v of+ Nothing -> do+ s <- case f of "-" -> getContents+ _ -> readFile f+ let (first:rest) = splitFeedCopies s+ putValue "globals" "feedfile" rest+ return first+ Just (first:rest) -> do+ putValue "globals" "feedfile" rest+ return first+ Just [] -> return ""+ where+ splitFeedCopies = initDef [""] . map (++"</feed>\n") . splitRegexPR "(?i)</(feed|rdf:RDF)\n? *>\n*"++-- | Check if the first date is newer than the second, where dates (from+-- feed items) can be Nothing, a parseable date string or unparseable. In+-- the (likely) event we can't parse two dates, return True.+isNewerThan :: Maybe String -> Maybe String -> Bool+isNewerThan _ Nothing = True+isNewerThan Nothing _ = True+isNewerThan (Just s2) (Just s1) =+ case (parseDateTime s2, parseDateTime s1) of+ (Just d2, Just d1) -> d2 > d1+ _ -> True++-- | Remove any items from the list which duplicate another item in+-- this or the second list (the last N fetched items), where+-- "duplicates" means "would generate a similar irc message", ie it+-- has the same item title. This is a final de-duplication pass before+-- announcing on irc.+elideDuplicates :: [(String,String)] -> [Item] -> [Item]+elideDuplicates seen new =+ filter (\a -> not $ fromMaybe "" (getItemTitle a) `elem` seentitles) $+ nubBy (\a b -> getItemTitle a == getItemTitle b)+ new+ where+ seentitles = map snd seen++-- | 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++-- | 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 "" :: String 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+ ]+
+ Irc.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}+{- |++IRC stuff++Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011+License: BSD3.++-}++module Irc where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.List+import Data.Maybe+import Data.Time.Clock (getCurrentTime,diffUTCTime)+import Network (PortID(PortNumber), connectTo)+import Network.IRC (Message(Message),msg_command,msg_params,decode,encode,nick,user,joinChan,privmsg)+import Prelude hiding (log)+import System.IO (BufferMode(NoBuffering),stdout,hSetBuffering,hFlush,hClose,hGetLine,hPutStr)+import Text.Printf++import Base+import Utils+++-- | Connect to the irc server.+connect :: App -> IO App+connect !app@App{aOpts=opts, aBot=bot@Bot{server=srv,port=p,channel=c,botnick=n}} = do+ unless (quiet opts) $+ log $ n ++ " connecting to " +++ (if null srv then "(simulated)" else printf "%s, channel %s" srv c)+ bot' <- if null srv+ then return bot+ else do+ h <- connectTo srv (PortNumber $ fromIntegral p)+ hSetBuffering h NoBuffering+ return bot{socket=h}+ ircWrite opts bot' $ encode $ nick n+ ircWrite opts bot' $ encode $ user defusername "0" "*" (ident opts)+ (connected,err) <- if null srv then return (True,"")+ else ircWaitForConnectConfirmation opts bot' -- some servers require this+ unless connected $ throw $ IrcException err+ ircWrite opts bot' $ encode $ joinChan c+ unless (quiet opts) $ log "connected."+ return app{aBot=bot'}++-- | Disconnect from the irc server, if connected.+disconnect :: App -> IO ()+disconnect App{aBot=Bot{server=srv,socket=s}}+ | s == stdout = return ()+ | otherwise = log (printf "disconnecting from %s" srv) >> hClose s++-- | Wait for server connection confirmation.+ircWaitForConnectConfirmation :: Opts -> Bot -> IO (Bool,String)+ircWaitForConnectConfirmation _ Bot{server=""} = return (True,"")+ircWaitForConnectConfirmation !opts !bot@Bot{socket=h} = do+ s <- hGetLine h+ when (debug_irc opts) $ log $ printf "<-%s" s+ if isPing s+ then ircPong opts bot s >> ircWaitForConnectConfirmation opts bot+ else if isResponseOK s+ then return (True, chomp s)+ else if isNotice s+ then ircWaitForConnectConfirmation opts bot+ else return (False, chomp 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'])++{-+2011-10-18 13:28:20 PDT: <-PING :niven.freenode.net+2011-10-18 13:28:20 PDT: ->PONG niven.freenode.net+hGetIRCLine :: Handle -> IO MsgString Read an IRC message string.+hGetMessage :: Handle -> IO Message Read the next valid IRC message.+hPutCommand :: Handle -> Command -> IO () Write an IRC command with no origin.+hPutMessage :: Handle -> Message -> IO () Write an IRC message.+-}+-- | Run forever, responding to irc PING commands to keep the bot connected.+-- Also keeps track of the last time a message was sent, for --idle.+ircResponder :: Shared App -> IO ()+ircResponder !appvar = do+ app@App{aOpts=opts,aBot=bot@Bot{server=srv,socket=h}} <- getSharedVar appvar+ if null srv+ then threadDelay (maxBound::Int)+ else do+ s <- hGetLine h+ let s' = init s+ when (debug_irc opts) $ log $ printf "<-%s" s'+ let respond | isMessage s = do t <- getCurrentTime+ putSharedVar appvar app{aBot=bot{lastmsgtime=t}}+ | isPing s = ircPong opts bot s'+ | otherwise = return ()+ respond+ ircResponder appvar++-- | Run forever, printing announcements appearing in the bot's announce+-- queue to its irc channel, complying with bot and irc server policies.+-- Specifically:+--+-- - no messages until --idle minutes of silence on the channel+--+-- - no more than 400 chars per message+--+-- - no more than one message per 2s+--+-- - no more than --max-items feed items announced per polling interval+--+-- - no more than --max-items messages per polling interval, except a+-- final item split across multiple messages will be completed.++-- XXX On freenode, six 400-char messages in 2s can still cause a flood.+-- Try limiting chars-per-period, or do ping-pong ?+ircAnnouncer :: Shared App -> IO ()+ircAnnouncer !appvar = do+ -- wait for something to announce+ App{aBot=Bot{announcequeue=q}} <- getSharedVar appvar+ ann <- readChan q+ -- re-read bot to get an up-to-date idle time+ app@App{aOpts=opts, aBot=bot@Bot{server=srv,batchindex=i}} <- getSharedVar appvar+ idletime <- channelIdleTime bot+ let batchsize = max_items opts+ requiredidle = idle opts -- minutes+ pollinterval = interval opts -- minutes+ sendinterval = if null srv then 0 else 2 -- seconds+ iscontinuation = continuationprefix `isPrefixOf` ann+ go | i >= batchsize && not iscontinuation = do+ -- reached max batch size, sleep+ when (debug_irc opts) $+ log $ printf "sent %d messages in this batch, max is %d, sleeping for %dm" i batchsize pollinterval+ threadDelay $ pollinterval * minutes+ unGetChan q ann+ putSharedVar appvar app{aBot=bot{batchindex=0}}+ ircAnnouncer appvar+ | requiredidle > 0 && (idletime < requiredidle) = do+ -- not yet at required idle time, sleep+ let idleinterval = requiredidle - idletime+ when (debug_irc opts) $ log $+ printf "channel has been idle %dm, %dm required, sleeping for %dm" idletime requiredidle idleinterval+ threadDelay $ idleinterval * minutes+ unGetChan q ann+ ircAnnouncer appvar+ | otherwise = do+ -- ok, announce it+ when (debug_irc opts) $ do+ let s | requiredidle == 0 = "" :: String+ | otherwise = printf " and channel has been idle %dm" idletime+ log $ printf "sent %d messages in this batch%s, sending next" i s+ let (a,rest) = splitAnnouncement ann+ when (not $ null rest) $ unGetChan q rest+ ircPrivmsg opts bot a+ threadDelay $ sendinterval * seconds+ putSharedVar appvar app{aBot=bot{batchindex=i+1}}+ ircAnnouncer appvar+ go++-- | 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++-- IRC utils++-- | Send a response to the irc server's ping.+ircPong :: Opts -> Bot -> String -> IO ()+ircPong opts b x = ircWrite opts b $ printf "PONG :%s" (drop 6 x)++-- | Send a privmsg to the bot's irc server & channel, and to stdout unless --quiet is in effect.+ircPrivmsg :: Opts -> Bot -> String -> IO ()+ircPrivmsg opts bot@(Bot{channel=c}) msg = do+ ircWrite opts bot $ encode $ privmsg c msg+ unless (quiet opts) $ putStrLn msg >> hFlush stdout++-- | Send a message to the bot's irc server, and log to the console if --debug-irc is in effect.+ircWrite :: Opts -> Bot -> String -> IO ()+ircWrite opts (Bot{server=srv,socket=h}) s = do+ when (debug_irc opts) $ log $ printf "->%s" s -- (B8.unpack $ showCommand c)+ unless (null srv) $ hPutStr h (s++"\r\n")++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+
+ Utils.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}+{- |++Common utilities.++Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011+License: BSD3.++-}++module Utils (+ module Utils,+ module Debug.Trace+ )+where+import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)+import Control.Concurrent+import Control.Monad+import Data.List+import Data.Maybe+import Data.Time.Clock (UTCTime,getCurrentTime)+import Data.Time.Format (parseTime)+import Data.Time.LocalTime (LocalTime,getCurrentTimeZone,utcToLocalTime)+import Prelude hiding (log)+import System.Info+import System.IO (stdout,hFlush)+import System.Locale (defaultTimeLocale)+import Text.Feed.Query+import Text.Feed.Types (Item)+import Text.ParserCombinators.Parsec hiding (label)+import Text.Printf (printf)+import Text.RegexPR (splitRegexPR,gsubRegexPR)++import Base++import Debug.Trace+-- | trace a showable expression+strace :: Show a => a -> a+strace a = trace (show a) a+-- | labelled trace - like strace, with a label prepended+ltrace :: Show a => String -> a -> a+ltrace l a = trace (l ++ ": " ++ show a) a+-- | monadic trace - like strace, but works as a standalone line in a monad+mtrace :: (Monad m, Show a) => a -> m a+mtrace a = strace a `seq` return a+-- | trace an expression using a custom show function+tracewith :: (a -> String) -> a -> a+tracewith f e = trace (f e) e+++-- Light abstraction layer for thread-safe mutable data++type Shared a = SampleVar a++newSharedVar :: a -> IO (SampleVar a)+newSharedVar = newSampleVar++getSharedVar :: SampleVar a -> IO a+getSharedVar v = do+ x <- readSampleVar v+ writeSampleVar v x+ return x++putSharedVar :: SampleVar a -> a -> IO ()+putSharedVar v x = writeSampleVar v x++-- Option parsing helpers++ircAddressFromOpts :: Opts -> Maybe IrcAddress+ircAddressFromOpts Opts{irc_address=""} = Nothing+ircAddressFromOpts Opts{irc_address=a} = Just $ parseIrcAddress a++parseIrcAddress :: String -> IrcAddress+parseIrcAddress a =+ either (\e -> opterror $ printf "could not parse IRC address \"%s\"\n%s\n" a (show e))+ id+ $ parse ircaddrp "" a+ where+ ircaddrp = choice' $ [+ do+ -- pre 0.5 syntax: [irc://]NICK@IRCSERVER[:PORT]/[#]CHANNEL+ optional $ choice' $ map string ["irc://", "irc:"]+ n <- many1 $ noneOf "@"+ char '@'+ s <- many1 $ noneOf ":/"+ p <- optionMaybe $ char ':' >> read `fmap` many1 digit >>= return+ char '/'+ optional $ char '#'+ c <- many1 $ noneOf "/ \t"+ eof+ return $ IrcAddress s p ('#':c) n+ ,+ do+ -- new easier syntax: [irc://]IRCSERVER[:PORT]/[#]CHANNEL/NICK+ optional $ choice' $ map string ["irc://", "irc:"]+ s <- many1 $ noneOf ":/"+ p <- optionMaybe $ char ':' >> read `fmap` many1 digit >>= return+ char '/'+ optional $ char '#'+ c <- many1 $ noneOf "/"+ char '/'+ n <- many1 $ noneOf "/ \t"+ eof+ return $ IrcAddress s p ('#':c) n+ ]++-- | A version of error' that suggests --help.+opterror :: String -> a+opterror = error' . (++ " (see --help for usage)")++-- | A version of error that's better at displaying unicode.+error' :: String -> a+error' = error . toPlatformString++-- | 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.+toAnnouncement:: Opts -> Item -> String+toAnnouncement opts i = applyReplacements opts $ printf "%s%s%s%s%s" title desc author' date link'+ where+ title = unlessopt no_title $ 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 o opts then id else const ""+ unlessopt o = if not $ o opts then id else const ""+ oneline = intercalate " " . map strip . lines -- two spaces to hint at newlines & brs+ trimwhitespace = gsubRegexPR "[ \t][ \t]+" " "+ striphtml = if html opts then id else stripHtml . brtonewline+ brtonewline = gsubRegexPR "(<|<) *br */?(>|>)" "\n"+ stripemail = if email opts then id else stripEmails+ parenthesise = (++")").("("++)++-- | 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 :: Opts -> String -> String+applyReplacements opts = foldl' (.) id (reverse substitutions)+ where substitutions = map replaceOptToSubst $ replace opts + replaceOptToSubst 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(>|>)?" ""++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+ [(x, _)] -> Just x+ _ -> Nothing++decrementMaybe :: Enum a => Maybe a -> Maybe a+decrementMaybe = maybe Nothing (Just . pred)++-- | 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++-- | Grammatically correct "every N minutes".+everyMinutesString :: Int -> String+everyMinutesString 1 = "every minute"+everyMinutesString i = "every " ++ show i ++ " minutes"++-- | Grammatically correct "in N minutes".+inMinutesString :: Int -> String+inMinutesString 1 = "in 1 minute"+inMinutesString i = "in " ++ show i ++ " minutes"++-- | Log some text to the console with a timestamp.+log :: String -> IO ()+log s = do+ t <- getTimeStamp+ putStrLn $ printf "%s: %s" t s+ hFlush stdout++-- | Decorate some multi-line text with a label and start/end separators.+labelledText :: String -> String -> String+labelledText label s = printf "========== %s:\n%s\n=============================================\n" label s++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)++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")++chomp :: String -> String+chomp = reverse . dropWhile (`elem` "\n\r") . reverse++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++-- platform strings++-- | A platform string is a string value from or for the operating system,+-- such as a file path or command-line argument (or environment variable's+-- name or value ?). On some platforms (such as unix) these are not real+-- unicode strings but have some encoding such as UTF-8. This alias does+-- no type enforcement but aids code clarity.+type PlatformString = String++-- | Convert a possibly encoded platform string to a real unicode string.+-- We decode the UTF-8 encoding recommended for unix systems+-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)+-- and leave anything else unchanged.+fromPlatformString :: PlatformString -> String+fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s++-- | Convert a unicode string to a possibly encoded platform string.+-- On unix we encode with the recommended UTF-8+-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)+-- and elsewhere we leave it unchanged.+toPlatformString :: String -> PlatformString+toPlatformString = case os of+ "unix" -> UTF8.encodeString+ "linux" -> UTF8.encodeString+ "darwin" -> UTF8.encodeString+ _ -> id++-- | Backtracking choice, use this when alternatives share a prefix.+-- Consumes no input if all choices fail.+choice' :: [GenParser tok st a] -> GenParser tok st a+choice' = choice . map Text.ParserCombinators.Parsec.try+
rss2irc.cabal view
@@ -1,114 +1,82 @@ name: rss2irc-version: 0.4.2+version: 1.0 homepage: http://hackage.haskell.org/package/rss2irc license: BSD3 license-file: LICENSE author: Don Stewart <dons@galois.com>, Simon Michael <simon@joyful.com> maintainer: Simon Michael <simon@joyful.com>-category: Network+category: IRC synopsis: watches an RSS/Atom feed and writes 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 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- .- For example, to announce Hackage updates:- .- > rss2irc http://hackage.haskell.org/packages/archive/recent.rss mybot@irc.freenode.org/#haskell- .- Release notes for 0.4.2, 2009-09-27:- .- * fix a bug where every --max-items-th announcement was skipped- .- Release notes for 0.4.1, 2009-09-26:- .- * fix release notes issues- .- Release notes for 0.4, 2009-09-26:- .- * 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+ rss2irc is an IRC bot that polls an RSS or Atom feed and announces updates to an+ IRC channel, with options for customizing output and behavior.+ It aims to be an easy-to-use, reliable, well-behaved bot. .- * 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.+ Usage: @rss2irc FEEDURL [BOTNAME\@IRCSERVER/#CHANNEL] [OPTS]@ .- * 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.+ For example, to announce Hackage uploads (like hackagebot): .- * --idle option, waits for N minutes of channel idle time before announcing+ > $ rss2irc http://hackage.haskell.org/packages/archive/recent.rss mybot@irc.freenode.org/#haskell .- * 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.+ 1.0 (2013/2/15) .- * misc. 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+ New:++ * more robust item detection and duplicate announcement protection, with simpler options+ * easier irc address syntax, drop -p/--port option+ * can poll urls with semicolon parameter separator (eg darcsweb's)+ * can poll https feeds+ * can poll from stdin (-)+ * can poll a file containing multiple copies of a feed (eg for testing)+ * can announce item urls containing percent+ * `--cache-control` option sets a HTTP Cache-Control header+ * `--use-actions` announces with CTCP ACTIONs (like the /me command) .- * logging improvements+ Fixed: .- * --delay now takes minutes, not seconds+ * updated for GHC 7.6 & current libs+ * initialises http properly on microsoft windows+ * builds threaded and optimised by default+ * thread and error handling is more robust, eg don't ignore exceptions in the irc writer thread+ * no longer adds stray "upload:" to IRC messages+ * renamed --dupe-descriptions to `--allow-duplicates`+ * dropped --debug flag+ * new item detection and announcing is more robust+ * announcements on console are clearer+ * a simulated irc connection is not logged unless --debug-irc is used .-stability: experimental-tested-with: GHC==6.8, GHC==6.10++stability: beta+tested-with: GHC==7.6.1 cabal-version: >= 1.6 build-type: Simple executable rss2irc main-is: rss2irc.hs- ghc-options: -Wall -fno-warn-orphans+ other-modules: Base, Utils, Feed, Irc+ ghc-options: -O2 -threaded -Wall -fno-warn-orphans -fno-warn-unused-do-bind build-depends:- 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,- 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+ base >= 4 && < 5+ ,bytestring+ ,cabal-file-th+ ,cmdargs+ ,containers+ ,deepseq+ ,irc >= 0.5 && < 0.6+ ,feed >= 0.3.8 && < 0.4+ ,http-conduit >= 1.8 && < 1.9+ ,http-types >= 0.6.4 && < 0.9+ ,io-storage >= 0.3 && < 0.4+ ,network >= 2.4 && < 2.5+ ,old-locale+ ,parsec+ ,regexpr >= 0.5 && < 0.6+ ,safe >= 0.2 && < 0.4+ ,split >= 0.2 && < 0.3+ ,text == 0.11.*+ ,transformers >= 0.2 && < 0.4+ ,time >= 1.1 && < 1.5+ ,utf8-string source-repository head type: darcs
rss2irc.hs view
@@ -1,737 +1,110 @@-{-# LANGUAGE PatternGuards,BangPatterns #-}+#!/usr/bin/env runhaskell+{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-} ----------------------------------------------------------------------- |--- 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---+{- |+rss2irc - watches an RSS/Atom feed and writes it to an IRC channel.++Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011+License: BSD3.+-} -------------------------------------------------------------------- -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,isNothing)-import Data.Time.Clock (UTCTime,getCurrentTime,diffUTCTime)-import Data.Time.Format (parseTime)-import Data.Time.LocalTime (LocalTime,getCurrentTimeZone,utcToLocalTime)-import Locale (defaultTimeLocale)-import Network (PortID(PortNumber), connectTo)-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- ,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+module Main where -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+import Control.Concurrent+import Control.Exception+import Control.Monad (when,unless)+import Data.Maybe+import Data.Time.Clock (getCurrentTime)+import Prelude hiding (log)+import Network (withSocketsDo)+import System.Console.CmdArgs+import System.Exit (ExitCode(ExitSuccess), exitFailure, exitSuccess)+import System.IO+import System.IO.Storage+import Text.Printf (printf) -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 minutes before starting (helps avoid mass joins)"- ,Option ['i'] ["interval"] (ReqArg Interval "N") ("polling interval in minutes (default "++(show defaultinterval)++")")- ,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 ['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 (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"- ,Option [] ["debug-http"] (NoArg DebugHttp) "show feed fetching progress"- ]+import Base+import Utils+import Feed+import Irc -help :: IO a-help = do- putStrLn "Usage: rss2irc FEEDURL [BOTNAME@IRCSERVER/#CHANNEL] [OPTS]"- 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}- | Announce {value::String}- | Idle {value::String}- | Author- | Description- | Time- | Link- | NoTitle- | Email- | Html- | DupeDescriptions- | 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- , botnick :: String- , botopts :: ![Opt]- , outputqueue :: Chan String- , lastmsgtime :: UTCTime+-- | Get parsed and checked options and a reader and bot ready to connect.+getRss2IrcArgs :: IO (Opts, Reader, Bot)+getRss2IrcArgs = do+ opts <- cmdArgs defopts >>= \opts -> do+ unless (interval opts > 0 || (maybe False (<=10) $ num_iterations opts)) $+ opterror "--interval 0 requires --num-iterations 10 or less"+ seq (applyReplacements opts "") $ return () -- report any bad --replace regexp+ return opts+ q <- newChan+ t <- getCurrentTime+ let reader = Reader{iterationsleft=num_iterations opts+ }+ bot = Bot{socket = stdout+ ,server = ""+ ,port = defport+ ,channel = ""+ ,botnick = ""+ ,announcequeue = q+ ,batchindex = 0+ ,lastmsgtime = t }--instance NFData Item+ bot' = case ircAddressFromOpts opts of+ Nothing -> bot+ Just (IrcAddress s p c n) ->+ bot{server = s+ ,port = fromMaybe defport p+ ,channel = c+ ,botnick = n+ }+ return (opts, reader, bot') +-- | Process arguments, join the irc channel, start worker threads,+-- disconnect and report when there is a problem. main :: IO ()-main = do- (opts, args, errs) <- getOpt Permute options `fmap` getArgs- let delay = optIntValue Delay 0 opts- interval = optIntValue Interval defaultinterval opts- 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 * 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- , botnick = n- , botopts = opts- , outputqueue = q- , lastmsgtime = t- })- _ -> help- [f] -> return (f, Bot{ socket = stdout- , server = ""- , port = 0- , channel = ""- , 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)- where - 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@(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'---- | Given a connected bot, start various threads to poll and announce,--- restarting them if they fail.-run :: Bot -> String -> IO ()-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 ()-disconnect b | Debug `elem` (botopts b) = return ()-disconnect b = hClose $ socket b---- feed stuff---- | Poll the feed every interval minutes and send announceable items--- to the announcer thread.------ 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- 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 "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 (announcement b) announceable'-- go seen lastpubdate iterations numannounced polls failedpolls-- where- 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- 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 "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 (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- 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 - 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 = 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. "file:..." uris are also allowed.-readUri :: String -> [Opt] -> IO (Either String String)-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 ()-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 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- 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 " " . 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---- | 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 :: 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- 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- unGetChan q ann- threadDelay $ pollinterval * minutes- ircWriterThread bv 0)- | requiredidle > 0 && (idle < requiredidle) = (do- let idleinterval = requiredidle-idle- 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%s, sending next\n" t batchindex (if requiredidle == 0 then "" else printf " and channel has been idle %dm" 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.--- 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 $ 1 * hours- else do- 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 $ 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")- 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---- | 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-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 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- (-1) -> Nothing- n -> Just n--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of- [(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- 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+main =+ withSocketsDo $ -- for ms windows+ withStore "globals" $ do -- for readFeedFile+ (opts,reader,bot) <- getRss2IrcArgs+ let app = App{aOpts=opts,aReader=reader,aBot=bot}+ when (delay opts > 0) $ threadDelay $ (delay opts) * minutes+ runThreads app --- strict :: NFData a => a -> a--- strict = id $| rnf+runThreads :: App -> IO ()+runThreads app@App{aOpts=opts} = do+ -- catch any termination or error in sub-threads and handle it here+ r <- try $ bracket (connect app) disconnect $ \a -> do+ appvar <- newSharedVar a+ -- 1. the feed reader thread polls forever or until it reaches max+ -- iterations or raises a non-transient exception+ _ <- forkMonitoredIO $ feedReader appvar+ -- 2. the irc announcer runs until it raises an exception or is killed+ _ <- forkMonitoredIO $ ircAnnouncer appvar+ -- 3. the main thread becomes the irc responder, keeping the+ -- connection alive until it raises or receives an exception+ ircResponder appvar+ -- exit after an exception+ preExitDelay+ case r of+ Right _ -> unless (quiet opts) (log "normal termination.") >> exitSuccess -- shouldn't happen+ Left e | Just ExitSuccess <- fromException e -> unless (quiet opts) (log "normal termination") >> exitSuccess+ Left e -> unless (quiet opts) (putStr "\n" >> log (show e)) >> exitFailure -hours, minutes, seconds :: Int-hours = 60 * minutes-minutes = 60 * seconds-seconds = 10^(6::Int)+-- | Spawn a thread which will throw any exception or termination (as+-- ExitSuccess) to us. Also log error exceptions.+forkMonitoredIO :: IO () -> IO ThreadId+forkMonitoredIO action = do+ me <- myThreadId+ forkIO $ do+ ex <- action >> return (toException ExitSuccess)+ `catch` \e ->+ case fromException e of+ Just ExitSuccess -> return e+ _ -> log (printf "Error: %s" (show (e::SomeException))) >> return e+ throwTo me ex -strip, lstrip, rstrip, dropws :: String -> String-strip = lstrip . rstrip-lstrip = dropws-rstrip = reverse . dropws . reverse-dropws = dropWhile (`elem` " \t")+-- hack: give announcer a chance to announce items from final poll+preExitDelay :: IO ()+preExitDelay = threadDelay $ 500000