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_, when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
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.State (getStateS)
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

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

formatEllipsis branch repo n =
    encode $
        Green #> "..." <> " " <>
        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

handler (GitPushEvent (Push branch commits)) = do
    chans <- getStateS $ gitAnnChans . bsSettings
    case M.lookup (keyb branch) chans of
        Just specs ->
            let fmt = formatCommit (branchName branch) (branchRepo branch)
                msgs = map fmt commits
                ellip =
                    formatEllipsis
                        (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 $ gitAnnChans . 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 $ gitAnnChans . 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 $ watchedFeeds . bsSettings
    let label = itemFeedLabel item
    case M.lookup label feeds of
        Just (_url, 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