(use-modules (guix gexp)
(gnu)
(guix)
((guix build utils) #:prefix utils:)
((guix modules) #:prefix modules:)
((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
(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)
(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))
(set! chars (cons curr chars)))
(let* ((pattern (reverse! chars))
(pointer pattern)
(output '()))
(do ((curr (read-char port)
(when (not (null? pointer))
(read-char port))))
((null? pointer))
(set! output (cons curr output))
(set! pointer
(if (equal? (car pointer) curr)
(cdr pointer)
pattern)))
(list->string
(reverse!
(srfi-1:drop output
(length pattern)))))))
(read-hash-extend #\> heredoc-reader)
(define-macro (-> x . sexps)
(srfi-1:fold
(lambda (el acc)
(if (list? el)
(append (list (car el)
acc)
(cdr el))
(list el acc)))
x
sexps))
(define-macro (->> x . sexps)
(srfi-1:fold
(lambda (el acc)
(if (list? el)
(append el (list acc))
(list el acc)))
x
sexps))
(define (cmd . args)
(let* ((port (apply popen:open-pipe* OPEN_READ args))
(out (string-trim-right (rdelim:read-string port))))
(popen:close-pipe port)
out))
;; 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* ((out-list (-> (cmd "git" "notes" "list")
(string-fun:string-replace-substring "\n" " ")
(string-split #\space)))
(relevant-commits (->> (srfi-1:zip out-list (iota (length out-list)))
(filter (compose odd? srfi-1:second))
(map srfi-1:first))))
(map (lambda (commit)
(let ((data (-> (cmd "git" "notes" "--ref=refs/notes/ci-data" "show" commit)
(string-split #\space)))
(logs (cmd "git" "notes" "--ref=refs/notes/ci-logs" "show" commit)))
(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
(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 * * * *"
#$(program-file
"generate-ci-index-html.scm"
(with-imported-modules (modules:source-module-closure
'((guix build utils)))
#~(begin
(use-modules (guix build utils))
(display '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))))
(simple-service 'automatic-certbot-renewal
activation-service-type
(with-imported-modules '((gnu services herd))
#~(begin
(use-modules (gnu services herd))
(restart-service 'mcron))))
(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)))