(use-modules (guix gexp)
(gnu)
(guix)
((guix build utils) #:prefix utils:)
((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:))
(use-package-modules ssh
backup
version-control)
(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
#"
Build logs
"#)
(define ci-html-ending
"
")
(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
"
"
(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
"-
" status "
" file "
")))
(ci-data-in-repo-notes (string-append git-data-path "/" name))))
"
"))
(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")
(define user
"andreh")
(define sudoers "\
root ALL=(ALL) ALL
%wheel ALL=NOPASSWD: ALL\n")
(define tld
(slurp "tld.txt"))
(define mail-domain-prefix "mail")
(define mail-domain
(string-append mail-domain-prefix "." tld))
(define git-domain-prefix "git")
(define git-domain
(string-append git-domain-prefix "." tld))
(define certbot-alias
"certbot")
(define letsencrypt-prefix
"/etc/letsencrypt/live/")
(define (tls-pub-for domain)
(string-append letsencrypt-prefix domain "/fullchain.pem"))
(define (tls-priv-for domain)
(string-append letsencrypt-prefix domain "/privkey.pem"))
(define opensmtpd-config
;; FIXME
(plain-file "euandreh-smtpd.conf" (string-append "
listen on eth0
# File comes from mail-aliases-service-type
table aliases file:/etc/aliases
accept from any domain " mail-domain " alias deliver to maildir
accept for local alias 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) "\"")))
(define tls-prefixes
(list "www"
mail-domain-prefix
"ci"
git-domain-prefix
"chat"
"meet"))
(define tls-domains
(cons tld
(map (lambda (prefix)
(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")
(keyboard-layout (keyboard-layout "us"))
(host-name "guix-pet-server")
(users (cons* (user-account
(name user)
(group "users")
(home-directory (string-append "/home/" user))
(supplementary-groups '("wheel")))
%base-user-accounts))
(sudoers-file (plain-file "sudoers" sudoers))
(packages
(append (map (compose list specification->package+output symbol->string)
'(git
nss-certs
rsync))
%base-packages))
(services
(append
(list (service openssh-service-type
(openssh-configuration
(openssh openssh-sans-x)
(password-authentication? #false)
(authorized-keys
`((,user ,(plain-file "id_rsa.pub" ssh-public-key))))))
(service mcron-service-type
(mcron-configuration
(jobs (list generate-ci-index-html-job
restore-logfiles-job))))
(service unattended-upgrade-service-type)
(service dhcp-client-service-type)
(service opensmtpd-service-type
(opensmtpd-configuration
(config-file opensmtpd-config)))
(service mail-aliases-service-type
`(("postmaster" "root")
("webmaster" "root")
("abuse" "root")
(,certbot-alias "root")))
;; (service nginx-service-type
;; (nginx-configuration
;; (server-blocks
;; (list
;; (nginx-server-configuration
;; (server-name (list tld))
;; (ssl-certificate (tls-pub-for tld))
;; (ssl-certificate-key (tls-priv-for tld)))))))
;; (service certbot-service-type
;; (certbot-configuration
;; (email (string-append certbot-alias "@" tld))
;; (certificates
;; (list
;; (certificate-configuration
;; (domains tls-domains))))))
(simple-service 'automatic-certbot-renewal
activation-service-type
(with-imported-modules '((gnu services herd))
#~(begin
(use-modules (gnu services herd))
;; (execl "/var/lib/certbot/renew-certificates")
(restart-service 'nginx))))
(service cgit-service-type
(cgit-configuration
(remove-suffix? #t)
(root-title "EuAndreh's repositories")
(root-desc "Patches welcome!")
(snapshots '("tar.gz" "zip"))
(clone-prefix (list (string-append "https://" git-domain)))
(source-filter (file-append cgit "/lib/cgit/filters/syntax-highlighting.py"))
(about-filter (file-append cgit "/lib/cgit/filters/about-formatting.sh"))
;; about-filter
;;(clone-url "dunno")
(enable-commit-graph? #t)
(enable-follow-links? #t)
(enable-index-links? #t)
(enable-log-filecount? #t)
(enable-log-linecount? #t)
(max-repodesc-length 120)
(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"))
))
(simple-service 'init-srv-directories
activation-service-type
#~(begin
(for-each (lambda (p)
(mkdir-p p)
(chmod p #o777))
'("/srv/http"
"/srv/git"
"/srv/ci")))))
%base-services))
(bootloader
(bootloader-configuration
(bootloader grub-bootloader)
(target "/dev/vda")
(keyboard-layout keyboard-layout)))
(swap-devices
(list (uuid "79a91c82-f3e1-4ed7-8c4e-23569f1ae0ca")))
(file-systems
(cons* (file-system
(mount-point "/")
(device
(uuid "fddb6a4c-8b8c-4f57-b274-5d6d33200f28"
'ext4))
(type "ext4"))
%base-file-systems)))