From 5c6afe3bda75644522f42426ddc680fd48f286dc Mon Sep 17 00:00:00 2001
From: Filip Gralinski <filip.gralinski@applica.pl>
Date: Sat, 30 May 2020 23:40:03 +0200
Subject: [PATCH] Handle GitLab/Gogs webhooks

---
 Foundation.hs            |  1 +
 Handler/ShowChallenge.hs | 36 ++++++++++++++++++++++++++++++++++++
 config/routes            |  2 ++
 3 files changed, 39 insertions(+)

diff --git a/Foundation.hs b/Foundation.hs
index e3cbec2..7eb3948 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -179,6 +179,7 @@ instance Yesod App where
     isAuthorized TriggerRemotelyR _ = return Authorized
     isAuthorized (TriggerRemotelySimpleR _ _ _ _) _ = return Authorized
     isAuthorized TriggerLocallyR _ = return Authorized
+    isAuthorized (TriggerByWebhookR _ _) _ = return Authorized
     isAuthorized (OpenViewProgressR _) _ = return Authorized
 
     isAuthorized CreateResetLinkR _ = isAdmin
diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs
index 94ba71d..aa20749 100644
--- a/Handler/ShowChallenge.hs
+++ b/Handler/ShowChallenge.hs
@@ -20,8 +20,12 @@ import Handler.Dashboard
 import Handler.Common
 import Handler.Evaluate
 
+import Data.Maybe (fromJust)
+
 import Text.Blaze
 
+import Data.Aeson
+
 import Gonito.ExtractMetadata (ExtractionOptions(..),
                                extractMetadataFromRepoDir,
                                GonitoMetadata(..),
@@ -279,6 +283,38 @@ getTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedConten
 getTriggerRemotelySimpleR token challengeName url branch =
   doTrigger token challengeName (decodeSlash url) (Just branch) Nothing
 
+data GitServerPayload = GitServerPayload {
+  gitServerPayloadRef :: Text,
+  -- Unfortunately, the URL is given in "ssh_url" field
+  -- for Gogs and "git_ssh_url" for GitLab, hence two
+  -- fields here
+  gitServerPayloadSshUrl :: Maybe Text,
+  gitServerPayloadGitSshUrl :: Maybe Text
+  }
+  deriving (Show, Eq)
+
+instance FromJSON GitServerPayload where
+    parseJSON (Object o) = GitServerPayload
+      <$> o .: "ref"
+      <*> ((o .: "repository") >>= (.:? "ssh_url"))
+      <*> ((o .: "repository") >>= (.:? "git_ssh_url"))
+
+postTriggerByWebhookR :: Text -> Text -> Handler TypedContent
+postTriggerByWebhookR token challengeName = do
+  payload <- requireJsonBody :: Handler GitServerPayload
+  let ref = gitServerPayloadRef payload
+  let refPrefix = "refs/heads/"
+  if refPrefix `isPrefixOf` ref
+    then
+      do
+        let branch = T.replace refPrefix "" ref
+        let url = fromMaybe (fromJust $ gitServerPayloadGitSshUrl payload)
+                            (gitServerPayloadSshUrl payload)
+        doTrigger token challengeName url (Just branch) Nothing
+    else
+      error $ "unexpected ref `" ++ (T.unpack ref) ++ "`"
+
+
 doTrigger :: Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
 doTrigger token challengeName url mBranch mGitAnnexRemote = do
   [Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
diff --git a/config/routes b/config/routes
index fdd68a2..74c6588 100644
--- a/config/routes
+++ b/config/routes
@@ -27,6 +27,8 @@
 /trigger-remotely TriggerRemotelyR POST
 /trigger-remotely-simple/#Text/#Text/#Text/#Text TriggerRemotelySimpleR GET POST
 /trigger-locally TriggerLocallyR POST
+-- trigger by JSON payload (from e.g. GitLab or Gogs)
+/trigger-by-webhook/#Text/#Text TriggerByWebhookR POST
 
 /indicator-graph-data/#IndicatorId IndicatorGraphDataR GET