aboutsummaryrefslogtreecommitdiff
path: root/vps/machines.scm
diff options
context:
space:
mode:
Diffstat (limited to 'vps/machines.scm')
-rw-r--r--vps/machines.scm376
1 files changed, 376 insertions, 0 deletions
diff --git a/vps/machines.scm b/vps/machines.scm
new file mode 100644
index 0000000..fe7143f
--- /dev/null
+++ b/vps/machines.scm
@@ -0,0 +1,376 @@
+(use-modules (guix gexp)
+ (gnu)
+ (guix)
+ ((guix build utils) #:prefix utils:)
+ ((guix modules) #:prefix modules:)
+ ((srfi srfi-1) #:prefix srfi-1:)
+ (srfi srfi-26) ; cut utility
+ ((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 functions from 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 (read-delimited-list char port)
+ (let ((sexp-string (string-append
+ "("
+ (rdelim:read-delimited (string char) port)
+ ")")))
+ (call-with-input-string sexp-string read)))
+
+(define (lambda-shorthand-reader _char port)
+ `(lambda (%)
+ ,(read-delimited-list #\] port)))
+
+(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))
+
+(read-hash-extend #\[ lambda-shorthand-reader)
+
+(define (tick-cmd-reader _char port)
+ (cons 'cmd
+ (map (lambda (s)
+ (if (equal? #\$ (string-ref s 0))
+ (string->symbol (substring s 1))
+ s))
+ (string-split (rdelim:read-delimited "´" port)
+ #\space))))
+
+(read-hash-extend #\´ tick-cmd-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))
+
+
+;; DNS constants
+
+(define user "andreh")
+
+(define tld (slurp "shared/tld.txt"))
+(define host-name (slurp "shared/hostname.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))
+
+
+;; OS configuration
+
+(define sudoers "\
+root ALL=(ALL) ALL
+%wheel ALL=NOPASSWD: ALL\n")
+
+(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 <aliases> deliver to maildir
+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) "\"")))
+
+(define tls-prefixes
+ (list mail-domain-prefix
+ git-domain-prefix
+ "chat"))
+
+(define static-projects
+ '("guile-pds" "boneco"))
+
+(define tls-domains
+ (cons tld
+ (append
+ (map #[string-append % "." tld]
+ tls-prefixes)
+ (map (cut string-append <> "." tld) static-projects))))
+
+(define (static-nginx-config domains root)
+ (nginx-server-configuration
+ (server-name domains)
+ (listen '("443 ssl"))
+ (ssl-certificate (tls-pub-for tld))
+ (ssl-certificate-key (tls-priv-for tld))
+ (root root)))
+
+(define static-projects-nginx-config
+ (map #[static-nginx-config (list (string-append % "." tld))
+ (string-append "/srv/http/" %)]
+ static-projects))
+
+(define cgit-with-custom-about-formatting
+ (package
+ (inherit cgit)
+ (arguments
+ (substitute-keyword-arguments (package-arguments cgit)
+ ((#:phases phases)
+ `(modify-phases ,phases
+ (add-after unpack 'patch-about-formatting
+ (lambda _
+ (substitute* "lib/cgit/filters/about-formatting.sh"
+ (("txt2html") "md2html"))))))))))
+
+(define my-system
+ (operating-system
+ (timezone "America/Sao_Paulo")
+ (host-name host-name)
+ (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)
+ ;; required for guix pull
+ '(nss-certs))
+ %base-packages))
+ (services
+ (append
+ (list (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (password-authentication? #false)
+ (authorized-keys
+ `((,user ,(local-file "id_rsa.pub"))))))
+ (simple-service 'automatic-services-restart
+ activation-service-type
+ (with-imported-modules '((gnu services herd))
+ #~(begin
+ (use-modules (gnu services herd))
+ (restart-service 'mcron)
+ (restart-service 'nginx))))
+ (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
+ (append (list)
+ static-projects-nginx-config))))
+ (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
+ (package cgit-with-custom-about-formatting)
+ (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"))
+ (favicon (file-append cgit "/share/cgit/favicon.ico"))
+ (enable-commit-graph? #t)
+ (enable-follow-links? #t)
+ (enable-index-owner? #f)
+ (enable-log-filecount? #t)
+ (enable-log-linecount? #t)
+ (enable-subject-links? #t)
+ (enable-html-serving? #t)
+ (enable-git-config? #t)
+ (max-repodesc-length 120)
+ (max-stats "year")
+ (nocache? #t)
+ (include
+ (plain-file "euandreh-cgitrc"
+ (string-join (map (partial string-append "readme=:README")
+ '("" ".txt" ".md" ".rst"))
+ "\n")))
+ #;
+ (nginx-server-configuration-list
+ (list
+ (nginx-server-configuration
+ (server-name (list git-domain)))))))
+ #;
+ (simple-service 'init-srv-directories
+ activation-service-type
+ #~(for-each (lambda (p)
+ (mkdir-p p)
+ (chmod p #o755))
+ '("/srv/http"
+ "/srv/git"))))
+ (modify-services
+ %base-services
+ (guix-service-type
+ config => (guix-configuration
+ (inherit config)
+ (authorized-keys
+ (append
+ (list (local-file "/etc/guix/signing-key.pub"))
+ %default-authorized-guix-keys)))))))
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vda")
+ (terminal-outputs '(console))))
+ (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))))
+
+(define my-machine
+ (machine
+ (operating-system my-system)
+ (environment managed-host-environment-type)
+ (configuration (machine-ssh-configuration
+ (host-name tld)
+ (system "x86_64-linux")
+ (user user)
+ (host-key "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOwnnw/u8ub+kcQhnVSyNWarYGH8aesUwIy4SIprufKf")))))
+
+(list my-machine)
generated by cgit v1.2.3 (git 2.49.0) at 2025-07-22 18:07:22 +0000