ExtHandlers.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/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

module FunBot.ExtHandlers
    ( handler
    )
where

import Control.Monad (forM_, liftM, when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Time.Clock (diffUTCTime)
import FunBot.ExtEvents
import FunBot.Types
import FunBot.Util (passes)
import Network.HTTP (Request (..), RequestMethod (..))
import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel)
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Color
import Text.Printf (printf)

import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import qualified Web.Hook.GitLab as GitLab
import qualified Web.Hook.Gogs as Gogs

makeEllip len =
    let ellip = "..."
        n = (len - 1) `div` 2 - 1
        padl = replicate n ' '
        m = len - length padl - length ellip
        padr = replicate m ' '
    in  padl ++ ellip ++ padr

formatCommit branch repo (Commit author msg url) =
    encode $
        Green #> Pure author <> " " <>
        Maroon #> Pure branch <> " " <>
        Purple #> Pure repo <> " | " <>
        Teal #> Pure msg <> " " <>
        Gray #> Pure url

formatEllipsis len branch repo n =
    encode $
        Green #> Pure (makeEllip len) <> " " <>
        Maroon #> Pure branch <> " " <>
        Purple #> Pure repo <> " | " <>
        Navy #> Pure ("... another " ++ show n ++ " commits ...")

formatTag (Tag author ref repo _owner) =
    encode $
        Green #> Pure author <> " " <>
        Purple #> Pure repo <> " " <>
        Teal #> Pure ref

formatMR (MergeRequest author iid _repo _owner title url action) =
    encode $
        Green #> Pure author <> " " <>
        Maroon #> Pure action <> " " <>
        Purple #> Pure ('#' : show iid) <> " | " <>
        Teal #> Pure title <> " " <>
        Gray #> Pure url

formatNews item fields =
    let -- Filtered fields
        filt pass val = if pass then val else Nothing
        authorF = filt (dispAuthor fields) (itemAuthor item)
        fTitleF = filt (dispFeedTitle fields) (itemFeedTitle item)
        urlF = filt (dispUrl fields) (itemUrl item)
        -- Separate components
        author = fmap (\ a -> Green #> Pure a) authorF
        fTitle = fmap (\ ft -> Purple #> Pure ft) fTitleF
        iTitle = Teal #> Pure (itemTitle item)
        url = fmap (\ u -> Gray #> Pure u) urlF
        -- Now combine them
        af = case (author, fTitle) of
                (Nothing,    Nothing)    -> Nothing
                (a@(Just _), Nothing)    -> a
                (Nothing,    t@(Just _)) -> t
                (Just a,     Just t)     -> Just $ a <> " @ " <> t
        iu = case url of
                Nothing -> iTitle
                Just u  -> iTitle <> " " <> u
    in  encode $ case af of
            Nothing  -> iu
            Just af' -> af' <> " | " <> iu

formatPaste (Paste author verb title url _chan) =
    printf "%v %v “%v” | %v" author verb title url

lower = map toLower

keyb b = (branchRepo b, lower $ branchRepoOwner b)

keyt t = (tagRepo t, lower $ tagRepoOwner t)

keym mr = (mrRepo mr, lower $ mrRepoOwner mr)

annCommits branch msgs ellip spec =
    let chan = pAnnChannel spec
    in  when (branch `passes` pAnnBranches spec) $
        if pAnnAllCommits spec || length msgs <= 3
            then mapM_ (sendToChannel chan) msgs
            else do
                let firstCommit = head msgs
                    lastCommit = last msgs
                    between = length msgs - 2
                sendToChannel chan firstCommit
                sendToChannel chan ellip
                sendToChannel chan lastCommit

makeVerbal []     = "... ummm... I don’t know, actually. How embarrassing"
makeVerbal [n]    = n
makeVerbal [n, m] = n ++ " and " ++ m
makeVerbal (n:ns) = n ++ ", " ++ makeVerbal ns

handler (GitPushEvent (Push branch commits)) = do
    chans <- getStateS $ stGitAnnChans . bsSettings
    case M.lookup (keyb branch) chans of
        Just specs ->
            let fmt = formatCommit (branchName branch) (branchRepo branch)
                msgs = map fmt commits
                len = case commits of
                    [] -> 0
                    cs -> length $ commitAuthor $ last cs
                ellip =
                    formatEllipsis
                        len
                        (branchName branch)
                        (branchRepo branch)
                        (length msgs - 2)
            in  mapM_ (annCommits (branchName branch) msgs ellip) specs
        Nothing ->
            liftIO $ putStrLn $
                "Ext handler: Git push for unregistered repo: " ++
                show (keyb branch)
handler (GitTagEvent tag) = do
    chans <- getStateS $ stGitAnnChans . bsSettings
    case M.lookup (keyt tag) chans of
        Just specs ->
            let msg = formatTag tag
                ann chan = sendToChannel chan msg
            in  mapM_ (ann . pAnnChannel) specs
        Nothing ->
            liftIO $ putStrLn $
                "Ext handler: Tag for unregistered repo: " ++
                show (keyt tag)
handler (MergeRequestEvent mr) = do
    chans <- getStateS $ stGitAnnChans . bsSettings
    case M.lookup (keym mr) chans of
        Just specs ->
            let msg = formatMR mr
                ann chan = sendToChannel chan msg
            in  mapM_ (ann . pAnnChannel) specs
        Nothing ->
            liftIO $ putStrLn $
                "Ext handler: MR for unregistered repo: " ++
                show (keym mr)
handler (NewsEvent item) = do
    feeds <- getStateS $ stWatchedFeeds . bsSettings
    let label = itemFeedLabel item
    case M.lookup label feeds of
        Just NewsFeed { nfAnnSpec = spec } ->
            let msg = formatNews item (nAnnFields spec)
            in  mapM_ (\ chan -> sendToChannel chan msg) (nAnnChannels spec)
        Nothing -> liftIO $ do
            putStrLn $ "Ext handler: Feed item with unknown label: " ++ label
            print item
handler (PasteEvent paste) =
    sendToChannel (pasteChannel paste) $ formatPaste paste
handler (WelcomeEvent nick chan) = do
    getTime <- askTimeGetter
    now <- liftIO $ liftM fst getTime
    mt <- getStateS $ M.lookup chan . bsLastMsgTime
    let quiet =
            case mt of
                Nothing -> True
                Just t  -> diffUTCTime t now >= 60 --seconds
    tracked <- channelIsTracked chan
    isHere <- nick `isInChannel` chan
    let assumeHere = tracked && isHere
    when (quiet && assumeHere) $ do
        chans <- getStateS $ stChannels . bsSettings
        case M.lookup chan chans of
            Nothing -> return ()
            Just cs ->
                sendToChannel chan $
                printf
                    "Welcome, %v! The channel is pretty quiet right now, so I \
                    \thought I’d say hello. For reference, the main people \
                    \here to ping if you have questions are %v. Also, if no \
                    \one responds for a while, try emailing us at %v, or just \
                    \come back later."
                    nick
                    (makeVerbal $ csFolks cs)
                    (csEmail cs)