Handle GitLab/Gogs webhooks

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

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] []

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