diff options
Diffstat (limited to 'sync')
| -rw-r--r-- | sync/vps.scm | 286 |
1 files changed, 260 insertions, 26 deletions
diff --git a/sync/vps.scm b/sync/vps.scm index 51fd91a..16be8cf 100644 --- a/sync/vps.scm +++ b/sync/vps.scm @@ -1,17 +1,245 @@ -(use-modules (gnu) - (ice-9 textual-ports) - (guix gexp)) -(use-package-modules ssh - backup - version-control) -(use-service-modules networking - ssh - mcron - admin - mail - web - certbot - cgit) +(use-modules ((gnu) #:prefix gnu:) + ((guix) #:prefix guix:) + ((guix build utils) #:prefix utils:) + ((guix gexp) #:prefix gexp:) + ((srfi srfi-1) #:prefix srfi-1:) + ((ice-9 textual-ports) #:prefix textual-ports:) + ((ice-9 ftw) #:prefix ftw:) + ((ice-9 popen) #:prefix popen:) + ((ice-9 rdelim) #:prefix rdelim:) + ((ice-9 string-fun) #:prefix string-fun:)) + +(gnu:use-package-modules ssh + backup + version-control) +(gnu:use-service-modules networking + ssh + mcron + admin + mail + web + certbot + cgit) + + + +;; missing from the stdlib + +(define* (partial f #:rest args1) + (lambda* (#:rest args2) + (apply f (append args1 args2)))) + +(define (every-pred-fn ps x) + (if (null? ps) + #t + (and ((car ps) x) + (every-pred-fn (cdr ps) x)))) + +(define (every-pred . ps) + (partial every-pred-fn ps)) + +(define (complement f) + (lambda* (#:rest args) + (not (apply f args)))) + + + +;; custom extensions + +;; FIXME: with-open-pipe + +(define (slurp f) + (string-trim-both + (call-with-input-file f textual-ports:get-string-all))) + +(define (ignored? path) + (or (equal? "." path) + (equal? ".." path))) + +(define (dotfile? path) + (equal? #\. (string-ref path 0))) + +(define (list-directory path) + (ftw:scandir path + (every-pred (complement ignored?) + (complement dotfile?)))) + +(define (hash-double-quote-reader _char port) + "Taken almost verbatim from let-over-lambda." + (let ((chars '())) + (do ((prev (read-char port) curr) + (curr (read-char port) (read-char port))) + ((and (equal? #\" prev) + (equal? #\# curr))) + (set! chars (cons prev chars))) + (list->string (reverse! chars)))) + +(read-hash-extend #\" hash-double-quote-reader) + +;; (defun |#"-reader| (stream sub-char numarg) +;; (declare (ignore sub-char numarg)) +;; (let (chars) +;; (do ((prev (read-char stream) curr) +;; (curr (read-char stream) (read-char stream))) +;; ((and (char= prev #\") (char= curr #\#))) +;; (push prev chars)) +;; (coerce (nreverse chars) 'string))) + +;; (set-dispatch-macro-character +;; #\# #\" #'|#"-reader|) + + +;; (define (heredoc-reader _char port) +;; "Taken almost verbatim from let-over-lambda." +;; (let ((chars '())) +;; (do ((curr (read-char port) +;; (read-char port))) +;; ((equal? #\newline curr)) +;; (push! curr chars)) +;; (let* ((pattern (reverse! chars)) +;; (pointer pattern) +;; (output '())) +;; (do ((curr (read-char port) +;; (read-char port))) +;; ((null? pointer)) +;; (push! curr output) +;; (set! pointer +;; (if (equal? (car pointer) curr) +;; (cdr pointer) +;; pattern)) +;; ;; (if (null? pointer) +;; ;; (return)) +;; ) +;; (list->string (reverse! output))))) + +;; (read-hash-extend #\> heredoc-reader) + +;; (defun |#>-reader| (stream sub-char numarg) +;; (declare (ignore sub-char numarg)) +;; (let (chars) +;; (do ((curr (read-char stream) +;; (read-char stream))) +;; ((char= #\newline curr)) +;; (push curr chars)) +;; (let* ((pattern (nreverse chars)) +;; (pointer pattern) +;; (output)) +;; (do ((curr (read-char stream) +;; (read-char stream))) +;; ((null pointer)) +;; (push curr output) +;; (setf pointer +;; (if (char= (car pointer) curr) +;; (cdr pointer) +;; pattern)) +;; (if (null pointer) +;; (return))) +;; (coerce +;; (nreverse +;; (nthcdr (length pattern) output)) +;; 'string)))) + + + +;; CI HTML generation + +(define ci-html-beginning + #"<!DOCTYPE html> +<html lang="en"> + <head> + <meta charset="UTF-8" /> + <meta name="viewport" content="width=device-width, initial-scale=1" /> + + <style> + pre { + display: inline; + } + </style> + </head> + <body> + <h1> + Build logs + </h1>"#) + +(define ci-html-ending + "</body> +</html>") + +(define git-data-path "/srv/git") +(define ci-data-path "/srv/ci") + +(define (ci-data-in-repo-notes path) + (utils:with-directory-excursion path + (let* ((port (popen:open-pipe* OPEN_READ "git" "notes" "list")) + (out (rdelim:read-string port)) + (out-list (string-split (string-fun:string-replace-substring (string-trim-right out) + "\n" + " ") + #\space)) + (relevant-commits (map srfi-1:first + (filter (compose odd? srfi-1:second) + (srfi-1:zip out-list + (iota (length out-list))))))) + (popen:close-pipe port) + (map (lambda (commit) + (let* ((data-port (popen:open-pipe* OPEN_READ "git" "notes" "--ref=refs/notes/ci-data" "show" commit)) + (logs-port (popen:open-pipe* OPEN_READ "git" "notes" "--ref=refs/notes/ci-logs" "show" commit)) + (data (string-split (string-trim-right (rdelim:read-string data-port)) + #\space)) + (logs (string-trim-right (rdelim:read-string logs-port)))) + (popen:close-pipe data-port) + (popen:close-pipe logs-port) + (list (cons #:status (srfi-1:first data)) + (cons #:filename (srfi-1:second data)) + (cons #:logs logs)))) + relevant-commits)))) + +(define (generate-html-for-project name) + (string-append + "<h2 id=\"" name "\"> + <a href=\"#" name "\"> + " name " + </a> + </h2> + <ul>" + (apply + string-append + (map (lambda (data) + (let ((status (if (equal? "0" (assoc-ref data #:status)) "✅" "❌")) + (file (string-append name "/" (assoc-ref data #:filename)))) + (string-append + "<li> + <a href=\"" file "\"> + " status " + <pre>" file "</pre> + </a> + </li>"))) + (ci-data-in-repo-notes (string-append git-data-path "/" name)))) + "</ul>")) + +(define (generate-ci-index-html) + (call-with-output-file (string-append ci-data-path "/index.html") + (partial display + (string-append ci-html-beginning + (apply string-append + (map generate-html-for-project + (list-directory git-data-path))) + ci-html-ending)))) + +(define (restore-logfiles) + (for-each (lambda (name) + (map (lambda (data) + (let* ((directory (string-append ci-data-path "/" name)) + (filename (string-append directory "/" (assoc-ref data #:filename)))) + (utils:mkdir-p directory) + (call-with-output-file filename + (partial display (assoc-ref data #:logs))))) + (ci-data-in-repo-notes (string-append git-data-path "/" name)))) + (list-directory git-data-path))) + + + +;; OS configuration (define ssh-public-key "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDF+uy407LKZAFnfFkJPRiOBzwV98qIEcKhITnLYhqfITfrJvcFVOY0/YDCrs6WHXyLdM29AoywVWsQ1qXiB7xQCwknPV8YZoCnJQcn0gvH8jbCk+C8Po0Rx846wbhL49qYolnmlhe+Uoy30j7XIJSDtPVO9d/hZqt2GPwGVJ98HLyY2ak+j4i1YkHr+mPFgnCaqCAzA374d1Bop18+YENYtMMU0k8hCsomwZny/7qNo4V8mjLxQAS8FvTuljxlthEpOM4Jsjl07yDLgE69kLvU7mmFi8EeC26e50N18Ouse82dZigtVhAMeLBhbJnQbDff4WfUBzSjpKjZPGcxoRaej3qSRbIkcMMqCOSlww6GcjRi+COvlpA4c1i4hKI15wHceoiKghDLA6jbaHfOqEMldflYl5gCVUIYzJ5XehZppH6L7PzO+L4suNs+aFjWPDZ0jqEtcyTmgTMea40p7wwz086ExnBDorbG79oDiJrWc+swJjXuVakS+fQjb3mPsCC/FgUhsxEtqiVfvLo2mphp47pOYvs64aUp3RV9muqQNuS4tEuP9V1urGTLtgPL26LEjF0oLu1ag0H+VZY5O/T9KRYvWre8IWbj/KkZYo1tJaGJyEVr0plmyzLBEy8b3Hu/6Wtq7yB0Eii60fxqFWC24nEkvs1V0cxDa+o6I2iA9w== eu@euandre.org") @@ -19,10 +247,6 @@ (define user "andreh") -(define (slurp f) - (string-trim-both - (call-with-input-file f get-string-all))) - (define sudoers "\ root ALL=(ALL) ALL %wheel ALL=NOPASSWD: ALL\n") @@ -51,7 +275,8 @@ root ALL=(ALL) ALL (string-append letsencrypt-prefix domain "/privkey.pem")) (define opensmtpd-config - (mixed-text-file "euandreh-smtpd.conf" " + ;; FIXME + (gexp:plain-file "euandreh-smtpd.conf" (string-append " listen on eth0 # File comes from mail-aliases-service-type table aliases file:/etc/aliases @@ -60,7 +285,7 @@ accept for local alias <aliases> deliver to maildir accept for any relay pki " mail-domain " cert \"" (tls-pub-for mail-domain) "\" -pki " mail-domain " key \"" (tls-priv-for mail-domain) "\"")) +pki " mail-domain " key \"" (tls-priv-for mail-domain) "\""))) (define tls-prefixes (list "www" @@ -76,6 +301,14 @@ pki " mail-domain " key \"" (tls-priv-for mail-domain) "\"")) (string-append prefix "." tld)) tls-prefixes))) +(define generate-ci-index-html-job + #~(job "*/5 * * * *" + generate-ci-index-html)) + +(define restore-logfiles-job + #~(job "1 * * * *" + restore-logfiles)) + (operating-system (locale "fr_FR.UTF-8") (timezone "America/Sao_Paulo") @@ -104,7 +337,8 @@ pki " mail-domain " key \"" (tls-priv-for mail-domain) "\"")) `((,user ,(plain-file "id_rsa.pub" ssh-public-key)))))) (service mcron-service-type (mcron-configuration - (jobs (list)))) + (jobs (list generate-ci-index-html-job + restore-logfiles-job)))) (service unattended-upgrade-service-type) (service dhcp-client-service-type) (service opensmtpd-service-type @@ -157,16 +391,16 @@ pki " mail-domain " key \"" (tls-priv-for mail-domain) "\"")) (max-stats "year") (nocache? #t) (readme "README.md") - ;() + ;() ;; (repositories ;; (list ;; (repository-cgit-configuration ;; )) ;; ) - ;; (map (lambda (f) - ;; (repository-cgit-configuration (readme f))) - ;; '("README.md" "README" "README.rst" "README.org")) - )) + ;; (map (lambda (f) + ;; (repository-cgit-configuration (readme f))) + ;; '("README.md" "README" "README.rst" "README.org")) + )) (simple-service 'init-srv-directories activation-service-type #~(begin |