{-# LANGUAGE PatternGuards #-}
--------------------------------------------------------------------
-- |
-- Module: Subscribe to an RSS feed and write it to an IRC channel
-- Copyright : (c) Don Stewart, 2008
-- License : BSD3
--
-- Maintainer: Don Stewart <dons@galois.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------
import System.Environment
import System.IO
import System.Exit
import Data.Char
import Data.List
import Data.Maybe
import Text.HTML.Download
import Text.HTML.TagSoup
import Text.Feed.Import
import Text.RSS.Syntax
import Text.Feed.Types
import Control.Monad.Reader
import Control.Monad
import qualified Control.Exception as C
import Control.Concurrent.Chan.Strict
import Control.Concurrent (forkIO,threadDelay)
import qualified Control.Parallel.Strategies as Par (NFData(..))
import System.Console.GetOpt
import Text.Printf
import Network
------------------------------------------------------------------------
type Net = ReaderT Bot IO
data Bot = Bot { socket :: Handle
, server :: String
, port :: !Int
, channel :: String
, nick :: String
, links :: !Bool
}
{-
server = "irc.freenode.org"
port = 6667
chan = "#arch-haskell"
nick = "archrss"
-}
data Flag = Links deriving Eq
main :: IO ()
main = do
(flags, args, errs) <- getOpt Permute [Option ['l'] ["links"] (NoArg Links) "include link URLs"] `fmap` getArgs
when (not . null $ errs) help
let l = Links `elem` flags
(st, feed, prefix) <- case args of
[s,p,c,n,f,z] | Just intp <- maybeRead p ->
return (Bot { socket = stdout
, server = s
, port = intp
, channel = c
, nick = n
, links = l }
,f, z)
_ -> help
C.bracket (connect st)
(hClose . socket)
(\st' -> C.catch
(runReaderT (run feed prefix) st')
(const $ return ()))
--
-- connect to the server
--
connect :: Bot -> IO Bot
connect st = notify $ do
h <- connectTo (server st) (PortNumber (fromIntegral (port st)))
hSetBuffering h NoBuffering
return st { socket = h }
where
notify a = C.bracket_
(printf "Connecting to %s ... " (server st) >> hFlush stdout)
(putStrLn "done.")
a
--
-- We're in the Net monad now, so we've connected successfully
-- Join a channel, and start processing commands
--
run :: String -> String -> Net ()
run feed prefix = do
n <- asks nick
c <- asks channel
h <- asks socket
l <- asks links
write "NICK" n
write "USER" (n++" 0 * :rss2irc gateway")
write "JOIN" c
-- run RSS thread
-- main thread just listens on commands
liftIO $ forkIO $ reader c h l feed prefix
listen h
--
-- handle commands from the channel
--
listen :: Handle -> Net ()
listen h = forever $ do
s <- init `fmap` io (hGetLine h)
io (putStrLn s)
if ping s then pong s else return () -- (io . print) (clean s)
where
-- clean = drop 1 . dropWhile (/= ':') . drop 1
ping x = "PING :" `isPrefixOf` x
pong x = write "PONG" (':' : drop 6 x)
------------------------------------------------------------------------
--
-- wait on an RSS thread, updating every 60 minutes.
--
reader :: String -> Handle -> Bool -> String -> String -> IO ()
reader c h l url prefix = go []
where
go old = do
RSSFeed f <- (fromJust . parseFeedString) `fmap` openURL url
let new = nubBy k . rssItems . rssChannel $ f
diff = (foldl' (flip (deleteBy k)) new old)
forM_ (take 5 diff) $ \item -> do
case rssItemTitle item of
Nothing -> return ()
Just t -> privmsgH h c $ prefix ++ t ++ if l then linkText else ""
where linkText = maybe "" (" " ++) (rssItemLink item)
threadDelay (60 * minutes)
go new
seconds = 10^6
minutes = 60 * seconds
k x y = let a = fromJust $ rssItemTitle x
b = fromJust $ rssItemTitle y
in a == b -- title
instance Par.NFData RSSItem
------------------------------------------------------------------------
io :: IO a -> Net a
io = liftIO
--
-- Send a privmsg to the current chan + server
--
privmsg :: String -> Net ()
privmsg s = do
h <- asks socket
c <- asks channel
io $ privmsgH h c s
write :: String -> String -> Net ()
write s t = do
h <- asks socket
io $ hWrite h s t
--
-- Send a message out to the server we're currently connected to
--
hWrite :: Handle -> String -> String -> IO ()
hWrite h s t = do
hPrintf h "%s %s\r\n" s t
printf "> %s %s\n" s t
privmsgH :: Handle -> String -> String -> IO ()
privmsgH h c s = hWrite h "PRIVMSG" (c ++ " :" ++ s)
------------------------------------------------------------------------
help = do
putStrLn "rss2irc [--links] <server> <port> <channel> <nick> <feed-url> <msg-prefix>"
exitWith ExitSuccess
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
[(x, _)] -> Just x
_ -> Nothing