{- This file is part of funbot.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For byte strings
{-# LANGUAGE OverloadedStrings #-}

module FunBot.IrcHandlers
    ( handleBotMsg
    , handleJoin
    , handleMsg
    , handleAction
    , handleNickChange
    , handleNames
    )
where

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan (writeChan)
import Control.Exception (catch)
import Control.Monad (liftM, unless, when, void)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Units
import FunBot.Config (welcomeDelay)
import FunBot.ExtEvents (ExtEvent (WelcomeEvent))
import FunBot.History (reportHistory)
import FunBot.KnownNicks
import FunBot.Memos (reportMemos, reportMemosAll)
import FunBot.Types
import FunBot.UserOptions (getUserHistoryOpts)
import FunBot.Util (unsnoc)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Types.Base
import Text.HTML.TagSoup

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.UTF8 as BU
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T

waveWordsL :: [Text]
waveWordsL = ["\\o", "\\O", "\\0"]

waveWordsR :: [Text]
waveWordsR = ["o/", "O/", "0/"]

lastChars :: [Char]
lastChars = ".!?"

isWord :: [Text] -> Maybe [Char] -> Text -> Bool
isWord ws mcs w =
    case listToMaybe $ mapMaybe (flip T.stripPrefix $ T.toLower w) ws of
        Nothing -> False
        Just r  ->
            case T.uncons $ T.stripStart r of
                Nothing     -> True
                Just (c, _) -> maybe True (c `elem`) mcs

isHello :: Text -> Bool
isHello = isWord ["hello", "hi", "hey", "yo"] (Just lastChars)

isPing :: Text -> Bool
isPing = isWord ["ping"] (Just lastChars)

isThanks :: Text -> Bool
isThanks = isWord ["thanks", "thank you"] Nothing

sayHello :: Channel -> Nickname -> MsgContent -> BotSession ()
sayHello chan (Nickname nick) (MsgContent msg)
    | isHello msg           = sendToChannel chan $ MsgContent $ "Hello, " <> nick
    | isPing msg            = sendToChannel chan $ MsgContent $ nick <> ", pong"
    | isThanks msg          = sendToChannel chan $ MsgContent $ nick <> ", you’re welcome!"
    | msg `elem` waveWordsL = sendToChannel chan $ MsgContent $ nick <> ": o/"
    | msg `elem` waveWordsR = sendToChannel chan $ MsgContent $ nick <> ": \\o"
    | otherwise             = return ()

recordTime :: Channel -> BotSession ()
recordTime chan = do
    getTime <- askTimeGetter
    now <- liftIO $ fmap fst getTime
    let update = M.insert chan now
    modifyState $ \ s -> s { bsLastMsgTime = update $ bsLastMsgTime s }

handleBotMsg
    :: Channel
    -> Nickname
    -> MsgContent
    -> MsgContent
    -> BotSession ()
handleBotMsg chan nick msg _full = do
    sayHello chan nick msg
    recordTime chan

isUnderscored :: Nickname -> Channel -> BotSession Bool
isUnderscored nick chan =
    case unsnoc $ unNickname nick of
        Just (t, '_') -> nickIsKnown (Nickname t) chan
        _             -> return False

handleJoin :: Channel -> Nickname -> BotSession ()
handleJoin chan nick = do
    sel <- channelSelected chan
    when sel $ do
        new <- rememberNick' nick chan
        when new $ do
            saveKnownNicks
            ud <- isUnderscored nick chan
            unless ud $ do
                mcs <- getStateS $ M.lookup chan . stChannels . bsSettings
                let welcome = maybe False csWelcome mcs
                when welcome $ do
                    q <- askEnvS loopbackQueue
                    liftIO $ void $ forkIO $ do
                        threadDelay $ welcomeDelay * 1000 * 1000
                        writeChan q $ WelcomeEvent (unNickname nick) (unChannel chan)
    reportMemos nick chan
    hd <- getUserHistoryOpts nick chan
    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd) True

goodHost :: B.ByteString -> Bool
goodHost h =
    let n = B.length h
        suffix6 = B.drop (n - 6) h
        suffix4 = B.drop 2 suffix6
        isCo = B.length suffix6 == 6 && ".co." `B.isPrefixOf` suffix6
        isCom = suffix4 == ".com"
    in  not $ isCom || isCo

findTitle :: String -> Maybe Text
findTitle page =
    let tags = parseTags page
        from = drop 1 $ dropWhile (not . isTagOpenName "title") tags
        range = takeWhile (not . isTagCloseName "title") from
        text = unwords $ words $ innerText range
    in  if null text then Nothing else Just $ T.pack text

sayTitle :: Channel -> MsgContent -> BotSession ()
sayTitle chan (MsgContent msg) = when ("http" `T.isPrefixOf` msg) $ do
    chans <- getStateS $ stChannels . bsSettings
    let say = maybe True csSayTitles $ M.lookup chan chans
    when say $ do
        manager <- liftIO $ newManager tlsManagerSettings
        let action = do
                request <- parseUrl $ T.unpack msg
                let h = host request
                if goodHost h
                    then do
                        response <- httpLbs request manager
                        let page = BU.toString $ responseBody response
                        return $ Right $ findTitle page
                    else return $ Right Nothing
            handler e = return $ Left (e :: HttpException)
            getTitle = action `catch` handler
        etitle <- liftIO getTitle
        case etitle of
            Right (Just title) -> sendToChannel chan $ MsgContent $ "“" <> title <> "”"
            _                  -> return ()

-- | Search for a shortcut prefix in the string, and return the word following
-- it (i.e. the argument) if found. Requirements and conditions:
--
-- * The prefix must come after a non-alphanum char (or beginning of message)
-- * The argument is the longest alphanum sequence following the prefix
--
-- (1) see if we have the prefix here
-- (2) if yes, take until non-alphanum and DONE
-- (3) if not, check if the first char is alphanum
-- (4) if yes, drop it and then all alphanum and repeat
-- (5) if not, drop it and repeat
search
    :: Text -- ^ Search in this
    -> Text -- ^ Search for this
    -> Maybe Text
search msg pref =
    if T.null pref
        then Nothing
        else f msg
    where
    skip = isAlphaNum
    pick = isAlphaNum
    once t =
        case T.stripPrefix pref t of
            Just r  ->
                let a = T.takeWhile pick r
                in  if T.null a
                        then Nothing
                        else Just a
            Nothing -> Nothing
    f t =
        case once t of
            succ@(Just _) -> succ
            Nothing       ->
                case T.uncons t of
                    Nothing     -> Nothing
                    Just (c, r) ->
                        if skip c
                            then f $ T.dropWhile skip r
                            else f r

format :: Shortcut -> Text -> Text
format cut t = T.concat [shPrefix cut, t, " | ", shBefore cut, t, shAfter cut]

sayTicket :: Channel -> MsgContent -> BotSession ()
sayTicket chan (MsgContent msg) = do
    allCuts <- getStateS $ stShortcuts . bsSettings
    let applies cut = chan `elem` shChannels cut
        cuts = M.elems $ M.filter applies allCuts
        getres cut = fmap (\ s -> (cut, s)) $ search msg (shPrefix cut)
        results = mapMaybe getres cuts
        first = listToMaybe results
    case first of
        Nothing       -> return ()
        Just (cut, s) -> sendToChannel chan $ MsgContent $ format cut s

handleMsg :: Channel -> Nickname -> MsgContent -> Bool -> BotSession ()
handleMsg chan nick msg _mention = do
    sayTitle chan msg
    sayTicket chan msg
    recordTime chan

handleAction :: Channel -> Nickname -> MsgContent -> Bool -> BotSession ()
handleAction chan nick msg _mention = do
    sayTicket chan msg
    recordTime chan

handleNickChange :: Nickname -> Nickname -> BotSession ()
handleNickChange _old new = reportMemosAll new

handleNames
    :: Channel
    -> ChannelPrivacy
    -> [(Privilege, Nickname)]
    -> BotSession ()
handleNames chan _priv pairs = do
    sel <- channelSelected chan
    when sel $ do
        rememberNicks (map snd pairs) chan
        saveKnownNicks