Move sync/* to .

1 files changed, 472 insertions, 0 deletions

diff --git a/vps.scm b/vps.scm
new file mode 100644
index 0000000..259ec80
--- /dev/null
+++ b/vps.scm
@@ -0,0 +1,472 @@
+(use-modules (guix gexp)
+             (gnu)
+             (guix)
+             ((guix build utils) #:prefix utils:)
+             ((guix modules) #:prefix modules:)
+             ((srfi srfi-1) #:prefix srfi-1:)
+       (srfi srfi-26)
+             ((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)))
+
+(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))
+
+(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))
+
+
+
+;; DNS constants
+
+(define user
+  "andreh")
+
+(define tld (slurp (string-append "/home/" user "/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 ci-domain-prefix "ci")
+(define ci-domain (string-append ci-domain-prefix "." tld))
+
+
+
+;; CI HTML generation from Git notes
+
+(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 name path)
+  (utils:with-directory-excursion path
+    (let* ((out-list (-> #´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 (-> #´git notes --ref=refs/notes/ci-data show $commit´
+                             (string-split #\space)))
+                   (logs #´git notes --ref=refs/notes/ci-logs show $commit´)
+                   (href (format #f
+                                 "https://~a/~a/blob?id=~a"
+                                 git-domain
+                                 name
+                                 #´git notes --ref=refs/notes/ci-logs list $commit´)))
+               (list (cons #:status (srfi-1:first data))
+                     (cons #:filename (srfi-1:second data))
+                     (cons #:logs logs)
+                     (cons #:href href))))
+           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)))
+                 (href (assoc-ref data #:href)))
+             (string-append
+              "<li>
+                 <a href=\"" href "\" download=" file ">
+                   " status "
+                   <pre>" file "</pre>
+                 </a>
+               </li>")))
+         (ci-data-in-repo-notes name (string-append git-data-path "/" name))))
+   "</ul>"))
+
+(define (generate-ci-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))))
+
+
+
+;; 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 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 "www"
+        mail-domain-prefix
+  ci-domain-prefix
+        git-domain-prefix
+        "chat"
+        "meet"))
+
+(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 generate-ci-html-job
+  #~(job "*/5 * * * *"
+         #$(program-file
+            "generate-ci-html.scm"
+            (with-imported-modules (modules:source-module-closure
+                                    '((guix build utils)))
+              #~(begin
+                  (use-modules (guix build utils))
+                  (display 'generate-ci-html))))))
+
+
+(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"))))))))))
+
+(operating-system
+  (locale "en_US.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-html-job))))
+          (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-nginx-config (list ci-domain) "/srv/ci"))
+      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
+          (nginx-server-configuration))))
+          (simple-service 'init-srv-directories
+                          activation-service-type
+                          #~(for-each (lambda (p)
+                                        (mkdir-p p)
+                                        ;; error: cmd is undefined
+                                        ;; #´chown -R $user users $p´
+          #;
+                                        (chown p #$user "users")
+          #;
+                                        (chmod p #o755))
+                                      '("/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)))