diff --git a/Base.hs b/Base.hs --- a/Base.hs +++ b/Base.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} +-- DeriveGeneric, StandaloneDeriving {- | Types and settings. @@ -10,27 +11,29 @@ module Base where -import Control.Concurrent.Chan (Chan) -import Control.DeepSeq (NFData) +import Control.Concurrent.STM (TChan) +-- import Control.DeepSeq (NFData) import Control.Exception import Control.Monad.IO.Class (MonadIO, liftIO) +-- import GHC.Generics import Data.Time () import Data.Time.Clock import Data.Typeable -import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion) import Network.HTTP.Conduit (Manager) import System.Console.CmdArgs import System.IO (Handle) -import Text.Feed.Types (Item) +-- import Text.Feed.Types import Text.Printf (printf) -progname = $(packageVariable (pkgName . package)) -version = $(packageVariable (pkgVersion . package)) +progname = "rss2irc" +version = "1.1" -- sync with rss2irc.cabal progversion = progname ++ " " ++ version :: String defport = 6667 defusername = progname defrealname = progname ++ " feed announcer" +defuseragent :: String +defuseragent = progversion definterval = 5 defidle = 0 defmaxitems = 5 @@ -53,6 +56,7 @@ defopts = Opts { ident = defrealname &= typ "STR" &= help "set the bot's identity string (useful for contact info)" + ,uagent = defuseragent &= typ "STR" &= help "set the bot's Http UserAgent string " ,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") @@ -84,6 +88,7 @@ data Opts = Opts { ident :: String + ,uagent :: String ,delay :: Int ,interval :: Int ,cache_control :: String @@ -121,7 +126,7 @@ , 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 + , announcequeue :: !(TChan 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 } @@ -152,7 +157,8 @@ instance Exception IrcException instance Show IrcException where show (IrcException msg) = printf "IRC error (%s)" msg -instance NFData Item +-- deriving instance Generic Item +-- instance NFData Item io :: MonadIO m => IO a -> m a io = liftIO diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,11 @@ +1.1 (2016/11/1) + +* update for GHC 8, stackage lts-7 +* allow latest http-client, http-conduit, resourcet, network, transformers, text; drop cabal-file-th +* update to irc 0.6 (warning: probably not unicode-safe) +* use STM's TChan, fixing warnings and possibly hangs +* use safer MSampleVar, possibly fixing hangs + 1.0.6 (2014/4/13) * minimal changes to build with feed 0.3.9.* and other libs in current Debian unstable (sid) @@ -6,19 +14,19 @@ * avoid feed 0.3.9.2 which has changed its API -1.0.4 +1.0.4 (2013/9/5) * fix compilation with GHC 7.4 (Fabien Andre) -1.0.3 +1.0.3 (2013/2/22) * fix http-conduit usage so the feed poller doesn't die within hours -1.0.2 +1.0.2 (2013/2/18) * `--use-actions` works again -1.0.1 +1.0.1 (2013/2/15) * fix release notes formatting on hackage diff --git a/Feed.hs b/Feed.hs --- a/Feed.hs +++ b/Feed.hs @@ -10,7 +10,8 @@ module Feed where -import Control.Concurrent +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.Trans.Resource (ResourceT, runResourceT) @@ -20,7 +21,7 @@ import Data.List import System.IO.Storage import Network.HTTP.Conduit -import Network.HTTP.Types (hCacheControl) +import Network.HTTP.Types (hCacheControl, hUserAgent) import Network.URI import Prelude hiding (log) import Safe @@ -178,11 +179,12 @@ Just _ -> do -- LB8.unpack `fmap` simpleHttp s -- http-conduit is complex, cf https://github.com/snoyberg/http-conduit/issues/97 - r <- parseUrl s + r <- parseUrlThrow s let cachecontrol = cache_control opts r' | null cachecontrol = r | otherwise = r{requestHeaders=(hCacheControl, B8.pack cachecontrol):requestHeaders r} - rsp <- httpLbs r' manager + r'' = r'{requestHeaders=(hUserAgent, B8.pack $ uagent opts):requestHeaders r'} + rsp <- httpLbs r'' manager return $ LB8.unpack $ responseBody rsp Nothing -> opterror $ "could not parse URI: " ++ s @@ -264,3 +266,7 @@ ,let i = maybe "" show $ getItemId item ] +writeList2Chan :: TChan a -> [a] -> IO () +writeList2Chan q as = do + atomically $ forM as $ \a -> writeTChan q a + return () diff --git a/Irc.hs b/Irc.hs --- a/Irc.hs +++ b/Irc.hs @@ -10,14 +10,16 @@ module Irc where -import Control.Concurrent +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.ByteString.Char8 as B8 (pack, unpack) 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 Network.IRC (Message(Message),msg_command,msg_params,decode,encode,joinChan,privmsg) import Prelude hiding (log) import System.IO (BufferMode(NoBuffering),stdout,hSetBuffering,hFlush,hClose,hGetLine,hPutStr) import Text.Printf @@ -38,12 +40,12 @@ 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) + ircWrite opts bot' n + ircWrite opts bot' $ if null (ident opts) then defusername else 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 + ircWrite opts bot' $ B8.unpack $ encode $ joinChan $ B8.pack c unless (quiet opts) $ log "connected." return app{aBot=bot'} @@ -118,7 +120,7 @@ ircAnnouncer !appvar = do -- wait for something to announce App{aBot=Bot{announcequeue=q}} <- getSharedVar appvar - ann <- readChan q + ann <- atomically $ readTChan 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 @@ -132,7 +134,7 @@ 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 + atomically $ unGetTChan q ann putSharedVar appvar app{aBot=bot{batchindex=0}} ircAnnouncer appvar | requiredidle > 0 && (idletime < requiredidle) = do @@ -141,7 +143,7 @@ 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 + atomically $ unGetTChan q ann ircAnnouncer appvar | otherwise = do -- ok, announce it @@ -150,7 +152,7 @@ | 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 + when (not $ null rest) $ atomically $ unGetTChan q rest ircPrivmsg opts bot a threadDelay $ sendinterval * seconds putSharedVar appvar app{aBot=bot{batchindex=i+1}} @@ -173,7 +175,7 @@ -- | 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' + ircWrite opts bot $ B8.unpack $ encode $ privmsg (B8.pack c) (B8.pack msg') unless (quiet opts) $ putStrLn msg >> hFlush stdout where msg' | use_actions opts = "\1ACTION " ++ msg ++ "\1" @@ -186,13 +188,13 @@ unless (null srv) $ hPutStr h (s++"\r\n") isMessage :: String -> Bool -isMessage s = isPrivmsg s && not ("VERSION" `elem` (msg_params $ fromJust $ decode s)) +isMessage s = isPrivmsg s && not ("VERSION" `elem` (maybe [] msg_params $ decode $ B8.pack s)) isPrivmsg :: String -> Bool -isPrivmsg s = case decode s of Just Message{msg_command="PRIVMSG"} -> True - _ -> False +isPrivmsg s = case decode $ B8.pack 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 +isPing s = case decode $ B8.pack s of Just Message{msg_command="PING"} -> True + _ -> False diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +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. + +Usage: `rss2irc [OPTIONS] FEEDURL [IRCSERVER[:PORT]/[#]CHANNEL/NICK]` + +Example: + + $ rss2irc http://hackage.haskell.org/packages/archive/recent.rss irc.freenode.net/mychannel/mybot + +Known limitations: + +- If the feed goes down for a while and then comes back up, the bot may re-announce all items. + +- Memory is leaked on each poll, causing rss2irc bots to consume more memory over time. + This will be more noticeable when feeds have large content and are polled frequently. + Restarting rss2irc bots daily is recommended. diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -14,17 +14,17 @@ ) where import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) -import Control.Concurrent +import Control.Concurrent.MSampleVar import Control.Monad import Data.List import Data.Maybe import Data.Time.Clock (UTCTime,getCurrentTime) -import Data.Time.Format (parseTime) +import Data.Time.Format (parseTimeM) import Data.Time.LocalTime (LocalTime,getCurrentTimeZone,utcToLocalTime) import Prelude hiding (log) import System.Info import System.IO (stdout,hFlush) -import System.Locale (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) import Text.Feed.Query import Text.Feed.Types (Item) import Text.ParserCombinators.Parsec hiding (label) @@ -50,19 +50,19 @@ -- Light abstraction layer for thread-safe mutable data -type Shared a = SampleVar a +type Shared a = MSampleVar a -newSharedVar :: a -> IO (SampleVar a) -newSharedVar = newSampleVar +newSharedVar :: a -> IO (MSampleVar a) +newSharedVar = newSV -getSharedVar :: SampleVar a -> IO a +getSharedVar :: MSampleVar a -> IO a getSharedVar v = do - x <- readSampleVar v - writeSampleVar v x + x <- readSV v + writeSV v x return x -putSharedVar :: SampleVar a -> a -> IO () -putSharedVar v x = writeSampleVar v x +putSharedVar :: MSampleVar a -> a -> IO () +putSharedVar v x = writeSV v x -- Option parsing helpers @@ -211,7 +211,7 @@ -- | 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] +parseDateTime s = firstJust [parseTimeM True defaultTimeLocale f s' | f <- formats] where s' = adaptForParseTime s adaptForParseTime = gsubRegexPR "(....-..-..T..:..:..[\\+\\-]..):(..)" "\\1\\2" -- 2009-09-22T13:10:56+00:00 @@ -268,10 +268,10 @@ strip = lstrip . rstrip lstrip = dropws rstrip = reverse . dropws . reverse -dropws = dropWhile (`elem` " \t") +dropws = dropWhile (`elem` (" \t"::String)) chomp :: String -> String -chomp = reverse . dropWhile (`elem` "\n\r") . reverse +chomp = reverse . dropWhile (`elem` ("\n\r"::String)) . reverse isLeft :: Either a b -> Bool isLeft (Left _) = True diff --git a/rss2irc.cabal b/rss2irc.cabal --- a/rss2irc.cabal +++ b/rss2irc.cabal @@ -1,5 +1,6 @@ name: rss2irc -version: 1.0.6 +-- also set version in Base.hs +version: 1.1 homepage: http://hackage.haskell.org/package/rss2irc license: BSD3 license-file: LICENSE @@ -18,39 +19,47 @@ > $ rss2irc http://hackage.haskell.org/packages/archive/recent.rss mybot@irc.freenode.org/#haskell stability: beta -tested-with: GHC==7.6.3 -cabal-version: >= 1.6 +tested-with: GHC==8.0 +cabal-version: >= 1.10 build-type: Simple -extra-source-files: CHANGES +extra-source-files: + CHANGES + README.md + stack.yaml + executable rss2irc main-is: rss2irc.hs other-modules: Base, Utils, Feed, Irc + default-language: Haskell2010 ghc-options: -threaded -Wall -fno-warn-orphans -fno-warn-unused-do-bind build-depends: base >= 4 && < 5 + ,SafeSemaphore >= 0.10 && < 1.1 ,bytestring - ,cabal-file-th ,cmdargs ,containers ,deepseq - ,irc >= 0.5 && < 0.6 - ,feed >= 0.3.9 && < 0.3.10 - ,http-client >= 0.2.1 && < 0.2.3 - ,http-conduit >= 1.9 && < 2.1 - ,resourcet >= 0.4.4 && < 0.5 - ,http-types >= 0.6.4 && < 0.9 + ,irc >= 0.6 && < 0.7 + ,feed >= 0.3.9 && < 0.4 + ,http-client >= 0.2.1 && < 0.5 + ,http-conduit >= 1.9 && < 2.2 + ,resourcet >= 0.4.4 && < 1.2 + ,http-types >= 0.6.4 && < 1.0 ,io-storage >= 0.3 && < 0.4 - ,network >= 2.4 && < 2.5 + ,network >= 2.6 && < 2.7 + ,network-uri >= 2.6 && < 2.7 ,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 + ,stm >= 2.1 && < 3.0 + ,text >= 0.11 && < 1.3 + ,transformers >= 0.2 && < 0.6 + ,time >= 1.5 && < 1.7 ,utf8-string + ,SafeSemaphore source-repository head type: darcs diff --git a/rss2irc.hs b/rss2irc.hs --- a/rss2irc.hs +++ b/rss2irc.hs @@ -12,6 +12,7 @@ module Main where import Control.Concurrent +import Control.Concurrent.STM import Control.Exception import Control.Monad (when,unless) import Data.Maybe @@ -40,7 +41,7 @@ opterror "--interval 0 requires --num-iterations 10 or less" seq (applyReplacements opts "") $ return () -- report any bad --replace regexp return opts - q <- newChan + q <- atomically $ newTChan t <- getCurrentTime let reader = Reader{httpManager=Nothing ,iterationsleft=num_iterations opts diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,10 @@ +resolver: lts-7.7 + +packages: +- '.' + +#flags: {} + +extra-deps: +- mtlparse-0.1.4.0 +- regexpr-0.5.4