Refactor towards generalization of announcements

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

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 :: Maybe AnnouncementHook -> App -> Text -> Text -> Text
-slackLink app title addr = formatLink slink title
+slackLink hook app title addr = formatLink hook slink title
   where slink = (appRoot $ appSettings app) ++ "/" ++ addr
 
 formatVersion :: (Int, Int, Int) -> Text

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,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
+                                case mHook of
-                                  Just "" -> return ()
                                   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

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

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 ()
+toAnnouncementHook :: Text -> AnnouncementHook
-sendAnnouncement hook message = do
+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 :: Maybe AnnouncementHook -> Text -> Text -> Text
-formatLink url title = "<" <> url <> "|" <> title <> ">"
+formatLink (Just (SlackWebHook _)) url title = "<" <> url <> "|" <> title <> ">"
+formatLink Nothing url title = title <> "<" <> url <> ">"