{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Network.IRC.Client.Events
-- Copyright   : (c) 2017 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : CPP, OverloadedStrings, RankNTypes
--
-- Events and event handlers. When a message is received from the
-- server, all matching handlers are executed sequentially in the
-- order that they appear in the 'handlers' list.
module Network.IRC.Client.Events
  ( -- * Handlers
    EventHandler(..)
  , matchCTCP
  , matchNumeric
  , matchType
  , matchWhen

  -- * Default handlers
  , defaultEventHandlers
  , defaultOnConnect
  , defaultOnDisconnect

  -- ** Individual handlers
  , pingHandler
  , ctcpPingHandler
  , ctcpVersionHandler
  , ctcpTimeHandler
  , welcomeNick
  , joinOnWelcome
  , joinHandler
  , nickMangler

  -- * Re-exported
  , Event(..)
  , Message(..)
  , Source(..)
  , module Network.IRC.Conduit.Lens
  ) where

import Control.Applicative ((<$>), (<|>))
import Control.Concurrent.STM (atomically, readTVar, modifyTVar)
import Control.Monad.Catch (SomeException, fromException, throwM)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text, breakOn, takeEnd, toUpper)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import Network.IRC.Conduit (Event(..), Message(..), Source(..))
import Network.IRC.CTCP (fromCTCP)
import Network.IRC.Conduit.Lens

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif

import qualified Data.Text as T

import Network.IRC.Client.Internal
import Network.IRC.Client.Lens
import Network.IRC.Client.Utils


-------------------------------------------------------------------------------
-- Handlers

-- | Match the verb of a CTCP, ignoring case, and returning the arguments.
--
-- > matchCTCP "ping"   ":foo PRIVMSG #bar :\001PING\001"          ==> Just []
-- > matchCTCP "PING"   ":foo PRIVMSG #bar :\001PING\001"          ==> Just []
-- > matchCTCP "ACTION" ":foo PRIVMSG #bar :\001ACTION dances\001" ==> Just ["dances"]
matchCTCP :: Text -> Event Text -> Maybe [Text]
matchCTCP verb ev = case _message ev of
  Privmsg _ (Left ctcpbs) ->
    let (v, args) = fromCTCP ctcpbs
    in if toUpper verb == toUpper v
       then Just args
       else Nothing
  _ -> Nothing

-- | Match a numeric server message. Numeric messages are sent in
-- response to most things, such as connecting to the server, or
-- joining a channel.
--
-- Numerics in the range 001 to 099 are informative messages, numerics
-- in the range 200 to 399 are responses to commands. Some common
-- numerics are:
--
--    - 001 (RPL_WELCOME), sent after successfully connecting.
--
--    - 331 (RPL_NOTOPIC), sent after joining a channel if it has no
--      topic.
--
--    - 332 (RPL_TOPIC), sent after joining a channel if it has a
--      topic.
--
--    - 432 (ERR_ERRONEUSNICKNAME), sent after trying to change to an
--      invalid nick.
--
--    - 433 (ERR_NICKNAMEINUSE), sent after trying to change to a nick
--      already in use.
--
--    - 436 (ERR_NICKCOLLISION), sent after trying to change to a nick
--      in use on another server.
--
-- See Section 5 of @<https://tools.ietf.org/html/rfc2812#section-5
-- RFC 2812>@ for a complete list.
--
-- > matchNumeric 001 "001 :Welcome to irc.example.com" ==> True
-- > matchNumeric 332 "332 :#haskell: We like Haskell"  ==> True
matchNumeric :: Int -> Event a -> Maybe [a]
matchNumeric num ev = case _message ev of
  Numeric n args | num == n -> Just args
  _ -> Nothing

-- | Match events of the given type. Refer to
-- "Network.IRC.Conduit.Lens#Message" for the list of 'Prism''s.
--
-- > matchType _Privmsg ":foo PRIVMSG #bar :hello world" ==> Just ("#bar", Right "hello world")
-- > matchType _Quit    ":foo QUIT :goodbye world"       ==> Just (Just "goodbye world")
matchType :: Prism' (Message a) b -> Event a -> Maybe b
matchType k = preview k . _message

-- | Match a predicate against an event.
--
-- > matchWhen (const True) ":foo PRIVMSG #bar :hello world" ==> Just ":foo PRIVMSG :hello world"
matchWhen :: (Event a -> Bool) -> Event a -> Maybe (Message a)
matchWhen p ev | p ev = Just (_message ev)
matchWhen _ _ = Nothing


-------------------------------------------------------------------------------
-- Default handlers

-- | The default event handlers, the following are included:
--
-- - respond to server @PING@ messages with a @PONG@;
-- - respond to CTCP @PING@ requests;
-- - respond to CTCP @VERSION@ requests with the version string;
-- - respond to CTCP @TIME@ requests with the system time;
-- - update the nick upon receiving the welcome message, in case the
--   server modifies it;
-- - mangle the nick if the server reports a collision;
-- - update the channel list on @JOIN@ and @KICK@.
defaultEventHandlers :: [EventHandler s]
defaultEventHandlers =
  [ pingHandler
  , kickHandler
  , ctcpPingHandler
  , ctcpTimeHandler
  , ctcpVersionHandler
  , welcomeNick
  , joinOnWelcome
  , joinHandler
  , nickMangler
  ]

-- | The default connect handler: set the nick.
defaultOnConnect :: IRC s ()
defaultOnConnect = do
  iconf <- snapshot instanceConfig =<< getIRCState
  send . Nick $ get nick iconf

-- | The default disconnect handler
--
--    - If the client disconnected due to a 'Timeout' exception, reconnect.
--
--    - If the client disconnected due to another exception, rethrow it.
--
--    - If the client disconnected without an exception, halt.
defaultOnDisconnect :: Maybe SomeException -> IRC s ()
defaultOnDisconnect (Just exc) = case fromException exc of
  Just Timeout -> reconnect
  Nothing -> throwM exc
