Introduce course-specific announcement hooks

Foundation.hs

@@ -167,6 +167,7 @@ instance Yesod App where
     isAuthorized ExtraPointsR _ = isAdmin
 
     isAuthorized TestAnnouncementsR _ = isAdmin
+    isAuthorized (TestChallengeAnnouncementsR _) _ = isAdmin
 
     isAuthorized DashboardR _ = regularAuthorization
 

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"

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

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

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

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

config/models

@@ -195,6 +195,7 @@ Course
     name Text
     code Text
     closed Bool
+    announcementHook Text Maybe
     UniqueCourseName name
     UniqueCourseCode code
 ExtraPoints

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

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

templates/show-challenge.hamlet

@@ -13,6 +13,8 @@ $if (checkIfAdmin mUserEnt)
       <button>_{MsgArchive}
     <form method=get action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
       <button>_{MsgUpdate}
+    <form method=get action=@{TestChallengeAnnouncementsR (challengeName challenge)}#form enctype="text/plain">
+      <button>_{MsgTestChallengeAnnouncements}
 
  $if (challengeArchived challenge == Just True)
     <form method=post action=@{UnarchiveR challengeId}#form enctype="text/plain">

templates/test-challenge-announcements.hamlet

@@ -0,0 +1 @@
+<p>Activated!