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 qualified Data.HashMap.Lazy as M
import           Data.Maybe (fromMaybe)
import           Data.Monoid ((<>))
import qualified Data.Text as T
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 (askEnvS, getStateS)
import           Network.IRC.Fun.Color
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 (MR 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

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 (GitPush (Push branch commits)) = do
    chans <- askEnvS gitAnnChans
    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 (GitTag tag) = do
    chans <- askEnvS gitAnnChans
    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 (MergeRequest mr) = do
    chans <- askEnvS gitAnnChans
    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 (NewsItem item) = do
    feeds <- getStateS $ watchedFeeds . settings
    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