diff --git a/Base.hs b/Base.hs new file mode 100644 --- /dev/null +++ b/Base.hs @@ -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 + diff --git a/Feed.hs b/Feed.hs new file mode 100644 --- /dev/null +++ b/Feed.hs @@ -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 (++"\n") . splitRegexPR "(?i)\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 + ] + diff --git a/Irc.hs b/Irc.hs new file mode 100644 --- /dev/null +++ b/Irc.hs @@ -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 + diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 "(? 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 + diff --git a/rss2irc.cabal b/rss2irc.cabal --- a/rss2irc.cabal +++ b/rss2irc.cabal @@ -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 , Simon Michael maintainer: Simon Michael -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 diff --git a/rss2irc.hs b/rss2irc.hs --- a/rss2irc.hs +++ b/rss2irc.hs @@ -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 "(? 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