aboutsummaryrefslogtreecommitdiff
path: root/guix/forge
diff options
context:
space:
mode:
Diffstat (limited to 'guix/forge')
-rw-r--r--guix/forge/build/git.scm76
-rw-r--r--guix/forge/forge.scm287
-rw-r--r--guix/forge/laminar.scm135
-rw-r--r--guix/forge/utils.scm70
-rw-r--r--guix/forge/webhook.scm193
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))))