From cb7cecae3f6152052bdaf601eb1f6fcb2727b6b9 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 2 Mar 2022 17:55:27 +0530 Subject: Move channel modules into subdirectory. We don't want the scm files in doc to be picked up on `guix pull'. * .guix-channel: New file. * forge: Move to guix/forge. --- .guix-channel | 3 + forge/build/git.scm | 76 ------------- forge/forge.scm | 287 ----------------------------------------------- forge/laminar.scm | 135 ---------------------- forge/utils.scm | 70 ------------ forge/webhook.scm | 193 ------------------------------- guix/forge/build/git.scm | 76 +++++++++++++ guix/forge/forge.scm | 287 +++++++++++++++++++++++++++++++++++++++++++++++ guix/forge/laminar.scm | 135 ++++++++++++++++++++++ guix/forge/utils.scm | 70 ++++++++++++ guix/forge/webhook.scm | 193 +++++++++++++++++++++++++++++++ 11 files changed, 764 insertions(+), 761 deletions(-) create mode 100644 .guix-channel delete mode 100644 forge/build/git.scm delete mode 100644 forge/forge.scm delete mode 100644 forge/laminar.scm delete mode 100644 forge/utils.scm delete mode 100644 forge/webhook.scm create mode 100644 guix/forge/build/git.scm create mode 100644 guix/forge/forge.scm create mode 100644 guix/forge/laminar.scm create mode 100644 guix/forge/utils.scm create mode 100644 guix/forge/webhook.scm diff --git a/.guix-channel b/.guix-channel new file mode 100644 index 0000000..8cec433 --- /dev/null +++ b/.guix-channel @@ -0,0 +1,3 @@ +(channel + (version 0) + (directory "guix")) 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 -;;; -;;; 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 -;;; . - -(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 -;;; -;;; 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 -;;; . - -(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 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 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 - 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 - object---and returns a G-expression describing a -derivation to run. JOB is a 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 -;;; -;;; 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 -;;; . - -(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 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 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 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 -;;; -;;; 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 -;;; . - -(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 -;;; -;;; 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 -;;; . - -(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 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 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)))) 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 +;;; +;;; 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 +;;; . + +(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 +;;; +;;; 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 +;;; . + +(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 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 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 + 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 + object---and returns a G-expression describing a +derivation to run. JOB is a 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 +;;; +;;; 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 +;;; . + +(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 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 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 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 +;;; +;;; 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 +;;; . + +(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 +;;; +;;; 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 +;;; . + +(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 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 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)))) -- cgit v1.2.3