From 3447b29a82fa0f4d73918a8ff996a28096588780 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Filip=20Grali=C5=84ski?= <filip.gralinski@applica.ai>
Date: Wed, 14 Nov 2018 17:41:01 +0100
Subject: [PATCH] Handle Slack hooks

---
 Handler/Shared.hs        | 18 +++++++++++++++++-
 Handler/ShowChallenge.hs | 25 +++++++++++++++++++++++--
 Settings.hs              |  3 +++
 config/settings.yml      |  1 +
 gonito.cabal             |  1 +
 5 files changed, 45 insertions(+), 3 deletions(-)

diff --git a/Handler/Shared.hs b/Handler/Shared.hs
index 040f566..80412b5 100644
--- a/Handler/Shared.hs
+++ b/Handler/Shared.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 
 module Handler.Shared where
 
@@ -10,6 +11,7 @@ import Handler.Runner
 import System.Exit
 
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as DTE
 
 import Database.Persist.Sql (fromSqlKey)
 
@@ -37,11 +39,12 @@ import System.IO.Unsafe (unsafePerformIO)
 
 import Text.Regex.TDFA
 
-import Data.Aeson.Types
 import GEval.Core
 
 import qualified Data.Vector as DV
 
+import Network.HTTP.Req as R
+
 arena :: Handler FilePath
 arena = do
   app <- getYesod
@@ -399,3 +402,16 @@ getIsHigherTheBetterArray = Array
 compareFun :: MetricOrdering -> Double -> Double -> Ordering
 compareFun TheLowerTheBetter = flip compare
 compareFun TheHigherTheBetter = compare
+
+runSlackHook :: Text -> Text -> IO ()
+runSlackHook hook message = do
+  let (Just (hookUrl, _)) = parseUrlHttps $ DTE.encodeUtf8 hook
+
+  R.runReq def $ do
+    let payload = object [ "text" .= message ]
+    (_ :: JsonResponse Value) <- R.req R.POST
+                                hookUrl
+                                (R.ReqBodyJson payload)
+                                R.jsonResponse
+                                mempty
+    return ()
diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs
index 7c36a54..ae3bcb6 100644
--- a/Handler/ShowChallenge.hs
+++ b/Handler/ShowChallenge.hs
@@ -241,6 +241,8 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
   case maybeRepoKey of
     Just repoId -> do
 
+      challenge <- runDB $ get404 challengeId
+
       activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
       let (Entity mainTestId mainTest) = getMainTest activeTests
 
@@ -253,7 +255,7 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
                         E.&&. submission ^. SubmissionIsHidden E.!=. E.val (Just True)
                         E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
                         E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
-                        E.&&. evaluation ^. EvaluationScore E.!=. E.val Nothing
+                        E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
                         E.&&. out ^. OutVariant E.==. variant ^. VariantId
                         E.&&. evaluation ^. EvaluationTest E.==. E.val mainTestId)
               E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
@@ -304,7 +306,26 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
       case bestScoreSoFar of
         Just b ->  case newScores'' of
                     (s:_) -> if compOp s b
-                             then msg chan "New record!"
+                             then
+                              do
+                                app <- getYesod
+                                let submissionLink = (appRoot $ appSettings app) ++ "/q/" ++ (fromSHA1ToText (repoCurrentCommit repo))
+                                let message = ("Whoa! New best result for '"
+                                               ++ (challengeName challenge)
+                                               ++ "' challenge, "
+                                               ++ (T.pack $ show $ testMetric mainTest)
+                                               ++ " ("
+                                               ++ (if s > b
+                                                   then "+"
+                                                   else "")
+                                               ++ (T.pack $ show $ s-b)
+                                               ++ ")"
+                                               ++ " See <" ++ submissionLink ++ "|Submission>")
+                                msg chan message
+                                case appNewBestResultSlackHook $ appSettings app of
+                                  Just hook -> liftIO $ runSlackHook hook message
+
+                                  Nothing -> return ()
                              else return ()
                     [] -> return ()
         Nothing -> return ()
diff --git a/Settings.hs b/Settings.hs
index e0922c6..2aa7e48 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -88,6 +88,7 @@ data AppSettings = AppSettings
     , appTagPermissions         :: TagPermissions
     , appAutoOpening            :: Bool
     , appLeaderboardStyle       :: LeaderboardStyle
+    , appNewBestResultSlackHook :: Maybe Text
     }
 
 instance FromJSON AppSettings where
@@ -127,6 +128,8 @@ instance FromJSON AppSettings where
         appAutoOpening            <- o .:? "auto-opening" .!= False
         appLeaderboardStyle       <- toLeaderboardStyle <$> o .: "leaderboard-style"
 
+        appNewBestResultSlackHook <- o .:? "new-best-result-slack-hook"
+
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and
diff --git a/config/settings.yml b/config/settings.yml
index 8c306e1..7ae59fc 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -13,6 +13,7 @@ repo-scheme:     "_env:REPO_SCHEME:selfhosted"
 tag-permissions: "_env:TAG_PERMISSIONS:only-admin-can-add-new-tags"
 auto-opening:    "_env:AUTO_OPENING:false"
 leaderboard-style: "_env:LEADERBOARD_STYLE:by-submitter"
+new-best-result-slack-hook: "_env:NEW_BEST_RESULT_SLACK_HOOK:"
 
 # Optional values with the following production defaults.
 # In development, they default to the inverse.
diff --git a/gonito.cabal b/gonito.cabal
index 3989b4b..9f4c1f5 100644
--- a/gonito.cabal
+++ b/gonito.cabal
@@ -146,6 +146,7 @@ library
                  , wai
                  , megaparsec
                  , Glob
+                 , req
 
 executable         gonito
     if flag(library-only)