blob: 670adbb375bf873893a8130d6044c3367cf9985a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2022, 2025 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 build linux-container)
#:use-module ((gnu packages admin) #:select (shadow))
#:use-module ((gnu packages guile) #:select (guile-json-4))
#:use-module ((gnu packages web) #:select (webhook))
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system accounts)
#:use-module (gnu system file-systems)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (guix least-authority)
#:use-module (forge socket)
#:export (webhook-service-type
webhook-configuration
webhook-configuration?
webhook-configuration-package
webhook-configuration-socket
webhook-configuration-log-directory
webhook-configuration-hooks
webhook-hook
webhook-hook?
webhook-hook-id
webhook-hook-run))
(define-record-type* <webhook-configuration>
webhook-configuration make-webhook-configuration
webhook-configuration?
(package webhook-configuration-package
(default webhook))
(socket webhook-configuration-socket
(default (forge-ip-socket
(ip "127.0.0.1")
(port 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-accounts
(list (user-account
(name "webhook")
(group "webhook")
(system? #t)
(comment "webhook user")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))
(user-group
(name "webhook")
(system? #t))))
(define (webhook-activation config)
(match-record config <webhook-configuration>
(log-directory)
#~(begin
;; Create log directory and set permissions.
(mkdir-p #$log-directory)
(let ((user (getpw "webhook")))
(for-each (lambda (file)
(chown file (passwd:uid user) (passwd:gid user)))
(find-files #$log-directory #:directories? #t))))))
(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 (string-append (webhook-hook-id hook)
"-webhook")
(webhook-hook-run hook)))))
(webhook-configuration-hooks config))))
<>)))))
(define (webhook-shepherd-service config)
(shepherd-service
(documentation "Run webhook.")
(provision '(webhook))
(requirement '(networking))
(start
(let ((hooks-json (computed-file "hooks.json" (hooks-json-gexp config))))
#~(make-forkexec-constructor
(list #$(least-authority-wrapper
(file-append (webhook-configuration-package config)
"/bin/webhook")
#:name "webhook"
#:mappings (list (file-system-mapping
(source hooks-json)
(target source))
(file-system-mapping
(source (webhook-configuration-log-directory config))
(target source)
(writable? #t)))
;; TODO: If socket is a Unix socket, run in a
;; network namespace. We can't do this yet due to
;; https://yhetil.org/guix/m1ilknoi5r.fsf@fastmail.net/
#:namespaces (delq 'net %namespaces))
"-hooks" #$hooks-json
"-ip" #$(forge-ip-socket-ip (webhook-configuration-socket config))
"-port" #$(number->string (forge-ip-socket-port (webhook-configuration-socket config)))
"-logfile" #$(string-append (webhook-configuration-log-directory config)
"/webhook.log"))
#:user "webhook"
#:group "webhook"
#: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 account-service-type
(const %webhook-accounts))
(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))))
|
