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
    )
where

import Control.Exception (catch)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import Data.List (isPrefixOf, stripPrefix)
import FunBot.History (remember, reportHistory)
import FunBot.Memos (reportMemos, reportMemosAll)
import FunBot.Types (HistoryDisplay (..))
import FunBot.UserOptions (getUserHistoryOpts)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Text.HTML.TagSoup

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.UTF8 as BU

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 ()

handleBotMsg chan nick msg full = do
    sayHello chan nick msg
    remember chan nick full False

handleJoin chan nick = do
    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
    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 ()

handleMsg chan nick msg _mention = do
    sayTitle chan msg
    remember chan nick msg False

handleAction chan nick msg _mention = remember chan nick msg True

handleNickChange _old new = reportMemosAll new