(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 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 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))



;; 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-logs-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 user
  "andreh")

(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"
        git-domain-prefix
        "chat"
        "meet"))

(define tls-domains
  (cons tld
        (map #[string-append % "." tld]
             tls-prefixes)))

(define generate-logs-html-job
  #~(job "*/5 * * * *"
         #$(program-file
            "generate-logs-html.scm"
            (with-imported-modules (modules:source-module-closure
                                    '((guix build utils)))
              #~(begin
                  (use-modules (guix build utils))
                  (display 'generate-logs-html))))))

(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-logs-html-job))))
          (simple-service 'automatic-mcron-restart
                          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"))
                    (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")))))
          (simple-service 'init-srv-directories
                          activation-service-type
                          #~(for-each (lambda (p)
                                        (mkdir-p p)
                                        (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)))
