From 3dc9ae5dd84fca1bd4251f2e9e39cbd59216027f Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 21 Aug 2021 10:08:41 +0200 Subject: [PATCH] Refactor towards generalization of announcements --- Handler/Announcements.hs | 2 +- Handler/Shared.hs | 6 +++--- Handler/ShowChallenge.hs | 11 +++++------ Settings.hs | 10 ++++++++-- Web/Announcements.hs | 19 ++++++++++++++----- 5 files changed, 31 insertions(+), 17 deletions(-) diff --git a/Handler/Announcements.hs b/Handler/Announcements.hs index 67f2d12..6bbfd20 100644 --- a/Handler/Announcements.hs +++ b/Handler/Announcements.hs @@ -16,7 +16,7 @@ getTestAnnouncementsR = do Nothing -> "Gonito" case webHook of - Just hook -> liftIO $ sendAnnouncement hook ("Test message from " ++ (slackLink app name "")) + Just hook -> liftIO $ sendAnnouncement hook ("Test message from " ++ (slackLink (Just hook) app name "")) Nothing -> return () defaultLayout $ do diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 1538925..22daee3 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -42,7 +42,7 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Regex.TDFA -import Web.Announcements (formatLink) +import Web.Announcements (formatLink, AnnouncementHook) import GEval.Core import GEval.Common @@ -743,8 +743,8 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering compareFun TheLowerTheBetter = flip compare compareFun TheHigherTheBetter = compare -slackLink :: App -> Text -> Text -> Text -slackLink app title addr = formatLink slink title +slackLink :: Maybe AnnouncementHook -> App -> Text -> Text -> Text +slackLink hook app title addr = formatLink hook slink title where slink = (appRoot $ appSettings app) ++ "/" ++ addr formatVersion :: (Int, Int, Int) -> Text diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index fd77962..b911e81 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -933,8 +933,9 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do msg chan "SUBMISSION CREATED" app <- getYesod + let mHook = appNewBestResultSlackHook $ appSettings app - let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo))) + let submissionLink = slackLink mHook app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo))) case mMainEnt of Just (Entity mainTestId mainTest) -> do @@ -952,8 +953,8 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do (s:_) -> if compOp s b then do - let challengeLink = slackLink app (challengeTitle challenge) ("challenge/" - ++ (challengeName challenge)) + let challengeLink = slackLink mHook app (challengeTitle challenge) ("challenge/" + ++ (challengeName challenge)) let message = ("Whoa! New best result for " ++ challengeLink ++ " challenge by " @@ -971,8 +972,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do ++ " See " ++ submissionLink ++ "." ++ " :clap:") msg chan message - case appNewBestResultSlackHook $ appSettings app of - Just "" -> return () + case mHook of Just hook -> liftIO $ sendAnnouncement hook message Nothing -> return () @@ -1021,7 +1021,6 @@ checkTarget theNow user submissionLink entries indicator target chan = do ++ (T.replicate 10 " :champagne: ") ++ " :mleczko: " msg chan message case appNewBestResultSlackHook $ appSettings app of - Just "" -> return () Just hook -> liftIO $ sendAnnouncement hook message Nothing -> return () else diff --git a/Settings.hs b/Settings.hs index 242e6a0..402d9fe 100644 --- a/Settings.hs +++ b/Settings.hs @@ -17,6 +17,7 @@ import Network.Wai.Handler.Warp (HostPreference) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload) +import Web.Announcements (AnnouncementHook, toAnnouncementHook) import qualified Jose.Jwk as JWK @@ -101,7 +102,7 @@ data AppSettings = AppSettings , appTagPermissions :: TagPermissions , appAutoOpening :: Bool , appLeaderboardStyle :: LeaderboardStyle - , appNewBestResultSlackHook :: Maybe Text + , appNewBestResultSlackHook :: Maybe AnnouncementHook , appServerSSHPublicKey :: Maybe Text -- ^ Are challenges, submission, etc. visible without logging in , appIsPublic :: Bool @@ -153,7 +154,7 @@ instance FromJSON AppSettings where appAutoOpening <- o .:? "auto-opening" .!= False appLeaderboardStyle <- toLeaderboardStyle <$> o .: "leaderboard-style" - appNewBestResultSlackHook <- o .:? "new-best-result-slack-hook" + appNewBestResultSlackHook <- toAnnouncementHook' <$> (o .:? "new-best-result-slack-hook") appServerSSHPublicKey <- o .:? "server-ssh-public-key" @@ -169,6 +170,11 @@ instance FromJSON AppSettings where return AppSettings {..} +-- just in case, not sure if needed +toAnnouncementHook' :: Maybe Text -> Maybe AnnouncementHook +toAnnouncementHook' (Just "") = Nothing +toAnnouncementHook' h = (fmap toAnnouncementHook) h + -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. -- diff --git a/Web/Announcements.hs b/Web/Announcements.hs index 3f55caf..0564864 100644 --- a/Web/Announcements.hs +++ b/Web/Announcements.hs @@ -3,7 +3,9 @@ module Web.Announcements (sendAnnouncement, - formatLink) + formatLink, + AnnouncementHook(..), + toAnnouncementHook) where import Data.Text @@ -14,9 +16,15 @@ import Prelude import Data.Aeson import Data.Default +data AnnouncementHook = SlackWebHook Text -sendAnnouncement :: Text -> Text -> IO () -sendAnnouncement hook message = do +toAnnouncementHook :: Text -> AnnouncementHook +toAnnouncementHook url + | ".slack." `isInfixOf` url = SlackWebHook url + | otherwise = error $ "unknown hook type" + +sendAnnouncement :: AnnouncementHook -> Text -> IO () +sendAnnouncement (SlackWebHook hook) message = do let (Just (hookUrl, _)) = parseUrlHttps $ DTE.encodeUtf8 hook R.runReq def $ do @@ -28,5 +36,6 @@ sendAnnouncement hook message = do mempty return () -formatLink :: Text -> Text -> Text -formatLink url title = "<" <> url <> "|" <> title <> ">" +formatLink :: Maybe AnnouncementHook -> Text -> Text -> Text +formatLink (Just (SlackWebHook _)) url title = "<" <> url <> "|" <> title <> ">" +formatLink Nothing url title = title <> "<" <> url <> ">"