diff options
Diffstat (limited to 'forge')
| -rw-r--r-- | forge/build/git.scm | 76 | ||||
| -rw-r--r-- | forge/forge.scm | 287 | ||||
| -rw-r--r-- | forge/laminar.scm | 135 | ||||
| -rw-r--r-- | forge/utils.scm | 70 | ||||
| -rw-r--r-- | forge/webhook.scm | 193 |
5 files changed, 0 insertions, 761 deletions
diff --git a/forge/build/git.scm b/forge/build/git.scm deleted file mode 100644 index 1434d07..0000000 --- a/forge/build/git.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;; 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/forge/forge.scm b/forge/forge.scm deleted file mode 100644 index e88edb0..0000000 --- a/forge/forge.scm +++ /dev/null @@ -1,287 +0,0 @@ -;;; 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/forge/laminar.scm b/forge/laminar.scm deleted file mode 100644 index 5d95372..0000000 --- a/forge/laminar.scm +++ /dev/null @@ -1,135 +0,0 @@ -;;; 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/forge/utils.scm b/forge/utils.scm deleted file mode 100644 index dd980ef..0000000 --- a/forge/utils.scm +++ /dev/null @@ -1,70 +0,0 @@ -;;; 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/forge/webhook.scm b/forge/webhook.scm deleted file mode 100644 index 737b9e6..0000000 --- a/forge/webhook.scm +++ /dev/null @@ -1,193 +0,0 @@ -;;; 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)))) |