{-# 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