defaultOnDisconnect Nothing = pure ()


-------------------------------------------------------------------------------
-- Individual handlers

-- | Respond to server @PING@ messages with a @PONG@.
pingHandler :: EventHandler s
pingHandler = EventHandler (matchType _Ping) $ \_ (s1, s2) ->
  send . Pong $ fromMaybe s1 s2

-- | Respond to CTCP @PING@ requests.
ctcpPingHandler :: EventHandler s
ctcpPingHandler = EventHandler (matchCTCP "PING") $ \src args -> case src of
  User n -> send $ ctcpReply n "PING" args
  _ -> pure ()

-- | Respond to CTCP @VERSION@ requests with the version string.
ctcpVersionHandler :: EventHandler s
ctcpVersionHandler = EventHandler (matchCTCP "VERSION") $ \src _ -> case src of
  User n -> do
    ver <- get version <$> (snapshot instanceConfig =<< getIRCState)
    send $ ctcpReply n "VERSION" [ver]
  _ -> pure ()

-- | Respond to CTCP @TIME@ requests with the system time.
ctcpTimeHandler :: EventHandler s
ctcpTimeHandler = EventHandler (matchCTCP "TIME") $ \src _ -> case src of
  User n -> do
    now <- liftIO getCurrentTime
    send $ ctcpReply n "TIME" [T.pack $ formatTime defaultTimeLocale "%c" now]
  _ -> pure ()

-- | Update the nick upon welcome (numeric reply 001), as it may not
-- be what we requested (eg, in the case of a nick too long).
welcomeNick :: EventHandler s
welcomeNick = EventHandler (matchNumeric 001) $ \_ args -> case args of
  (srvNick:_) -> do
    tvarI <- get instanceConfig <$> getIRCState
    liftIO . atomically $
      modifyTVar tvarI (set nick srvNick)
  [] -> pure ()

-- | Join default channels upon welcome (numeric reply 001). If sent earlier,
-- the server might reject the JOIN attempts.
joinOnWelcome :: EventHandler s
joinOnWelcome = EventHandler (matchNumeric 001) $ \_ _ -> do
  iconf <- snapshot instanceConfig =<< getIRCState
  mapM_ (send . Join) $ get channels iconf

-- | Mangle the nick if there's a collision (numeric replies 432, 433,
-- and 436) when we set it
nickMangler :: EventHandler s
nickMangler = EventHandler (\ev -> matcher 432 fresh ev <|> matcher 433 mangle ev <|> matcher 436 mangle ev) $ \_ -> uncurry go
  where
    matcher num f ev = case _message ev of
      Numeric n args | num == n -> Just (f, args)
      _ -> Nothing

    go f (_:srvNick:_) = do
      theNick <- get nick <$> (snapshot instanceConfig =<< getIRCState)

      -- If the length of our nick and the server's idea of our nick
      -- differ, it was truncated - so calculate the allowable length.
      let nicklen = if T.length srvNick /= T.length theNick
                    then Just $ T.length srvNick
                    else Nothing

      setNick . trunc nicklen $ f srvNick
    go _ _ = return ()

    fresh n = if T.length n' == 0 then "f" else n'
      where n' = T.filter isAlphaNum n

    mangle n = (n <> "1") `fromMaybe` charsubst n

    -- Truncate a nick, if there is a known length limit.
    trunc len txt = maybe txt (`takeEnd` txt) len

    -- List of substring substitutions. It's important that these
    -- don't contain any loops!
    charsubst = transform [ ("i", "1")
                          , ("I", "1")
                          , ("l", "1")
                          , ("L", "1")
                          , ("o", "0")
                          , ("O", "0")
                          , ("A", "4")
                          , ("0", "1")
                          , ("1", "2")
                          , ("2", "3")
                          , ("3", "4")
                          , ("4", "5")
                          , ("5", "6")
                          , ("6", "7")
                          , ("7", "8")
                          , ("8", "9")
                          , ("9", "-")
                          ]

    -- Attempt to transform some text by the substitutions.
    transform ((from, to):trs) txt = case breakOn' from txt of
      Just (before, after) -> Just $ before <> to <> after
      _ -> transform trs txt
    transform [] _ = Nothing

-- | Upon joining a channel (numeric reply 331 or 332), add it to the
-- list (if not already present).
joinHandler :: EventHandler s
joinHandler = EventHandler (\ev -> matchNumeric 331 ev <|> matchNumeric 332 ev) $ \_ args -> case args of
  (c:_) -> do
    tvarI <- get instanceConfig <$> getIRCState
    liftIO . atomically $
      modifyTVar tvarI $ \iconf ->
        (if c `elem` get channels iconf
          then modify channels (c:)
          else id) iconf
  _ -> pure ()

-- | Update the channel list upon being kicked.
kickHandler :: EventHandler s
kickHandler = EventHandler (matchType _Kick) $ \src (n, _, _) -> do
  tvarI <- get instanceConfig <$> getIRCState
  liftIO . atomically $ do
    theNick <- get nick <$> readTVar tvarI
    case src of
      Channel c _
        | n == theNick -> delChan tvarI c
        | otherwise    -> pure ()
      _ -> pure ()


-------------------------------------------------------------------------------
-- Utils

-- | Break some text on the first occurrence of a substring, removing
-- the substring from the second portion.
breakOn' :: Text -> Text -> Maybe (Text, Text)
breakOn' delim txt = if T.length after >= T.length delim
                     then Just (before, T.drop (T.length delim) after)
                     else Nothing
  where
    (before, after) = breakOn delim txt