diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-26 00:02:44 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-26 00:02:44 +0200 |
commit | 2508079864766afc3b6d3b670547b827c7a84ef7 (patch) | |
tree | f492a57db656d0678c9aa30dc13586b581e4a624 | |
parent | 654b70c84a608c43d07f089c17e71a7d9307a4c0 (diff) |
Update package
-rw-r--r-- | vkraus/packages/disfluid.scm | 2 | ||||
-rw-r--r-- | vkraus/services/disfluid.scm | 766 | ||||
-rw-r--r-- | vkraus/systems/test.scm | 141 |
3 files changed, 476 insertions, 433 deletions
diff --git a/vkraus/packages/disfluid.scm b/vkraus/packages/disfluid.scm index 0b1db2a..dd7667f 100644 --- a/vkraus/packages/disfluid.scm +++ b/vkraus/packages/disfluid.scm @@ -209,6 +209,6 @@ corresponding source, as an AGPL requirement."))) (define-public (make-website disfluid) (file-append (disfluid-htmlize disfluid) "/share/doc/disfluid/disfluid.html")) -(define-public disfluid (disfluid-release "0.5.3-45-g1224ff5" "2021-09-25T15:55:09+02:00" "1224ff517f28d00136a2261c4f214d767f047498" "1lbhd7kl2q6pfz19daacbyj64l9py1sy8yafb4pli3lclyjmrych")) +(define-public disfluid (disfluid-release "0.5.3-44-ga87caca" "2021-09-24T15:59:50+02:00" "a87cacab058ad6b92e2b5bb011ac776685aa1575" "1fyswnabpq6gj6s61fj3lxrxdnqashrpzsrfmksgq4hgafxjxscn")) (define-public disfluid-html (disfluid-htmlize disfluid)) (define-public disfluid:website (make-website disfluid)) diff --git a/vkraus/services/disfluid.scm b/vkraus/services/disfluid.scm index ecd0f33..21adca2 100644 --- a/vkraus/services/disfluid.scm +++ b/vkraus/services/disfluid.scm @@ -23,354 +23,387 @@ #:use-module (gnu packages admin) #:use-module (vkraus packages disfluid) #:use-module (guix gexp) - #:use-module (guix packages) #:use-module (guix modules) + #:use-module (guix records) #:use-module (ice-9 match) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (web uri) - #:use-module (oop goops) - #:declarative? #t - #:export - ( - <disfluid-configuration> - disfluid-package - extra-options - <disfluid-server-configuration> - complete-corresponding-source - port - <disfluid-issuer-configuration> - issuer - key-file - subject - encrypted-password-file - jwks-uri - authorization-endpoint-uri - token-endpoint-uri - <disfluid-reverse-proxy-configuration> - inbound-uri - outbound-uri - header - <disfluid-hello-configuration> - <disfluid-client-service-configuration> - client-id - redirect-uri - client-name - client-uri - <disfluid-full-server-configuration> - server-name - - kind - document - invocation - ->shepherd-service - ->log-rotation - - disfluid-service-type - disfluid-website - )) - -(define-class <disfluid-configuration> () - (disfluid-package - #:init-keyword #:disfluid-package - #:init-value disfluid - #:getter disfluid-package) + #:use-module (ice-9 optargs)) + +(define-record-type* <disfluid-issuer-configuration> + disfluid-issuer-configuration + make-disfluid-issuer-configuration + disfluid-issuer-configuration? + (disfluid disfluid-issuer-configuration-disfluid + (default disfluid)) + (complete-corresponding-source + disfluid-issuer-configuration-complete-corresponding-source) + (issuer disfluid-issuer-configuration-issuer) + (key-file disfluid-issuer-configuration-key-file) + (subject disfluid-issuer-configuration-subject) + (encrypted-password-file disfluid-issuer-configuration-encrypted-password-file) + (jwks-uri disfluid-issuer-configuration-jwks-uri) + (authorization-endpoint-uri + disfluid-issuer-configuration-authorization-endpoint-uri) + (token-endpoint-uri + disfluid-issuer-configuration-token-endpoint-uri) + (port disfluid-issuer-configuration-port (default 8088)) (extra-options - #:init-keyword #:extra-options - #:init-value '() - #:getter extra-options)) - -(define-class <disfluid-server-configuration> (<disfluid-configuration>) + disfluid-issuer-configuration-extra-options + (default '()))) + +(define-record-type* <disfluid-reverse-proxy-configuration> + disfluid-reverse-proxy-configuration + make-disfluid-reverse-proxy-configuration + disfluid-reverse-proxy-configuration? + (disfluid disfluid-reverse-proxy-configuration-disfluid + (default disfluid)) (complete-corresponding-source - #:init-keyword #:complete-corresponding-source - #:getter complete-corresponding-source) - (port - #:init-keyword #:port - #:getter port)) - -(define-class <disfluid-issuer-configuration> (<disfluid-server-configuration>) - (issuer #:init-keyword #:issuer #:getter issuer) - (key-file #:init-keyword #:key-file #:getter key-file) - (subject #:init-keyword #:subject #:getter subject) - (encrypted-password-file - #:init-keyword #:encrypted-password-file - #:accessor encrypted-password-file) - (jwks-uri #:init-keyword #:jwks-uri #:getter jwks-uri) + disfluid-reverse-proxy-configuration-complete-corresponding-source) + (port disfluid-reverse-proxy-port (default 8090)) + (inbound-uri disfluid-reverse-proxy-configuration-inbound-uri) + (outbound-uri disfluid-reverse-proxy-configuration-outbound-uri) + (header disfluid-reverse-proxy-configuration-header + (default "XXX-Agent")) + (extra-options + disfluid-reverse-proxy-extra-options + (default '()))) + +(define-record-type* <disfluid-hello-configuration> + disfluid-hello-configuration + make-disfluid-hello-configuration + disfluid-hello-configuration? + (disfluid disfluid-hello-configuration-disfluid + (default disfluid)) + (complete-corresponding-source + disfluid-hello-configuration-complete-corresponding-source) + (port disfluid-hello-configuration-port (default 8089)) + (extra-options + disfluid-hello-configuration-extra-options + (default '()))) + +(define-record-type* <disfluid-client-service-configuration> + disfluid-client-service-configuration + make-disfluid-client-service-configuration + disfluid-client-service-configuration? + (disfluid disfluid-client-service-configuration-disfluid + (default disfluid)) + (complete-corresponding-source + disfluid-client-service-configuration-complete-corresponding-source) + (client-id disfluid-client-service-configuration-client-id) + (redirect-uri disfluid-client-service-configuration-redirect-uri) + (client-name disfluid-client-service-configuration-client-name (default "Example Solid App")) + (client-uri disfluid-client-service-configuration-client-uri (default "https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client")) + (port disfluid-client-service-configuration-port (default 8088)) + (extra-options + disfluid-client-service-configuration-extra-options + (default '()))) + +(define-record-type* <disfluid-server-configuration> + disfluid-server-configuration + make-disfluid-server-configuration + disfluid-server-configuration? + (disfluid disfluid-server-configuration-disfluid + (default disfluid)) + (complete-corresponding-source + disfluid-server-configuration-complete-corresponding-source) + (server-name disfluid-server-configuration-server-name) + (key-file disfluid-server-configuration-key-file) + (subject disfluid-server-configuration-subject) + (encrypted-password-file disfluid-server-configuration-encrypted-password-file) + (jwks-uri disfluid-server-configuration-jwks-uri) (authorization-endpoint-uri - #:init-keyword #:authorization-endpoint-uri - #:getter authorization-endpoint-uri) + disfluid-server-configuration-authorization-endpoint-uri) (token-endpoint-uri - #:init-keyword #:token-endpoint-uri - #:getter token-endpoint-uri)) - -(define-class <disfluid-reverse-proxy-configuration> (<disfluid-server-configuration>) - (inbound-uri #:init-keyword #:inbound-uri #:getter inbound-uri) - (outbound-uri #:init-keyword #:outbound-uri #:getter outbound-uri) - (header #:init-keyword #:header #:getter header #:init-value "XXX-Agent")) - -(define-class <disfluid-hello-configuration> (<disfluid-server-configuration>)) - -(define-class <disfluid-client-service-configuration> (<disfluid-server-configuration>) - (client-id #:init-keyword #:client-id #:getter client-id) - (redirect-uri #:init-keyword #:redirect-uri #:getter redirect-uri) - (client-name - #:init-keyword #:client-name - #:getter client-name - #:init-value "Example Solid App") - (client-uri - #:init-keyword #:client-uri - #:getter client-uri - #:init-value (string->uri - "https://disfluid.planete-kraus.eu/Running-a-client.html#Running-a-client"))) - -(define-class <disfluid-full-server-configuration> (<disfluid-issuer-configuration>) - (server-name #:init-keyword #:server-name #:getter server-name)) - -(define-method (initialize (cfg <disfluid-configuration>) initargs) - (next-method) - (unless (package? (disfluid-package cfg)) - (scm-error 'wrong-type-arg "make <disfluid-configuration>" - "#:disfluid-package argument should be a package" - '() - (list (disfluid-package cfg)))) - (unless (list? (extra-options cfg)) - (scm-error 'wrong-type-arg "make <disfluid-configuration>" - "#:extra-options argument should be a list" - '() - (list (extra-options cfg))))) - -(define-method (initialize (cfg <disfluid-server-configuration>) initargs) - (next-method) - (let ((ccs (complete-corresponding-source cfg)) - (port (port cfg))) - (unless (or (string? ccs) (uri? ccs)) - (scm-error 'wrong-type-arg "make <disfluid-server-configuration>" - "#:complete-corresponding-source should be a string or an URI" - '() - (list ccs))) - (unless (and (integer? port) - (> port 0) - (< port 65536)) - (scm-error 'wrong-type-arg "make <disfluid-server-configuration>" - "#:port should be a port number" - '() - (list port))))) - -(define string->uri* - ;; Try to convert a string to an URI, but keep the old value if it - ;; fails - (match-lambda - ((or (? uri? uri) - (? string? (= string->uri (? uri? uri)))) - uri) - (non-uri non-uri))) - -(define (uri-slot! object slot-name) - (slot-set! object slot-name - (string->uri* (slot-ref object slot-name))) - (unless (uri? (slot-ref object slot-name)) - (scm-error 'wrong-type-arg "make" - (format #f "#:~a should be an URI" slot-name) - '() - (list (slot-ref object slot-name))))) - -(define (string/file-like-slot! object slot-name) - (let ((value (slot-ref object slot-name))) - (unless (or (string? value) (file-like? value)) - (scm-error 'wrong-type-arg "make" - (format #f "#:~a should be a file name or a file-like object" - slot-name) - '() - (list value))))) - -(define-method (initialize (cfg <disfluid-issuer-configuration>) initargs) - (next-method) - (uri-slot! cfg 'issuer) - (string/file-like-slot! cfg 'key-file) - (uri-slot! cfg 'subject) - (string/file-like-slot! cfg 'encrypted-password-file) - (uri-slot! cfg 'jwks-uri) - (uri-slot! cfg 'authorization-endpoint-uri) - (uri-slot! cfg 'token-endpoint-uri)) - -(define-method (initialize (cfg <disfluid-reverse-proxy-configuration>) initargs) - (next-method) - (uri-slot! cfg 'inbound-uri) - (uri-slot! cfg 'outbound-uri) - (when (symbol? (header cfg)) - (slot-set! cfg 'header (symbol->string (header cfg)))) - (unless (string? (header cfg)) - (scm-error 'wrong-type-arg "make" - "#:header should be a symbol or a string") - '() - (list (header cfg)))) - -(define-method (initialize (cfg <disfluid-client-service-configuration>) initargs) - (next-method) - (uri-slot! cfg 'client-id) - (uri-slot! cfg 'redirect-uri) - (unless (string? (client-name cfg)) - (scm-error 'wrong-type-arg "make" - "#:client-name should be a string") - '() - (list (client-name cfg))) - (uri-slot! cfg 'client-uri)) - -(define-method (initialize (cfg <disfluid-full-server-configuration>) initargs) - (let-keywords - initargs #t - ((server-name #f)) - (begin - (slot-set! cfg 'server-name server-name) - (uri-slot! cfg 'server-name) - (slot-set! cfg 'issuer server-name) - (uri-slot! cfg 'issuer))) - ;; #:issuer defaults to the server name - (next-method) - ;; server-name has been reset - (uri-slot! cfg 'server-name)) - -(define-method (kind (cfg <disfluid-issuer-configuration>)) - "issuer") - -(define-method (kind (cfg <disfluid-reverse-proxy-configuration>)) - "reverse-proxy") - -(define-method (kind (cfg <disfluid-hello-configuration>)) - "hello") - -(define-method (kind (cfg <disfluid-client-service-configuration>)) - "client-service") - -(define-method (kind (cfg <disfluid-full-server-configuration>)) - "server") - -(define-method (document (cfg <disfluid-issuer-configuration>) (id <string>)) - (format #f "Run a Solid identity provider for ~a (~a)" - (uri->string (issuer cfg)) id)) - -(define-method (document (cfg <disfluid-reverse-proxy-configuration>) (id <string>)) - (format #f "Run a Solid reverse proxy from ~a to ~a (~a)" - (uri->string (inbound-uri cfg)) (outbound-uri cfg) id)) - -(define-method (document (cfg <disfluid-hello-configuration>) (id <string>)) - (format #f "Run a demonstration Solid server on port ~a (~a)" - (port cfg) id)) - -(define-method (document (cfg <disfluid-client-service-configuration>) (id <string>)) - (format #f "Serve the public pages for ~a (~a)" - (uri->string (client-id cfg)) id)) - -(define-method (document (cfg <disfluid-full-server-configuration>) (id <string>)) - (format #f "Run the Solid server ~a (~a)" - (uri->string (server-name cfg)) id)) - -(define-method (invocation (cfg <disfluid-configuration>) (id <string>)) - ;; Return the program name, command and arguments - (values "/bin/disfluid" - #f - `("-l" ,(string-append (kind cfg) "-" id ".log") - "-e" ,(string-append (kind cfg) "-" id ".err") - ,@(extra-options cfg)))) - -(define-method (invocation (cfg <disfluid-server-configuration>) (id <string>)) - (receive (program-name command arguments) (next-method) - (values program-name - command - `("-S" ,(let ((ccs (complete-corresponding-source cfg))) - (if (uri? ccs) (uri->string ccs) ccs)) - "-p" ,(with-output-to-string - (lambda () (display (port cfg)))) - ,@arguments)))) - -(define-method (invocation (cfg <disfluid-issuer-configuration>) (id <string>)) - (receive (_program _command arguments) (next-method) - (values "/bin/disfluid" - "identity-provider" - `("-n" (uri->string (issuer cfg)) - "-k" (key-file cfg) - "-s" (uri->string (subject cfg)) - "-W" (encrypted-password-file cfg) - "-j" (uri->string (jwks-uri cfg)) - "-a" (uri->string (authorization-endpoint-uri cfg)) - "-t" (uri->string (token-endpoint-uri cfg)) - ,@arguments)))) - -(define-method (invocation (cfg <disfluid-reverse-proxy-configuration>) (id <string>)) - (receive (_program _command arguments) (next-method) - (values "/bin/disfluid" - "reverse-proxy" - `("-n" (uri->string (inbound-uri cfg)) - "-b" (uri->string (outbound-uri cfg)) - "-H" (header cfg) - ,@arguments)))) - -(define-method (invocation (cfg <disfluid-hello-configuration>) (id <string>)) - (receive (_program _command arguments) (next-method) - (values "/bin/disfluid-hello" - #f - arguments))) - -(define-method (invocation (cfg <disfluid-client-service-configuration>) (id <string>)) - (receive (_program _command arguments) (next-method) - (values "/bin/disfluid" - "client-service" - `("-c" (uri->string (client-id cfg)) - "-r" (uri->string (redirect-uri cfg)) - "-C" (client-name cfg) - "-u" (uri->string (client-uri cfg)) - ,@arguments)))) - -(define-method (invocation (cfg <disfluid-full-server-configuration>) (id <string>)) - (receive (_program _command arguments) (next-method) - (values "/bin/disfluid" - "server" - `("-n" (uri->string (server-name cfg)) - ,@arguments)))) - -(define (->shepherd-service cfg id) - (receive (program-name command arguments) (invocation cfg id) - (define all-arguments `(command ,@arguments)) - (shepherd-service - (provision (list (string->symbol (format #f "disfluid-~a" id)))) - (documentation (document cfg id)) - (requirement '(user-processes)) - (modules '((gnu build shepherd) - (gnu system file-systems))) - (start - (with-imported-modules - '((gnu build shepherd) - (gnu system file-systems)) - #~(begin - (let* ((user (getpwnam "disfluid")) - (prepare-directory - (lambda (dir) - (mkdir-p dir) - (chown dir (passwd:uid user) (passwd:gid user)) - (chmod dir #o700)))) - (prepare-directory "/var/log/disfluid") - (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) - (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) - (make-forkexec-constructor - (cons (string-append #$(disfluid-package cfg) #$program-name) - #$all-arguments) - #:user "disfluid" - #:group "disfluid" - #:directory "/var/log/disfluid" - #:environment-variables - '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) - #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) - (stop #~(make-kill-destructor))))) + disfluid-server-configuration-token-endpoint-uri) + (port disfluid-server-configuration-port (default 8088)) + (extra-options + disfluid-issuer-configuration-extra-options + (default '()))) + +(export <disfluid-issuer-configuration> + disfluid-issuer-configuration + make-disfluid-issuer-configuration + disfluid-issuer-configuration? + disfluid-issuer-configuration-disfluid + disfluid-issuer-configuration-complete-corresponding-source + disfluid-issuer-configuration-issuer + disfluid-issuer-configuration-key-file + disfluid-issuer-configuration-subject + disfluid-issuer-configuration-encrypted-password-file + disfluid-issuer-configuration-jwks-uri + disfluid-issuer-configuration-authorization-endpoint-uri + disfluid-issuer-configuration-token-endpoint-uri + disfluid-issuer-configuration-port + disfluid-issuer-configuration-extra-options + <disfluid-reverse-proxy-configuration> + disfluid-reverse-proxy-configuration + make-disfluid-reverse-proxy-configuration + disfluid-reverse-proxy-configuration? + disfluid-reverse-proxy-configuration-disfluid + disfluid-reverse-proxy-configuration-complete-corresponding-source + disfluid-reverse-proxy-configuration-port + disfluid-reverse-proxy-configuration-inbound-uri + disfluid-reverse-proxy-configuration-outbound-uri + disfluid-reverse-proxy-configuration-header + disfluid-reverse-proxy-configuration-extra-options + <disfluid-hello-configuration> + disfluid-hello-configuration + make-disfluid-hello-configuration + disfluid-hello-configuration? + disfluid-hello-configuration-disfluid + disfluid-hello-configuration-complete-corresponding-source + disfluid-hello-configuration-port + disfluid-hello-configuration-extra-options + <disfluid-client-service-configuration> + disfluid-client-service-configuration + make-disfluid-client-service-configuration + disfluid-client-service-configuration? + disfluid-client-service-configuration-disfluid + disfluid-client-service-configuration-complete-corresponding-source + disfluid-client-service-configuration-client-id + disfluid-client-service-configuration-redirect-uri + disfluid-client-service-configuration-client-name + disfluid-client-service-configuration-client-uri + disfluid-client-service-configuration-port + disfluid-client-service-configuration-extra-options + <disfluid-server-configuration> + disfluid-server-configuration + make-disfluid-server-configuration + disfluid-server-configuration? + disfluid-server-configuration-disfluid + disfluid-server-configuration-complete-corresponding-source + disfluid-server-configuration-server-name + disfluid-server-configuration-key-file + disfluid-server-configuration-subject + disfluid-server-configuration-encrypted-password-file + disfluid-server-configuration-jwks-uri + disfluid-server-configuration-authorization-endpoint-uri + disfluid-server-configuration-token-endpoint-uri + disfluid-server-configuration-port + disfluid-server-configuration-extra-options) (define configuration->shepherd-service (match-lambda - (((or (? symbol? (= symbol->string id)) - (? string? id)) . cfg) - (list (->shepherd-service cfg id))) + ((id . ($ <disfluid-issuer-configuration> + disfluid ccs issuer key-file subject encrypted-password-file jwks-uri + authorization-endpoint-uri token-endpoint-uri port extra-options)) + `(,(shepherd-service + (provision (list (string->symbol (format #f "disfluid-~a" id)))) + (documentation (format #f "Run a Solid identity provider (~a)" id)) + (requirement '(user-processes)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start + (with-imported-modules + (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + #~(begin + (let* ((user (getpwnam "disfluid")) + (prepare-directory + (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid user) (passwd:gid user)) + (chmod dir #o700)))) + (prepare-directory "/var/log/disfluid") + (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) + (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) + (make-forkexec-constructor + (list + (string-append #$disfluid "/bin/disfluid") + "identity-provider" + "-S" #$ccs + "-n" #$issuer + "-k" #$key-file + "-s" #$subject + "-W" #$encrypted-password-file + "-j" #$jwks-uri + "-a" #$authorization-endpoint-uri + "-t" #$token-endpoint-uri + "-p" (with-output-to-string (lambda () (display #$port))) + "-l" #$(format #f "issuer-~a.log" id) + "-e" #$(format #f "issuer-~a.err" id) + #$@extra-options) + #:user "disfluid" + #:group "disfluid" + #:directory "/var/log/disfluid" + #:environment-variables + '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) + #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) + (stop #~(make-kill-destructor))))) + ((id . ($ <disfluid-reverse-proxy-configuration> + disfluid ccs port inbound-uri outbound-uri header extra-options)) + `(,(shepherd-service + (provision (list (string->symbol (format #f "disfluid-~a" id)))) + (documentation (format #f "Run a Solid reverse proxy (~a)" id)) + (requirement '(user-processes)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start + (with-imported-modules + (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + #~(begin + (let* ((user (getpwnam "disfluid")) + (prepare-directory + (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid user) (passwd:gid user)) + (chmod dir #o700)))) + (prepare-directory "/var/log/disfluid") + (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) + (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) + (make-forkexec-constructor + (list + (string-append #$disfluid "/bin/disfluid") + "reverse-proxy" + "-S" #$ccs + "-p" (with-output-to-string (lambda () (display #$port))) + "-n" #$inbound-uri + "-b" #$outbound-uri + "-H" #$header + "-l" #$(format #f "reverse-proxy-~a.log" id) + "-e" #$(format #f "reverse-proxy-~a.err" id) + #$@extra-options) + #:user "disfluid" + #:group "disfluid" + #:directory "/var/log/disfluid" + #:environment-variables + '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) + #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) + (stop #~(make-kill-destructor))))) + ((id . ($ <disfluid-hello-configuration> + disfluid ccs port extra-options)) + `(,(shepherd-service + (provision (list (string->symbol (format #f "disfluid-~a" id)))) + (documentation (format #f "Run a demonstration Solid server (~a)" id)) + (requirement '(user-processes)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start + (with-imported-modules + (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + #~(begin + (let* ((user (getpwnam "disfluid")) + (prepare-directory + (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid user) (passwd:gid user)) + (chmod dir #o700)))) + (prepare-directory "/var/log/disfluid") + (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) + (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) + (make-forkexec-constructor + (list + (string-append #$disfluid "/bin/disfluid-hello") + "-S" #$ccs + "-p" (with-output-to-string (lambda () (display #$port))) + "-l" #$(format #f "hello-~a.log" id) + "-e" #$(format #f "hello-~a.err" id) + #$@extra-options) + #:user "disfluid" + #:group "disfluid" + #:directory "/var/log/disfluid" + #:environment-variables + '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) + #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) + (stop #~(make-kill-destructor))))) + ((id . ($ <disfluid-client-service-configuration> + disfluid ccs client-id redirect-uri client-name client-uri port + extra-options)) + `(,(shepherd-service + (provision (list (string->symbol (format #f "disfluid-~a" id)))) + (documentation (format #f "Serve the public page for an application (~a)" id)) + (requirement '(user-processes)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start + (with-imported-modules + (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + #~(begin + (let* ((user (getpwnam "disfluid")) + (prepare-directory + (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid user) (passwd:gid user)) + (chmod dir #o700)))) + (prepare-directory "/var/log/disfluid") + (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) + (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) + (make-forkexec-constructor + (list + (string-append #$disfluid "/bin/disfluid") + "client-service" + "-S" #$ccs + "-c" #$client-id + "-r" #$redirect-uri + "-C" #$client-name + "-u" #$client-uri + "-p" (with-output-to-string (lambda () (display #$port))) + "-l" #$(format #f "client-service-~a.log" id) + "-e" #$(format #f "client-service-~a.err" id) + #$@extra-options) + #:user "disfluid" + #:group "disfluid" + #:directory "/var/log/disfluid" + #:environment-variables + '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) + #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) + (stop #~(make-kill-destructor))))) + ((id . ($ <disfluid-server-configuration> + disfluid ccs server-name key-file subject encrypted-password-file jwks-uri + authorization-endpoint-uri token-endpoint-uri port + extra-options)) + `(,(shepherd-service + (provision (list (string->symbol (format #f "disfluid-~a" id)))) + (documentation (format #f "Run a full server (~a)" id)) + (requirement '(user-processes)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start + (with-imported-modules + (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + #~(begin + (let* ((user (getpwnam "disfluid")) + (prepare-directory + (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid user) (passwd:gid user)) + (chmod dir #o700)))) + (prepare-directory "/var/log/disfluid") + (prepare-directory #$(format #f "/var/lib/disfluid/~a" id)) + (prepare-directory #$(format #f "/var/cache/disfluid/~a" id))) + (make-forkexec-constructor + (list + (string-append #$disfluid "/bin/disfluid") + "server" + "-S" #$ccs + "-n" #$server-name + "-k" #$key-file + "-s" #$subject + "-W" #$encrypted-password-file + "-j" #$jwks-uri + "-a" #$authorization-endpoint-uri + "-t" #$token-endpoint-uri + "-p" (with-output-to-string (lambda () (display #$port))) + "-l" #$(format #f "server-~a.log" id) + "-e" #$(format #f "server-~a.err" id) + #$@extra-options) + #:user "disfluid" + #:group "disfluid" + #:directory "/var/log/disfluid" + #:environment-variables + '(#$(format #f "XDG_DATA_HOME=/var/lib/disfluid/~a" id) + #$(format #f "XDG_CACHE_HOME=/var/cache/disfluid/~a" id)))))) + (stop #~(make-kill-destructor))))) ((items ...) - (apply append (map configuration->shepherd-service items))) - (only-one-cfg - (configuration->shepherd-service `(default . ,only-one-cfg))))) + (apply append (map configuration->shepherd-service items))))) (define %disfluid-accounts (list (user-group (name "disfluid") @@ -383,25 +416,50 @@ (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) -(define-method (->log-rotation (cfg <disfluid-server-configuration>) - (id <string>)) - (log-rotation - (frequency 'daily) - (files - (map (lambda (ext) - (format #f "/var/log/disfluid/~a-~a.~a" (kind cfg) id ext)) - '("log err"))) - (options '("sharedscripts" "storedir /var/log/disfluid")))) - (define configuration->log-rotation (match-lambda - (((or (? symbol? (= symbol->string id)) - (? string? id)) . cfg) - (list (->log-rotation cfg id))) + ((id . ($ <disfluid-issuer-configuration>)) + `(,(log-rotation + (frequency 'daily) + (files + (map (lambda (ext) + (format #f "/var/log/disfluid/issuer-~a.~a" id ext)) + '("log err"))) + (options '("sharedscripts" "storedir /var/log/disfluid"))))) + ((id . ($ <disfluid-reverse-proxy-configuration>)) + `(,(log-rotation + (frequency 'daily) + (files + (map (lambda (ext) + (format #f "/var/log/disfluid/reverse-proxy-~a.~a" id ext)) + '("log err"))) + (options '("sharedscripts" "storedir /var/log/disfluid"))))) + ((id . ($ <disfluid-hello-configuration>)) + `(,(log-rotation + (frequency 'daily) + (files + (map (lambda (ext) + (format #f "/var/log/disfluid/hello-~a.~a" id ext)) + '("log err"))) + (options '("sharedscripts" "storedir /var/log/disfluid"))))) + ((id . ($ <disfluid-client-service-configuration>)) + `(,(log-rotation + (frequency 'daily) + (files + (map (lambda (ext) + (format #f "/var/log/disfluid/client-service-~a.~a" id ext)) + '("log err"))) + (options '("sharedscripts" "storedir /var/log/disfluid"))))) + ((id . ($ <disfluid-server-configuration>)) + `(,(log-rotation + (frequency 'daily) + (files + (map (lambda (ext) + (format #f "/var/log/disfluid/server-~a.~a" id ext)) + '("log err"))) + (options '("sharedscripts" "storedir /var/log/disfluid"))))) ((items ...) - (apply append (map configuration->log-rotation items))) - (only-one-cfg - (configuration->log-rotation `(default . ,only-one-cfg))))) + (apply append (map configuration->log-rotation items))))) (define-public disfluid-service-type (service-type diff --git a/vkraus/systems/test.scm b/vkraus/systems/test.scm index c742db9..1bfc2b8 100644 --- a/vkraus/systems/test.scm +++ b/vkraus/systems/test.scm @@ -19,85 +19,70 @@ #:use-module (guix gexp) #:use-module (gnu packages certs) #:use-module (vkraus packages disfluid) - #:use-module (vkraus services disfluid) - #:use-module (ice-9 match) - #:use-module (ice-9 optargs) - #:use-module (oop goops)) - -(define-class <test-server-configuration> (<disfluid-full-server-configuration>) - (user #:init-keyword #:user #:getter user)) - -(define-method (initialize (cfg <test-server-configuration>) initargs) - (let-keywords - initargs #t - ((port #f)) - (let replace-#:user ((args initargs) - (replaced '()) - (replaced? #f)) - (match args - (() - (if replaced? - ;; last explicit call to initialize - (initialize cfg (reverse replaced)) - ;; #:user not found - (next-method))) - ((#:user username args ...) - (let ((added-args - `(#:complete-corresponding-source "https://disfluid.planete-kraus.eu/complete-corresponding-source.tar.gz" - #:server-name ,(format #f "http://localhost:~a" port) - #:subject ,(format #f "http://localhost:~a/~a#me" port username) - #:encrypted-password-file - ,(computed-file (format #f "~a-password" username) - #~(let ((salt "$6$not.secured.salt.") - (password username)) - (call-with-output-file #$output - (lambda (port) - (format port "~a\n" - (crypt password salt)))))) - #:key-file ,(format #f "/var/lib/disfluid/~a/key.jwk" username) - #:jwks-uri ,(format #f "http://localhost:~a/keys" port) - #:authorization-endpoint-uri - ,(format #f "http://localhost:~a/authorize" port) - #:token-endpoint-uri - ,(format #f "http://localhost:~a/token" port)))) - (replace-#:user args (append (reverse added-args) replaced) #t))) - (((? keyword? key) value args ...) - (replace-#:user args `(,value ,key ,@replaced) replaced?)))))) + #:use-module (vkraus services disfluid)) (operating-system - (host-name "disfluid-test-system") - (hosts-file - (plain-file "hosts" - "127.0.0.1 localhost + (host-name "disfluid-test-system") + (hosts-file + (plain-file "hosts" + "127.0.0.1 localhost ::1 localhost ")) - (users %base-user-accounts) - (packages - `(,disfluid - ,nss-certs - ,@%base-packages)) - (services - (append - (list - (service disfluid-service-type - `(("alice" - . ,(make <test-server-configuration> - #:user "alice" - #:port 8081)) - ("bob" - . ,(make <test-server-configuration> - #:user "bob" - #:port 8082))))) - %base-services)) - (timezone "Europe/Paris") - (bootloader - (bootloader-configuration - (bootloader grub-efi-bootloader) - (target "/boot/efi"))) - (mapped-devices '()) - (file-systems - `(,(file-system - (mount-point "/") - (device "/dev/sda") - (type "ext4")) - ,@%base-file-systems))) + (users %base-user-accounts) + (packages + `(,disfluid + ,nss-certs + ,@%base-packages)) + (services + (append + (list + (service disfluid-service-type + `(("alice" + . ,(disfluid-server-configuration + (complete-corresponding-source "https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz") + (server-name "http://localhost:8081") + (subject "http://localhost:8081/alice#me") + (encrypted-password-file + (computed-file "alice-password" + #~(let ((salt "$6$.salt.for.Alice.") + (password "alice")) + (call-with-output-file #$output + (lambda (port) + (format port "~a\n" + (crypt password salt))))))) + (key-file "/var/lib/disfluid/alice/key.jwk") + (jwks-uri "http://localhost:8081/keys") + (authorization-endpoint-uri "http://localhost:8081/authorize") + (token-endpoint-uri "http://localhost:8081/token") + (port 8081))) + ("bob" + . ,(disfluid-server-configuration + (complete-corresponding-source "https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz") + (server-name "http://localhost:8082") + (subject "http://localhost:8082/bob#me") + (encrypted-password-file + (computed-file "bob-password" + #~(let ((salt "$6$And.salt.for.Bob") + (password "bob")) + (call-with-output-file #$output + (lambda (port) + (format port "~a\n" + (crypt password salt))))))) + (key-file "/var/lib/disfluid/bob/key.jwk") + (jwks-uri "http://localhost:8082/keys") + (authorization-endpoint-uri "http://localhost:8082/authorize") + (token-endpoint-uri "http://localhost:8082/token") + (port 8082)))))) + %base-services)) + (timezone "Europe/Paris") + (bootloader + (bootloader-configuration + (bootloader grub-efi-bootloader) + (target "/boot/efi"))) + (mapped-devices '()) + (file-systems + `(,(file-system + (mount-point "/") + (device "/dev/sda") + (type "ext4")) + ,@%base-file-systems))) |