s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

Refactor towards generalization of announcements

Browse Source
This commit is contained in:
Filip Gralinski 2021-08-21 10:08:41 +02:00
parent 8e9df1c311
commit 3dc9ae5dd8
5 changed files with 31 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/Announcements.hs
View File

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

6
Handler/Shared.hs
View File

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

9
Handler/ShowChallenge.hs
View File

@ -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,7 +953,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
(s:_) -> if compOp s b
then
do
let challengeLink = slackLink app (challengeTitle challenge) ("challenge/"
let challengeLink = slackLink mHook app (challengeTitle challenge) ("challenge/"
++ (challengeName challenge))
let message = ("Whoa! New best result for "
++ challengeLink
@ -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

10
Settings.hs
View File

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

19
Web/Announcements.hs
View File

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