From 270d4b2607391cb3e822d3f42894a1126290b4da Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Tue, 18 Jan 2022 22:54:07 +0100 Subject: [PATCH] Introduce course-specific announcement hooks --- Foundation.hs | 1 + Handler/Announcements.hs | 52 ++++++++++++++++--- Handler/Course.hs | 1 - Handler/Shared.hs | 5 +- Handler/ShowChallenge.hs | 49 ++++++++--------- Web/Announcements.hs | 23 ++++++-- config/models | 1 + config/routes | 1 + messages/en.msg | 1 + templates/show-challenge.hamlet | 2 + templates/test-challenge-announcements.hamlet | 1 + 11 files changed, 99 insertions(+), 38 deletions(-) create mode 100644 templates/test-challenge-announcements.hamlet diff --git a/Foundation.hs b/Foundation.hs index fc22c2f..2bb65e7 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -167,6 +167,7 @@ instance Yesod App where isAuthorized ExtraPointsR _ = isAdmin isAuthorized TestAnnouncementsR _ = isAdmin + isAuthorized (TestChallengeAnnouncementsR _) _ = isAdmin isAuthorized DashboardR _ = regularAuthorization diff --git a/Handler/Announcements.hs b/Handler/Announcements.hs index e07c9da..b381695 100644 --- a/Handler/Announcements.hs +++ b/Handler/Announcements.hs @@ -3,7 +3,44 @@ module Handler.Announcements where import Import import Handler.Shared -import Web.Announcements (sendAnnouncement) +import Web.Announcements (sendAnnouncement, + AnnouncementPiece(..), + AnnouncementMessage, + AnnouncementHook, + toAnnouncementHook) + +import qualified Database.Esqueleto as E +import Database.Esqueleto ((^.)) + +sendChallengeAnnouncement :: ChallengeId -> AnnouncementMessage -> Handler () +sendChallengeAnnouncement challengeId announcementMsg = do + hooks <- fetchChallengeHooks challengeId + liftIO $ mapM_ (\hook -> sendAnnouncement hook announcementMsg) hooks + +fetchChallengeHooks :: ChallengeId -> Handler [AnnouncementHook] +fetchChallengeHooks challengeId = do + courses <- runDB $ E.select $ E.from $ \(course, course_challenge) -> do + E.where_ (course_challenge ^. CourseChallengeChallenge E.==. E.val challengeId + E.&&. course_challenge ^. CourseChallengeCourse E.==. course ^. CourseId) + return course + + case catMaybes $ map (courseAnnouncementHook . entityVal) courses of + [] -> do + app <- getYesod + let mWebHook = appAnnouncementHook $ appSettings app + return $ maybeToList mWebHook + hooks -> return $ map toAnnouncementHook hooks + +getTestChallengeAnnouncementsR :: Text -> Handler Html +getTestChallengeAnnouncementsR challengeName = do + (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName + + app <- getYesod + sendChallengeAnnouncement challengeId (testMessage app) + + defaultLayout $ do + setTitle "Test announcements" + $(widgetFile "test-challenge-announcements") getTestAnnouncementsR :: Handler Html getTestAnnouncementsR = do @@ -11,14 +48,17 @@ getTestAnnouncementsR = do let webHook = appAnnouncementHook $ appSettings app - let name = case appLocation $ appSettings app of - Just loc -> "Gonito@" ++ loc - Nothing -> "Gonito" - case webHook of - Just hook -> liftIO $ sendAnnouncement hook ("Test message from " ++ (linkInAnnouncement (Just hook) app name "")) + Just hook -> liftIO $ sendAnnouncement hook (testMessage app) Nothing -> return () defaultLayout $ do setTitle "Test announcements" $(widgetFile "test-announcements") + +testMessage :: App -> AnnouncementMessage +testMessage app = [AnnouncementText "Test message from ", + (linkInAnnouncement app name "")] + where name = case appLocation $ appSettings app of + Just loc -> "Gonito@" ++ loc + Nothing -> "Gonito" diff --git a/Handler/Course.hs b/Handler/Course.hs index 228209c..f68e57b 100644 --- a/Handler/Course.hs +++ b/Handler/Course.hs @@ -2,7 +2,6 @@ module Handler.Course where import Import -import Handler.Shared import Handler.ListChallenges import qualified Database.Esqueleto as E diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 21663d7..d58db4b 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -13,6 +13,7 @@ import Yesod.WebSockets import Handler.Runner import System.Exit +import Web.Announcements import qualified Data.Text as T @@ -753,8 +754,8 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering compareFun TheLowerTheBetter = flip compare compareFun TheHigherTheBetter = compare -linkInAnnouncement :: Maybe AnnouncementHook -> App -> Text -> Text -> Text -linkInAnnouncement hook app title addr = formatLink hook slink title +linkInAnnouncement :: App -> Text -> Text -> AnnouncementPiece +linkInAnnouncement app title addr = AnnouncementLink slink title where slink = (appRoot $ appSettings app) ++ "/" ++ addr formatVersion :: (Int, Int, Int) -> Text diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index d3c2923..ea86ab1 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -32,6 +32,7 @@ import Handler.Common import Handler.Evaluate import Handler.JWT import Handler.Team +import Handler.Announcements import Database.Persist.Sql (fromSqlKey) @@ -87,7 +88,6 @@ instance ToJSON Import.Tag where instance ToSchema Import.Tag where declareNamedSchema _ = do stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) - boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) return $ NamedSchema (Just "Tag") $ mempty & type_ .~ SwaggerObject & properties .~ @@ -1000,9 +1000,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do msg chan "SUBMISSION CREATED" app <- getYesod - let mHook = appAnnouncementHook $ appSettings app - - let submissionLink = linkInAnnouncement mHook app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo))) + let submissionLink = linkInAnnouncement app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo))) case mMainEnt of Just (Entity mainTestId mainTest) -> do @@ -1020,13 +1018,13 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do (s:_) -> if compOp s b then do - let challengeLink = linkInAnnouncement mHook app (challengeTitle challenge) ("challenge/" + let challengeLink = linkInAnnouncement app (challengeTitle challenge) ("challenge/" ++ (challengeName challenge)) let formattingOpts = getTestFormattingOpts mainTest - let message = ("Whoa! New best result for " - ++ challengeLink - ++ " challenge by " + let message = [AnnouncementText "Whoa! New best result for ", + challengeLink, + AnnouncementText (" challenge by " ++ (fromMaybe "???" $ userName user) ++ ", " ++ (T.pack $ evaluationSchemeName $ testMetric mainTest) @@ -1038,13 +1036,11 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do else "") ++ (T.pack $ formatTheResult formattingOpts (SimpleRun (s-b))) ++ ")." - ++ " See " ++ submissionLink ++ "." - ++ " :clap:") - msg chan message - case mHook of - Just hook -> liftIO $ sendAnnouncement hook message - - Nothing -> return () + ++ " See "), + submissionLink, + AnnouncementText ("." ++ " :clap:")] + msg chan $ renderAnnouncementMessage Nothing message + sendChallengeAnnouncement challengeId message else return () [] -> return () Nothing -> return () @@ -1064,34 +1060,35 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do Nothing -> return () -checkIndicators :: User -> ChallengeId -> SubmissionId -> Text -> [IndicatorEntry] -> Channel -> Handler () +checkIndicators :: User -> ChallengeId -> SubmissionId -> AnnouncementPiece -> [IndicatorEntry] -> Channel -> Handler () checkIndicators user challengeId submissionId submissionLink relevantIndicators chan = do msg chan "Checking indicators..." theNow <- liftIO $ getCurrentTime mapM_ (\indicator -> checkIndicator theNow user challengeId submissionId submissionLink indicator chan) relevantIndicators -checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () +checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> AnnouncementPiece -> IndicatorEntry -> Channel -> Handler () checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator) -checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () +checkTarget :: UTCTime -> User -> AnnouncementPiece -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () checkTarget theNow user submissionLink entries indicator target chan = do - app <- getYesod + let challengeId = entityKey $ indicatorEntryChallenge indicator + let status = getTargetStatus theNow entries indicator target if status == TargetPassed then do - let message = "Congratulations!!! The target " ++ indicatorText + let message = [AnnouncementText ("Congratulations!!! The target " ++ indicatorText ++ " was beaten by " ++ (fromMaybe "???" $ userName user) ++ ", " - ++ " See " ++ submissionLink ++ "." - ++ (T.replicate 10 " :champagne: ") ++ " :mleczko: " - msg chan message - case appAnnouncementHook $ appSettings app of - Just hook -> liftIO $ sendAnnouncement hook message - Nothing -> return () + ++ " See "), + submissionLink, + AnnouncementText ("." + ++ (T.replicate 10 " :champagne: ") ++ " :mleczko: ")] + msg chan $ renderAnnouncementMessage Nothing message + sendChallengeAnnouncement challengeId message else return () where indicatorText = prettyIndicatorEntry indicator diff --git a/Web/Announcements.hs b/Web/Announcements.hs index 56f84e0..c26bc64 100644 --- a/Web/Announcements.hs +++ b/Web/Announcements.hs @@ -5,6 +5,9 @@ module Web.Announcements (sendAnnouncement, formatLink, AnnouncementHook(..), + AnnouncementPiece(..), + AnnouncementMessage, + renderAnnouncementMessage, toAnnouncementHook) where @@ -18,15 +21,29 @@ import Data.Default data AnnouncementHook = SlackWebHook Text | DiscordWebHook Text +data AnnouncementPiece = AnnouncementText Text | AnnouncementLink Text Text + +type AnnouncementMessage = [AnnouncementPiece] + +renderAnnouncementMessage :: Maybe AnnouncementHook -> AnnouncementMessage -> Text +renderAnnouncementMessage hook pieces = Data.Text.concat $ Prelude.map (renderAnnouncementPiece hook) pieces + +renderAnnouncementPiece :: Maybe AnnouncementHook -> AnnouncementPiece -> Text +renderAnnouncementPiece _ (AnnouncementText t) = t +renderAnnouncementPiece mHook (AnnouncementLink url title) = formatLink mHook url title + toAnnouncementHook :: Text -> AnnouncementHook toAnnouncementHook url | ".slack." `isInfixOf` url = SlackWebHook url | "discord.com" `isInfixOf` url = DiscordWebHook url | otherwise = error $ unpack $ "unknown hook type '" <> url <> "'" -sendAnnouncement :: AnnouncementHook -> Text -> IO () -sendAnnouncement (SlackWebHook hook) message = sendAnnouncementViaJson hook "text" message -sendAnnouncement (DiscordWebHook hook) message = sendAnnouncementViaJson hook "content" message +sendAnnouncement :: AnnouncementHook -> AnnouncementMessage -> IO () +sendAnnouncement hook message = sendAnnouncement' hook $ renderAnnouncementMessage (Just hook) message + +sendAnnouncement' :: AnnouncementHook -> Text -> IO () +sendAnnouncement' (SlackWebHook hook) message = sendAnnouncementViaJson hook "text" message +sendAnnouncement' (DiscordWebHook hook) message = sendAnnouncementViaJson hook "content" message sendAnnouncementViaJson :: Text -> Text -> Text -> IO () sendAnnouncementViaJson hook fieldName message = do diff --git a/config/models b/config/models index e565ac2..d599e36 100644 --- a/config/models +++ b/config/models @@ -195,6 +195,7 @@ Course name Text code Text closed Bool + announcementHook Text Maybe UniqueCourseName name UniqueCourseCode code ExtraPoints diff --git a/config/routes b/config/routes index c6e3430..3abfa2d 100644 --- a/config/routes +++ b/config/routes @@ -18,6 +18,7 @@ /course/#Text CourseR GET /test-announcements TestAnnouncementsR GET +/test-challenge-announcements/#Text TestChallengeAnnouncementsR GET /api/list-challenges ListChallengesJsonR GET /api/leaderboard/#Text LeaderboardJsonR GET diff --git a/messages/en.msg b/messages/en.msg index 7c7cc76..56927f8 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -109,3 +109,4 @@ NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYB TestAnnouncements: test announcements Color: color name or hex value Phase: competition phase (use a pre-existing tag) +TestChallengeAnnouncements: Test announcements diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index 7d00292..2a97884 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -13,6 +13,8 @@ $if (checkIfAdmin mUserEnt)