aboutsummaryrefslogtreecommitdiff
path: root/forge
diff options
context:
space:
mode:
authorArun Isaac2022-03-02 17:55:27 +0530
committerArun Isaac2022-03-02 21:04:17 +0530
commitcb7cecae3f6152052bdaf601eb1f6fcb2727b6b9 (patch)
treee369c485363fb08ed2b294e1602d4a209754d506 /forge
parent419d982bb29dd8a3904e6591796cc7ebc9190fd8 (diff)
downloadguix-forge-cb7cecae3f6152052bdaf601eb1f6fcb2727b6b9.tar.gz
guix-forge-cb7cecae3f6152052bdaf601eb1f6fcb2727b6b9.tar.lz
guix-forge-cb7cecae3f6152052bdaf601eb1f6fcb2727b6b9.zip
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.
Diffstat (limited to 'forge')
-rw-r--r--forge/build/git.scm76
-rw-r--r--forge/forge.scm287
-rw-r--r--forge/laminar.scm135
-rw-r--r--forge/utils.scm70
-rw-r--r--forge/webhook.scm193
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))))