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

import Data.Char (intToDigit)
import Network.URI
import Network.HTTP hiding (port)
import Network.Stream

------------------------------------------------------------------------

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

help = do
    putStrLn "rss2irc [--links] <server> <port> <channel> <nick> <feed-url> <msg-prefix> <interval>"
    exitWith ExitSuccess

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, interval) <- case args of
         [s,p,c,n,f,z,i] | Just intp <- maybeRead p, Just inti <- maybeRead i ->
             return (Bot { socket  = stdout
                         , server  = s
                         , port    = intp
                         , channel = c
                         , nick    = n
                         , links   = l }
                         ,f, z, inti)

         _ -> help

    C.bracket (connect st)
              (hClose . socket)
              (\st' -> C.catch
                (runReaderT (run feed prefix interval) st')
                (const $ return () :: C.SomeException -> IO ()))

--
-- 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 -> Int -> Net ()
run feed prefix interval = 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 interval
    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 interval minutes.
--
reader :: String -> Handle -> Bool -> String -> String -> Int -> IO ()
reader c h l url prefix interval = do
  initialitems <- items url
  go initialitems
  where
    go old = do
        new <- items url
        let diff = (foldl' (flip (deleteBy matchingTitles)) new old)

        forM_ (take 100 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 (interval * minutes)
        go new

    seconds = 10^6
    minutes = 60 * seconds

items :: String -> IO [RSSItem]
items url = do
  s <- get $ fromJust $ parseURI url
  let RSSFeed r = fromJust $ parseFeedString s
  return $ nubBy matchingTitles $ rssItems $ rssChannel r

matchingTitles x y = (fromJust $ rssItemTitle x) == (fromJust $ rssItemTitle y)

instance Par.NFData RSSItem

------------------------------------------------------------------------

get :: URI -> IO String
get uri = do
  resp <- simpleHTTP (request uri) >>= handleE (error . show)
  case rspCode resp of
    (2,0,0) -> return (rspBody resp)
    _ -> error (httpError resp)
    where
      httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp
      showRspCode (a,b,c) = map intToDigit [a,b,c]

request :: URI -> Request String
request uri = Request{rqURI=uri, rqMethod=GET, rqHeaders=[], rqBody=""}

handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a
handleE h (Left e) = h e
handleE _ (Right v) = return v

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)

------------------------------------------------------------------------

maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
    [(x, _)] -> Just x
    _        -> Nothing