diff options
Diffstat (limited to 'guix/forge')
| -rw-r--r-- | guix/forge/build/git.scm | 76 | ||||
| -rw-r--r-- | guix/forge/forge.scm | 287 | ||||
| -rw-r--r-- | guix/forge/laminar.scm | 135 | ||||
| -rw-r--r-- | guix/forge/utils.scm | 70 | ||||
| -rw-r--r-- | guix/forge/webhook.scm | 193 |
5 files changed, 761 insertions, 0 deletions
diff --git a/guix/forge/build/git.scm b/guix/forge/build/git.scm new file mode 100644 index 0000000..1434d07 --- /dev/null +++ b/guix/forge/build/git.scm @@ -0,0 +1,76 @@ +;;; 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 build git) + #:use-module (rnrs exceptions) + #:use-module (guix build utils) + #:use-module (guix store) + #:use-module (guix utils) + #:export (download-git-to-store + latest-git-checkout)) + +;;; +;;; Commentary: +;;; +;;; This module provides build-side code to download a git repository +;;; to the store. +;;; + +;;; Code: + +(define (hline) + "Print a horizontal line 50 '=' characters long." + (display (make-string 50 #\=)) + (newline) + (force-output)) + +(define* (download-git-to-store store name url #:key branch show-commit?) + "Download BRANCH of git repository from URL to STORE under NAME and +return store path. If BRANCH is not specified, the default branch is +downloaded. git and certificates should be in the environment." + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (guard (condition ((invoke-error? condition) + (format (current-error-port) + "'~a~{ ~a~}' failed with exit code ~a~%" + (invoke-error-program condition) + (invoke-error-arguments condition) + (invoke-error-exit-status condition)) + (exit #f))) + (apply invoke + "git" "clone" "--quiet" "--depth" "1" + ;; Append file:// to local repository path so that + ;; shallow clone works. + (if (string-prefix? "/" url) + (string-append "file://" url) + url) + (append (if branch + (list "--branch" branch) + (list)) + (list ".")))) + (when show-commit? + (hline) + (invoke "git" "--no-pager" "log") + (hline)) + (delete-file-recursively ".git")) + (add-to-store store name #t "sha256" directory)))) + +(define latest-git-checkout + (store-lift download-git-to-store)) diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm new file mode 100644 index 0000000..e88edb0 --- /dev/null +++ b/guix/forge/forge.scm @@ -0,0 +1,287 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2021, 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 forge) + #:use-module (gnu) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module ((gnu packages certs) #:select (nss-certs)) + #:use-module (gnu packages ci) + #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages guile) #:select (guile-3.0 guile-zlib)) + #:use-module ((gnu packages version-control) #:select (git-minimal)) + #:use-module (gnu services mcron) + #:use-module (guix modules) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (forge laminar) + #:use-module (forge utils) + #:use-module (forge webhook) + #:export (forge-service-type + forge-configuration + forge-configuration? + forge-configuration-projects + forge-project + forge-project? + this-forge-project + forge-project-name + forge-project-user + forge-project-repository + forge-project-repository-branch + forge-project-website-directory + forge-project-ci-jobs + forge-project-ci-jobs-trigger + derivation-job-gexp)) + +(define-record-type* <forge-project> + forge-project make-forge-project + forge-project? + this-forge-project + (name forge-project-name) + ;; The user field is optional because the repository may be remote + ;; and not need to be owned by any user. + (user forge-project-user + (default #f)) + (repository forge-project-repository) + (repository-branch forge-project-repository-branch + (default "main")) + (description forge-project-description + (default #f)) + (website-directory forge-project-website-directory + (default #f)) + (ci-jobs forge-project-ci-jobs + (default '()) (thunked)) + (ci-jobs-trigger forge-project-ci-jobs-trigger ; one of 'post-receive-hook, 'cron, 'webhook + (default (cond + ;; 'post-receive-hook for local repositories + ((string-prefix? "/" (forge-project-repository this-forge-project)) + 'post-receive-hook) + ;; 'cron for remote repositories + (else 'cron))) + (thunked))) + +(define-record-type* <forge-configuration> + forge-configuration make-forge-configuration + forge-configuration? + (projects forge-configuration-projects + (default '()))) + +(define* (ci-jobs-trigger-gexp ci-jobs #:key reason) + "Return a G-expression that triggers CI-JOBS. CI-JOBS is a list of +<forge-laminar-job> objects." + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + ;; TODO: Only trigger on updates to the main/master branch. + (display "Triggering continuous integration jobs..." (current-error-port)) + (newline (current-error-port)) + (when #$reason + (setenv "LAMINAR_REASON" #$reason)) + (apply invoke + #$(file-append laminar "/bin/laminarc") + "queue" '#$(map forge-laminar-job-name ci-jobs))))) + +(define (forge-activation config) + (let ((projects + (map (lambda (project) + (list (forge-project-user project) + (forge-project-repository project) + (forge-project-description project) + (forge-project-website-directory project) + (program-file + (forge-project-name project) + (ci-jobs-trigger-gexp + (forge-project-ci-jobs project) + #:reason "post-receive hook")) + (forge-project-ci-jobs-trigger project))) + (forge-configuration-projects config)))) + #~(begin + (use-modules (rnrs io ports) + (srfi srfi-26) + (ice-9 match)) + + (define (find-regular-files dir) + (find-files dir (lambda (file stat) + (memq (stat:type stat) + '(regular directory))) + #:directories? #t)) + + (for-each (match-lambda + ((username repository description website-directory ci-jobs-trigger ci-jobs-trigger-type) + ;; For local repositories only + (when (string-prefix? "/" repository) + ;; Set description. + (when description + (call-with-output-file (string-append repository "/description") + (cut put-string <> description))) + ;; Set ownership of repository files. + (for-each (lambda (file) + (let ((user (getpw username))) + (chown file (passwd:uid user) (passwd:gid user)))) + (append (find-regular-files repository)))) + ;; Install post receive hook. + (when (eq? ci-jobs-trigger-type 'post-receive-hook) + (let ((hook-link (string-append repository "/hooks/post-receive"))) + (when (file-exists? hook-link) + (delete-file hook-link)) + (symlink ci-jobs-trigger hook-link))) + ;; Set ownership of website directory. + (when website-directory + (let ((user (getpw "laminar"))) + (chown website-directory (passwd:uid user) (passwd:gid user)))))) + '#$projects)))) + +(define (import-module? name) + "Return #t if module NAME may be imported. Else, return #f." + (match name + (('forge _ ...) #t) + (name (guix-module-name? name)))) + +(define* (derivation-job-gexp project job gexp-producer + #:key (guix-daemon-uri (%daemon-socket-uri))) + "Return a G-expression that builds another G-expression as a +derivation and returns its output path. GEXP-PRODUCER is a +G-expression that expands to a lambda function. The lambda function +takes one argument---the latest git checkout of PROJECT, a +<forge-project> object---and returns a G-expression describing a +derivation to run. JOB is a <forge-laminar-job> object representing +the job that this derivation will be part of. GUIX_DAEMON_URI is a +file name or URI designating the Guix daemon endpoint." + (with-imported-modules (source-module-closure '((forge build git) + (guix gexp) + (guix profiles)) + #:select? import-module?) + (with-extensions (list guile-gcrypt guile-zlib) + (with-packages (list git-minimal nss-certs) + #~(begin + ;; We pull out macros using module-ref and functions using + ;; @@ instead of using use-modules because this gexp might + ;; be substituted into other gexps and use-modules only + ;; works at the top-level. + (let-syntax ((guard (macro-transformer + (module-ref (resolve-module '(rnrs exceptions)) + 'guard))) + (mbegin (macro-transformer + (module-ref (resolve-module '(guix monads)) + 'mbegin))) + (mlet* (macro-transformer + (module-ref (resolve-module '(guix monads)) + 'mlet*))) + (with-store (macro-transformer + (module-ref (resolve-module '(guix store)) + 'with-store))) + (return (identifier-syntax ((@@ (guix store) %store-monad) + %return)))) + (let* ((latest-git-checkout (@@ (forge build git) latest-git-checkout)) + (built-derivations (@@ (guix derivations) built-derivations)) + (derivation->output-path (@@ (guix derivations) derivation->output-path)) + (read-derivation-from-file (@@ (guix derivations) read-derivation-from-file)) + (gexp->derivation (@@ (guix gexp) gexp->derivation)) + (%daemon-socket-uri (@@ (guix store) %daemon-socket-uri)) + (%store-monad (@@ (guix store) %store-monad)) + (store-protocol-error? (@@ (guix store) store-protocol-error?)) + (run-with-store (@@ (guix store) run-with-store)) + (derivation-output + (parameterize ((%daemon-socket-uri #$guix-daemon-uri)) + (with-store store + (guard (condition ((store-protocol-error? condition) + (exit #f))) + (run-with-store store + (mlet* %store-monad ((git-checkout (latest-git-checkout + #$(string-append (forge-project-name project) + "-checkout") + #$(forge-project-repository project) + #:show-commit? #t)) + (drv (gexp->derivation #$(string-append + (forge-laminar-job-name job) + "-derivation") + (#$gexp-producer git-checkout) + #:guile-for-build (read-derivation-from-file + #$(raw-derivation-file + (with-store store + (package-derivation store guile-3.0)))) + #:substitutable? #f))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (derivation->output-path drv)))))))))) + (format (current-error-port) "Built ~a successfully~%" derivation-output) + derivation-output))))))) + +(define forge-service-type + (service-type + (name 'forge) + (description "Run guix-forge.") + (extensions (list (service-extension activation-service-type + forge-activation) + (service-extension forge-laminar-service-type + (lambda (config) + (append + ;; jobs + (append-map forge-project-ci-jobs + (forge-configuration-projects config)) + ;; group jobs by project + (filter-map (lambda (project) + (match (forge-project-ci-jobs project) + (() #f) + ((job) #f) + (jobs + (forge-laminar-group + (name (forge-project-name project)) + (regex (string-append "^(?:" + (string-join (map forge-laminar-job-name jobs) + "|") + ")$")))))) + (forge-configuration-projects config))))) + ;; Set up cron jobs to trigger CI jobs for remote + ;; repositories. + ;; TODO: Run CI job only if there are new commits + ;; in the remote repository. + (service-extension mcron-service-type + (lambda (config) + (filter-map (lambda (project) + (and (eq? (forge-project-ci-jobs-trigger project) + 'cron) + #~(job '(next-day) + #$(program-file + (forge-project-name project) + (ci-jobs-trigger-gexp + (forge-project-ci-jobs project) + #:reason "Cron job")) + #:user "laminar"))) + (forge-configuration-projects config)))) + (service-extension webhook-service-type + (lambda (config) + (filter-map (lambda (project) + (and (eq? (forge-project-ci-jobs-trigger project) + 'webhook) + (webhook-hook + (id (forge-project-name project)) + (run (ci-jobs-trigger-gexp + (forge-project-ci-jobs project) + #:reason "Webhook"))))) + (forge-configuration-projects config)))))) + (compose concatenate) + (extend (lambda (config projects) + (forge-configuration + (inherit config) + (projects (append (forge-configuration-projects config) + projects))))) + (default-value (forge-configuration)))) diff --git a/guix/forge/laminar.scm b/guix/forge/laminar.scm new file mode 100644 index 0000000..5d95372 --- /dev/null +++ b/guix/forge/laminar.scm @@ -0,0 +1,135 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2021, 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 laminar) + #:use-module (gnu) + #:use-module (srfi srfi-1) + #:use-module (gnu packages ci) + #:use-module (gnu services ci) + #:use-module (guix records) + #:export (forge-laminar-service-type + forge-laminar-configuration + forge-laminar-configuration? + forge-laminar-configuration-state-directory + forge-laminar-configuration-jobs + forge-laminar-job + forge-laminar-job? + this-forge-laminar-job + forge-laminar-job-name + forge-laminar-job-run + forge-laminar-job-after + forge-laminar-group + forge-laminar-group? + forge-laminar-group-name + forge-laminar-group-regex)) + +(define-record-type* <forge-laminar-configuration> + forge-laminar-configuration make-forge-laminar-configuration + forge-laminar-configuration? + (state-directory forge-laminar-configuration-state-directory + (default "/var/lib/laminar")) + (jobs forge-laminar-configuration-jobs + (default '())) + (groups forge-laminar-configuration-groups + (default '()))) + +(define-record-type* <forge-laminar-job> + forge-laminar-job make-forge-laminar-job + forge-laminar-job? + this-forge-laminar-job + (name forge-laminar-job-name) + (run forge-laminar-job-run (thunked)) + (after forge-laminar-job-after + (default #f))) + +(define-record-type* <forge-laminar-group> + forge-laminar-group make-forge-laminar-group + forge-laminar-group? + (name forge-laminar-group-name) + (regex forge-laminar-group-regex)) + +(define (forge-laminar-activation config) + (let* ((state-directory (forge-laminar-configuration-state-directory config)) + (configuration-directory (string-append state-directory "/cfg")) + (groups-configuration (string-append configuration-directory "/groups.conf")) + (jobs-directory (string-append configuration-directory "/jobs"))) + #~(begin + (use-modules (srfi srfi-26)) + + ;; Ensure configuration directory exists. + (mkdir-p #$configuration-directory) + ;; Configure groups. + (when (file-exists? #$groups-configuration) + (delete-file #$groups-configuration)) + (symlink + #$(plain-file "laminar-groups" + (string-join (map (lambda (group) + (string-append (forge-laminar-group-name group) + "=" + (forge-laminar-group-regex group))) + (forge-laminar-configuration-groups config)) + "\n")) + #$groups-configuration) + ;; Create jobs directory and populate with job scripts. + (mkdir-p #$(dirname jobs-directory)) + (when (file-exists? #$jobs-directory) + (delete-file #$jobs-directory)) + (symlink + #$(file-union "laminar-jobs" + (append-map (lambda (job) + (let ((name (forge-laminar-job-name job)) + (run (forge-laminar-job-run job)) + (after (forge-laminar-job-after job))) + (cons (list (string-append name ".run") + (program-file name run)) + (if after + (list (list (string-append name ".after") + (program-file name after))) + (list))))) + (forge-laminar-configuration-jobs config))) + #$jobs-directory) + ;; Set permissions for laminar directory. + (for-each (lambda (file) + (let ((user (getpw "laminar"))) + (chown file (passwd:uid user) (passwd:gid user)))) + (find-files #$state-directory + (lambda (file stat) + (memq (stat:type stat) + '(regular directory))) + #:directories? #t))))) + +(define forge-laminar-service-type + (service-type + (name 'forge-laminar) + (description "Run forge-laminar.") + (extensions (list (service-extension activation-service-type + forge-laminar-activation) + ;; Extend the laminar service with a dummy value, + ;; thus requiring it. + (service-extension laminar-service-type + (const #t)))) + (compose concatenate) + (extend (lambda (config extended-values) + (forge-laminar-configuration + (inherit config) + (jobs (append (forge-laminar-configuration-jobs config) + (filter forge-laminar-job? extended-values))) + (groups (append (forge-laminar-configuration-groups config) + (filter forge-laminar-group? extended-values)))))) + (default-value (forge-laminar-configuration)))) diff --git a/guix/forge/utils.scm b/guix/forge/utils.scm new file mode 100644 index 0000000..dd980ef --- /dev/null +++ b/guix/forge/utils.scm @@ -0,0 +1,70 @@ +;;; 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 utils) + #:use-module (ice-9 match) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix profiles) + #:use-module (guix search-paths) + #:use-module (guix store) + #:export (with-packages)) + +(define (profile-with-packages packages) + "Return profile with PACKAGES." + (with-store store + (run-with-store store + (mlet* %store-monad ((prof-drv (profile-derivation + (packages->manifest packages))) + (profile -> (derivation->output-path prof-drv))) + (mbegin %store-monad + (built-derivations (list prof-drv)) + (return profile)))))) + +(define (environment-with-packages packages) + "Return environment of a profile with PACKAGES. Return value is an +association list mapping the name of an environment variable to its +value." + (map (match-lambda + ((search-path . value) + (cons (search-path-specification-variable search-path) + value))) + (profile-search-paths (profile-with-packages packages)))) + +(define (with-packages packages exp) + "Return a gexp executing EXP, another gexp, in an environment where +PACKAGES are available and their search path environment variables +have been set." + #~(begin + ;; Add a reference to the profile. + #$(profile-with-packages packages) + ;; Set the environment. + ;; We pull out match-lambda using module-ref instead of using + ;; use-modules because this gexp will be substituted into other + ;; gexps and use-modules only works at the top-level. + (let-syntax ((match-lambda (macro-transformer + (module-ref (resolve-module '(ice-9 match)) + 'match-lambda)))) + (for-each (match-lambda + ((variable . value) + (setenv variable value))) + '#$(environment-with-packages packages))) + ;; Run the provided expression. + #$exp)) diff --git a/guix/forge/webhook.scm b/guix/forge/webhook.scm new file mode 100644 index 0000000..737b9e6 --- /dev/null +++ b/guix/forge/webhook.scm @@ -0,0 +1,193 @@ +;;; 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))))) + (default-value (webhook-configuration)))) |