(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 "andreh")
                    (host-key "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOwnnw/u8ub+kcQhnVSyNWarYGH8aesUwIy4SIprufKf")))))

(list my-machine)