IrcHandlers.hs

{- This file is part of funbot.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ 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, when, void)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum, toLower)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.List (isPrefixOf, stripPrefix)
import Data.Time.Units
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 Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Network.IRC.Fun.Bot.State
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

helloWords :: [String]
helloWords = ["hello", "hi", "hey", "yo"]

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

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

lastChars :: String
lastChars = ".!?"

isHello :: String -> Bool
isHello s =
    let s' = map toLower s
    in     null s
        || s' `elem` helloWords
        || init s' `elem` helloWords && last s' `elem` lastChars

isPing :: String -> Bool
isPing s =
    case stripPrefix "ping" $ map toLower s of
        Just []  -> True
        Just [c] -> c `elem` lastChars
        _        -> False

isThanks :: String -> Bool
isThanks s =
    let slow = map toLower s
    in  case (stripPrefix "thanks" slow, stripPrefix "thank you" slow) of
            (Nothing, Nothing) -> False
            _                  -> True

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

recordTime chan = do
    getTime <- askTimeGetter
    now <- liftIO $ liftM fst getTime
    let update = M.insert chan now
    modifyState $ \ s -> s { bsLastMsgTime = update $ bsLastMsgTime s }

handleBotMsg chan nick msg full = do
    sayHello chan nick msg
    recordTime chan

handleJoin chan nick = do
    sel <- channelSelected chan
    when sel $ do
        new <- rememberNick' nick chan
        when new $ do
            saveKnownNicks
            mcs <- getStateS $ M.lookup chan . stChannels . bsSettings
            let welcome = maybe False csWelcome mcs
            when welcome $ do
                q <- askEnvS loopbackQueue
                liftIO $ void $ forkIO $ do
                    threadDelay $ fromInteger $ toMicroseconds (1 :: Minute)
                    writeChan q $ WelcomeEvent nick chan
    hd <- getUserHistoryOpts nick chan
    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd)
    reportMemos nick chan

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 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 text

sayTitle chan msg = when ("http" `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 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 $ '“' : title ++ "”"
            _                  -> return ()

search _   ""   = Nothing
search msg pref = f msg False
    where
    skip = isAlphaNum
    pick = isAlphaNum
    f ""       _     = Nothing
    f (c:cs)   True  = f cs (skip c)
    f s@(c:cs) False =
        let next = f cs (skip c)
        in  case stripPrefix pref s of
                Nothing -> next
                Just r  ->
                    case span pick r of
                        ("", _)     -> next
                        (p,  "")    -> Just p
                        (p,  (d:_)) ->
                            if skip d
                                then next
                                else Just p

format cut s = shPrefix cut ++ s ++ " | " ++ shBefore cut ++ s ++ shAfter cut

sayTicket chan 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 $ format cut s

handleMsg chan nick msg _mention = do
    sayTitle chan msg
    sayTicket chan msg
    recordTime chan

handleAction chan nick msg _mention = do
    sayTicket chan msg
    recordTime chan

handleNickChange _old new = reportMemosAll new

handleNames chan _priv pairs = do
    sel <- channelSelected chan
    when sel $ do
        rememberNicks (map snd pairs) chan
        saveKnownNicks