ExtHandlers.hs

{- This file is part of funbot.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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.Foldable (mapM_)
import Data.Monoid ((<>))
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Time.Clock (diffUTCTime)
import Formatting hiding (text)
import FunBot.Config (welcomeDelay)
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 Network.IRC.Fun.Types.Base
import Prelude hiding (mapM_)

import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Web.Hook.GitLab as GitLab
import qualified Web.Hook.Gogs as Gogs

makeEllip :: Int -> Text
makeEllip len = T.center len ' ' "..."

formatCommit :: BranchName -> RepoName -> Commit -> MsgContent
formatCommit branch repo c =
    MsgContent $ encode $
        Green  #> plain (commitAuthor c)                <> " " <>
        Maroon #> plain (unBranchName branch)           <> " " <>
        Purple #> plain (CI.original $ unRepoName repo) <> " | " <>
        Teal   #> plain (commitTitle c)                 <> " " <>
        Gray   #> plain (commitUrl c)

formatEllipsis :: Int -> BranchName -> RepoName -> Int -> MsgContent
formatEllipsis len branch repo n =
    MsgContent $ encode $
        Green  #> plain (makeEllip len)                 <> " " <>
        Maroon #> plain (unBranchName branch)           <> " " <>
        Purple #> plain (CI.original $ unRepoName repo) <> " | " <>
        Navy   #> plain (sformat ("... another " % int % " commits ...") n)

formatTag :: ProjectObject Tag -> MsgContent
formatTag (ProjectObject repo tag) =
    MsgContent $ encode $
        Green  #> plain (tagAuthor tag) <> " " <>
        Purple #> plain (repoName repo) <> " " <>
        Teal   #> plain (tagRef tag)

formatMR :: ProjectObject MergeRequest -> MsgContent
formatMR (ProjectObject repo mr) =
    MsgContent $ encode $
        Green  #> plain (mrAuthor mr)                   <> " " <>
        Maroon #> (plain $ mrAction mr <> " MR")        <> " " <>
        Orange #> plain (sformat ("#" % int) (mrId mr)) <> " " <>
        Purple #> plain (repoName repo)                 <> " | " <>
        Teal   #> plain (mrTitle mr)                    <> " " <>
        Gray   #> plain (mrUrl mr)

formatIssue :: ProjectObject Issue -> MsgContent
formatIssue (ProjectObject repo i) =
    MsgContent $ encode $
        Green  #> plain (issueAuthor i)                   <> " " <>
        Maroon #> (plain $ issueAction i <> " issue")     <> " " <>
        Orange #> plain (sformat ("#" % int) (issueId i)) <> " " <>
        Purple #> plain (repoName repo)                   <> " | " <>
        Teal   #> plain (issueTitle i)                    <> " " <>
        Gray   #> plain (issueUrl i)

formatNote :: ProjectObject Note -> MsgContent
formatNote (ProjectObject repo n) =
    MsgContent $ encode $
        Green  #> plain (noteAuthor n)  <>
        Maroon #> " commented on "     <>
        Orange #> plain (noteTarget n)  <> " " <>
        Purple #> plain (repoName repo) <> " | " <>
        Teal   #> plain (noteContent n) <> " " <>
        Gray   #> plain (noteUrl n)

formatNews :: NewsItem -> NewsItemFields -> MsgContent
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 #> plain a) authorF
        fTitle = fmap (\ ft -> Purple #> plain ft) fTitleF
        iTitle = Teal #> plain (itemTitle item)
        url = fmap (\ u -> Gray #> plain 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  MsgContent $ encode $ case af of
            Nothing  -> iu
            Just af' -> af' <> " | " <> iu

formatPaste :: Paste -> MsgContent
formatPaste p = MsgContent $ T.concat
    [ pasteAuthor p , " "
    , pasteVerb p   , " “"
    , pasteTitle p  , "” | "
    , pasteUrl p
    ]

annCommits
    :: BranchName
    -> [MsgContent]
    -> MsgContent
    -> RepoAnnSpec
    -> BotSession ()
annCommits branch msgs ellip spec =
    let chan = rasChannel spec
    in  when (rasCommits spec && branch `passes` rasBranches spec) $
        if rasAllCommits 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 :: [Text] -> Text
makeVerbal []     = "... ummm... I don’t know, actually. How embarrassing"
makeVerbal [n]    = n
makeVerbal [n, m] = n <> " and " <> m
makeVerbal (n:ns) = n <> ", " <> makeVerbal ns

repoKey :: Repository -> (RepoSpace, RepoName)
repoKey repo =
    ( RepoSpace $ CI.mk $ repoSpace repo
    , RepoName $ CI.mk $ repoName repo
    )

handlePO
    :: (Text -> BotSession ())
    -> ProjectObject a
    -> Text
    -> (Seq RepoAnnSpec -> BotSession ())
    -> BotSession ()
handlePO elog (ProjectObject repo obj) desc act = do
    hosts <- getStateS $ stGitAnnChans . bsSettings
    sites <- getStateS $ stDevHosts . bsSettings
    case M.lookup (DevHost $ CI.mk $ repoHost repo) sites of
        Nothing -> elog $ sformat
            ( "Ext handler: "
            % stext
            % " for unregistered dev host: "
            % stext
            % " | "
            % shown
            )
            desc (repoHost repo) repo
        Just dhl -> case M.lookup dhl hosts of
            Nothing -> elog $ sformat
                ( "Ext handler: "
                % stext
                % " for unregistered dev host label section: "
                % stext
                % " | "
                % shown
                )
                desc (unDevHostLabel dhl) repo
            Just repos -> case M.lookup (repoKey repo) repos of
                Nothing -> elog $ sformat
                    ( "Ext handler: "
                    % stext
                    % " for unregistered repo under "
                    % stext
                    % ": "
                    % stext
                    % "/"
                    % stext
                    )
                    desc (unDevHostLabel dhl) (repoSpace repo) (repoName repo)
                Just specs -> act specs

handleSimple
    :: (Text -> BotSession ())
    -> ProjectObject a
    -> Text
    -> (RepoAnnSpec -> Bool)
    -> (ProjectObject a -> MsgContent)
    -> BotSession ()
handleSimple elog po desc enabled fmt =
    handlePO elog po desc $ \ specs ->
        let msg = fmt po
            ann spec =
                when (enabled spec) $ sendToChannel (rasChannel spec) msg
        in  mapM_ ann specs

handler'
    :: (Text -> BotSession ())
    -> (Text -> BotSession ())
    -> ExtEvent
    -> BotSession ()
handler' elog _dlog (GitPushEvent po) = handlePO elog po "Push" $ \ specs ->
    let repo = poRepo po
        push = poObj po
        branch = BranchName $ pushBranch push
        reponame = RepoName $ CI.mk $ repoName repo
        fmt = formatCommit branch reponame
        commits = pushCommits push
        msgs = map fmt commits
        len = case commits of
                [] -> 0
                cs -> T.length $ commitAuthor $ last cs
        ellip =
            formatEllipsis
                len
                branch
                reponame
                (length msgs - 2)
    in  mapM_ (annCommits branch msgs ellip) specs
handler' elog _dlog (GitTagEvent po) =
    handleSimple elog po "Tag" rasCommits formatTag
handler' elog _dlog (MergeRequestEvent po) =
    handleSimple elog po "MR" rasMergeRequests formatMR
handler' elog _dlog (IssueEvent po) =
    handleSimple elog po "Issue" rasIssues formatIssue
handler' elog _dlog (NoteEvent po) =
    handleSimple elog po "Note" rasNotes formatNote
handler' elog _dlog (NewsEvent item) = do
    feeds <- getStateS $ stWatchedFeeds . bsSettings
    let label = itemFeedLabel item
    case M.lookup (FeedLabel $ CI.mk label) feeds of
        Just NewsFeed { nfAnnSpec = spec } ->
            let msg = formatNews item (nAnnFields spec)
            in  mapM_ (\ chan -> sendToChannel chan msg) (nAnnChannels spec)
        Nothing -> do
            elog $ "Ext handler: Feed item with unknown label: " <> label
            elog $ T.pack $ show item
handler' _elog _dlog (PasteEvent paste) =
    sendToChannel (Channel $ pasteChannel paste) $ formatPaste paste
handler' _elog _dlog (WelcomeEvent nickt chant) = do
    getTime <- askTimeGetter
    now <- liftIO $ liftM fst getTime
    let chan = Channel chant
        nick = Nickname nickt
    mt <- getStateS $ M.lookup chan . bsLastMsgTime
    let quiet =
            case mt of
                Nothing -> True
                Just t  -> diffUTCTime now t >= fromIntegral welcomeDelay
    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 $ MsgContent $
                sformat
                    ( "Welcome, " % stext % "! 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 "
                    % stext % ". Also, if no one responds for a while, try \
                    \emailing us at " % stext % ", or just come back later."
                    )
                    nickt
                    (makeVerbal $ map unNickname $ csFolks cs)
                    (csEmail cs)

handler
    :: (Text -> BotSession ())
    -> (Text -> BotSession ())
    -> ExtEvent
    -> BotSession ()
handler elog dlog event = do
    dlog $ T.pack $ show event
    handler' elog dlog event