forge: Add webhook service.

* forge/webhook.scm: New file.

1 files changed, 192 insertions, 0 deletions

diff --git a/forge/webhook.scm b/forge/webhook.scm
new file mode 100644
index 0000000..e61494b
--- /dev/null
+++ b/forge/webhook.scm
@@ -0,0 +1,192 @@
+;;; guix-forge --- Guix software forge meta-service
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of guix-forge.
+;;;
+;;; guix-forge is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; guix-forge is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with guix-forge.  If not, see
+;;; <https://www.gnu.org/licenses/>.
+
+(define-module (forge webhook)
+  #:use-module (srfi srfi-1)
+  #:use-module ((gnu packages admin) #:select (shadow))
+  #:use-module ((gnu packages guile) #:select (guile-json-4))
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system accounts)
+  #:use-module (gnu system shadow)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix records)
+  #:use-module (guix packages)
+  #:use-module (guix git-download)
+  #:use-module (guix build-system go)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:export (webhook-service-type
+            webhook-configuration
+            webhook-configuration?
+            webhook-configuration-package
+            webhook-configuration-port
+            webhook-configuration-log-directory
+            webhook-configuration-hooks
+            webhook-hook
+            webhook-hook?
+            webhook-hook-id
+            webhook-hook-run))
+
+(define webhook
+  (package
+    (name "webhook")
+    (version "2.8.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/adnanh/webhook")
+                    (commit version)))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0n03xkgwpzans0cymmzb0iiks8mi2c76xxdak780dk0jbv6qgp5i"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/adnanh/webhook"
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'configure
+           (lambda* (#:key inputs #:allow-other-keys)
+             (substitute* "src/github.com/adnanh/webhook/webhook_test.go"
+               (("/bin/echo")
+                (string-append (assoc-ref inputs "coreutils")
+                               "/bin/echo"))))))))
+    (home-page "https://github.com/adnanh/webhook")
+    (synopsis "Lightweight incoming webhook server")
+    (description "webhook is a lightweight configurable tool written
+in Go, that allows you to easily create HTTP endpoints (hooks) on your
+server, which you can use to execute configured commands. You can also
+pass data from the HTTP request (such as headers, payload or query
+variables) to your commands. webhook also allows you to specify rules
+which have to be satisfied in order for the hook to be triggered.
+
+For example, if you're using Github or Bitbucket, you can use webhook
+to set up a hook that runs a redeploy script for your project on your
+staging server, whenever you push changes to the master branch of your
+project.
+
+If you use Mattermost or Slack, you can set up an \"Outgoing webhook
+integration\" or \"Slash command\" to run various commands on your
+server, which can then report back directly to you or your channels
+using the \"Incoming webhook integrations\", or the appropriate
+response body.
+
+webhook aims to do nothing more than it should do, and that is:
+
+@itemize
+@item receive the request,
+@item parse the headers, payload and query variables,
+@item check if the specified rules for the hook are satisfied,
+@item and finally, pass the specified arguments to the specified
+command via command line arguments or via environment variables.
+@end itemize
+
+Everything else is the responsibility of the command's author.")
+    (license license:expat)))
+
+(define-record-type* <webhook-configuration>
+  webhook-configuration make-webhook-configuration
+  webhook-configuration?
+  (package webhook-configuration-package
+           (default webhook))
+  (ip webhook-configuration-ip
+      (default "127.0.0.1"))
+  (port webhook-configuration-port
+        (default 9000))
+  (log-directory webhook-configuration-log-directory
+                 (default "/var/log/webhook"))
+  (hooks webhook-configuration-hooks
+         (default '())))
+
+(define-record-type* <webhook-hook>
+  webhook-hook make-webhook-hook
+  webhook-hook?
+  (id webhook-hook-id)
+  (run webhook-hook-run))
+
+(define (webhook-activation config)
+  ;; Create log directory.
+  #~(mkdir-p #$(webhook-configuration-log-directory config)))
+
+(define (hooks-json-gexp config)
+  (with-extensions (list guile-json-4)
+    #~(begin
+        (use-modules (srfi srfi-26)
+                     (json))
+        
+        (call-with-output-file #$output
+          (cut scm->json
+               ;; We convert from list to vector on the build-side
+               ;; because a vector cannot be lowered correctly into a
+               ;; G-expression.
+               (list->vector
+                ;; We build a true dotted association list in this
+                ;; roundabout way because a true dotted association
+                ;; list cannot be lowered correctly into a
+                ;; G-expression.
+                (map (cut map (cut apply cons <>) <>)
+                     '#$(map (lambda (hook)
+                               `(("id" ,(webhook-hook-id hook))
+                                 ("execute-command" ,(program-file (webhook-hook-id hook)
+                                                                   (webhook-hook-run hook)))))
+                             (webhook-configuration-hooks config))))
+               <>)))))
+
+(define webhook-shepherd-service
+  (lambda (config)
+    (shepherd-service
+     (documentation "Run webhook.")
+     (provision '(webhook))
+     (requirement '(networking))
+     (modules '((gnu build shepherd)
+                (gnu system file-systems)))
+     (start (with-imported-modules (source-module-closure
+                                    '((gnu build shepherd)
+                                      (gnu system file-systems)))
+              #~(make-forkexec-constructor/container
+                 (list #$(file-append (webhook-configuration-package config)
+                                      "/bin/webhook")
+                       "-hooks" #$(computed-file "hooks.json"
+                                                 (hooks-json-gexp config))
+                       "-ip" #$(webhook-configuration-ip config)
+                       "-port" #$(number->string (webhook-configuration-port config))
+                       "-logfile" #$(string-append (webhook-configuration-log-directory config)
+                                                   "/webhook.log"))
+                 #:mappings (list (file-system-mapping
+                                   (source #$(webhook-configuration-log-directory config))
+                                   (target source)
+                                   (writable? #t)))
+                 #:log-file "/var/log/webhook.log")))
+     (stop #~(make-kill-destructor)))))
+
+(define webhook-service-type
+  (service-type
+   (name 'webhook)
+   (description "Run webhook.")
+   (extensions (list (service-extension activation-service-type
+                                        webhook-activation)
+                     (service-extension shepherd-root-service-type
+                                        (compose list webhook-shepherd-service))))
+   (compose concatenate)
+   (extend (lambda (config hook-extensions)
+             (webhook-configuration
+              (inherit config)
+              (hooks (append (webhook-configuration-hooks config)
+                             hook-extensions)))))))