filipg
/
gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Introduce course-specific announcement hooks

This commit is contained in:
Filip Gralinski 2022-01-18 22:54:07 +01:00
parent 36ad24dba5
commit 270d4b2607
11 changed files with 99 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Foundation.hs
View File

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

52
Handler/Announcements.hs
View File

@ -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"

1
Handler/Course.hs
View File

@ -2,7 +2,6 @@ module Handler.Course where
import Import
import Handler.Shared
import Handler.ListChallenges
import qualified Database.Esqueleto as E

5
Handler/Shared.hs
View File

@ -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

49
Handler/ShowChallenge.hs
View File

@ -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

23
Web/Announcements.hs
View File

@ -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

1
config/models
View File

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

1
config/routes
View File

@ -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

1
messages/en.msg
View File

@ -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

2
templates/show-challenge.hamlet
View File

@ -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">

1
templates/test-challenge-announcements.hamlet Normal file
View File

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