;;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Copyright © 2023 Saku Laesvuori <saku@laesvuori.fi>

(define-module (nongnu services version-control)
  #:use-module ((rnrs) :version (6))
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu services base)
  #:use-module (gnu services certbot)
  #:use-module (gnu services configuration)
  #:use-module (gnu services databases)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu services)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (ice-9 string-fun)
  #:use-module (nongnu packages version-control)
  #:use-module (srfi srfi-1)
  #:export
    (gitea-configuration
     gitea-service-type))

(define (gitea-fields? x)
  (match x
    (((section . ((name . value) ...)) ...)
     (and (all symbol? section)
          (all symbol? name)))
    (_
      #f)))

(define-maybe string)

(define-configuration/no-serialization gitea-configuration
  (app-name
    (string "Gitea: Git with a cup of tea")
    "Instance name")
  (domain
    (string "localhost")
    "Domain name of the server")
  (root-url
    (maybe-string)
    "Public root url, default http(s)://DOMAIN/")
  (extra-gitea-fields
    (gitea-fields '())
    "Extra gitea configuration")
  (https?
    (boolean #t)
    "Set up HTTPS with certbot")
  (nginx?
    (boolean #t)
    "Set up NGINX as a reverse proxy")
  (postgresql?
    (boolean #t)
    "Set up a PostgreSQL database")
  (gitea
    (package gitea)
    "The Gitea package to use")
  (work-dir
    (string "/var/lib/gitea")
    "Gitea working directory")
  (run-dir
    (string "/var/run/gitea")
    "Gitea runtime directory")
  (internal-token
    (maybe-string)
    "Path to gitea's internal token"))

(define (gitea-internal-token config)
  (match-record config <gitea-configuration>
    (internal-token work-dir)
    (if (maybe-value-set? internal-token)
      internal-token
      (string-append work-dir "/internal-token"))))

(define (gitea-configuration->fields config)
  (match-record config <gitea-configuration>
    (app-name work-dir domain root-url extra-gitea-fields nginx? https? postgresql? run-dir)
    (append
      `((DEFAULT . ((app-name . ,app-name)))
        (security . ((internal-token-uri . ,(string-append "file:" (gitea-internal-token config)))
                     (install-lock . #t)))
        ,@(if postgresql?
            '((database . ((db-type . "postgres")
                           (host . "/var/run/postgresql/")
                           (user . "gitea")
                           (name . "gitea"))))
            '())
        (server . ((domain . ,domain)
                   (ssh-root-path . ,(string-append work-dir "/.ssh"))
                ,@(if root-url `((root-url . ,root-url)) '())
                ,@(if nginx?
                    `((protocol . "http+unix")
                      (http-addr . ,(string-append run-dir "/gitea.socket")))
                    (if https?
                      `((protocol . "https")
                        (cert-file . ,(string-append "/etc/letsencrypt/live/" domain "/fullchain.pem"))
                        (key-file . ,(string-append "/etc/letsencrypt/live/" domain "/privkey.pem")))
                      '())))))
      extra-gitea-fields)))

(define (gitea-shepherd-service config)
  (match-record config <gitea-configuration>
    (work-dir run-dir postgresql? gitea)
    (let ((config-file (gitea-serialize-config config)))
      (list (shepherd-service
              (documentation "Run the gitea server")
              (requirement `(networking ,@(if postgresql? '(postgres) '())))
              (provision '(gitea))
              (start #~(make-forkexec-constructor
                         (list
                           #$(file-append gitea "/bin/gitea")
                           "web"
                           "--config" #$config-file
                           "--work-path" #$work-dir
                           "--custom-path" (string-append #$work-dir "/custom")
                           "--pid" (string-append #$run-dir "/pid"))
                         #:user "gitea"
                         #:group "gitea"
                         #:directory #$work-dir
                         ; TODO can these be set automatically
                         #:environment-variables (cons*
                           "USER=gitea"
                           (string-append "HOME=" #$work-dir)
                           (default-environment-variables))))
              (stop #~(make-kill-destructor))
              (actions (list (shepherd-configuration-action config-file))))))))

(define (gitea-certbot config)
  (match-record config <gitea-configuration>
    (https? domain nginx?)
    (if (not https?) '()
      (list (certificate-configuration
        (domains (list domain))
        (deploy-hook (if nginx? %nginx-cert-deploy-hook %gitea-cert-deploy-hook)))))))

(define (gitea-postgresql-roles config)
  (match-record config <gitea-configuration>
    (postgresql?)
    (if postgresql?
      (list (postgresql-role
              (name "gitea")
              (create-database? #t)))
      '())))

(define (gitea-accounts config)
  (match-record config <gitea-configuration>
    (work-dir)
    (list (user-group
            (name "gitea")
            (system? #t))
          (user-account
            (name "gitea")
            (system? #t)
            (group "gitea")
            (comment "Gitea server user")
            (home-directory work-dir)
            (shell (file-append bash-minimal "/bin/bash"))))))

(define (gitea-activation config)
  (match-record config <gitea-configuration>
    (work-dir run-dir)
    #~(begin
        (use-modules (guix build utils)
                     (ice-9 string-fun))
        (let* ((user (getpw "gitea"))
               (user-id (passwd:uid user))
               (group-id (passwd:gid user))
               (internal-token #$(gitea-internal-token config))
               (shell-escape (lambda (str)
                               (string-append "'"
                                              (string-replace-substring str "'" "'\"'\"'")
                                              "'")))
               (generate-internal-token
                 (lambda _
                   (if (not (file-exists? internal-token))
                     (system*
                      (string-append #$bash-minimal "/bin/bash") "-c"
                       (string-append
                        "umask 277 ; "
                        ; /dev/random blocks if there isn't enough entropy which
                        ; might be useful as this might be ran right after booting
                        #$coreutils "/bin/head -c 30 /dev/urandom | "
                        #$coreutils "/bin/base64 > " (shell-escape internal-token)))))))
          (mkdir-p #$work-dir)
          (mkdir-p #$run-dir)
          (unless (file-exists? internal-token) (generate-internal-token))
          (chown #$work-dir user-id group-id)
          (chown #$run-dir user-id group-id)
          (chown internal-token user-id group-id)))))

(define (gitea-nginx config)
  (match-record config <gitea-configuration>
    (https? domain nginx? run-dir)
    (if (not nginx?) '()
      (list (nginx-server-configuration
        (listen (if https? '("443 ssl") '("80")))
        (server-name (list domain))
        (ssl-certificate (if https? (string-append "/etc/letsencrypt/live/" domain "/fullchain.pem") #f))
        (ssl-certificate-key (if https? (string-append "/etc/letsencrypt/live/" domain "/privkey.pem") #f))
        (locations (list
          (nginx-location-configuration
            (uri "/")
            (body `(,(string-append "proxy_pass http://unix:" run-dir "/gitea.socket;")
                    "proxy_set_header Host $host;"
                    "proxy_set_header X-Real_IP $remote_addr;"
                    "proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;"
                    "proxy_set_header X-Forwarded-Proto $scheme;"))))))))))

(define %nginx-cert-deploy-hook
  (program-file
    "nginx-cert-deploy-hook"
    #~(let ((pid (call-with-input-file "/var/run/nginx/pid" read)))
        (kill pid SIGHUP))))

(define %gitea-cert-deploy-hook
  (program-file
    "gitea-cert-deploy-hook"
    (with-imported-modules '((guix build utils))
      #~(begin (use-modules (guix build utils))
               (invoke "herd" "restart" "gitea")))))

(define (gitea-serialize-name name)
  (let ((str (symbol->string name)))
    (string-replace-substring
      (if (string-suffix? "?" str)
        (string-drop-right str 1)
        str)
      "-"
      "_")))

(define (gitea-serialize-field-name field-name)
  (string-upcase (gitea-serialize-name field-name)))

(define (gitea-serialize-config config)
  (gitea-serialize-fields (gitea-configuration->fields config)))

(define (gitea-serialize-fields fields)
  (mixed-text-file "app.ini" #~(string-concatenate (list #$@(map gitea-serialize-sections fields)))))

(define (gitea-serialize-sections sections)
  (match sections
         ((section . (fields ...))
          #~(string-append "[" #$(gitea-serialize-name section) "]\n"
                         (string-concatenate (list #$@(map gitea-serialize-field fields)))))))

(define (gitea-serialize-field field)
  (match field
         ((name . value)
          (if (maybe-value-set? value)
           ;; XXX It seems that there is no way to perfectly escape values for
           ;; gitea/go-ini. """ is probably the most unlikely escaping to fail
           #~(string-append #$(gitea-serialize-field-name name) " = \"\"\""
                            #$(gitea-serialize-value value) "\"\"\"\n")
           ""))))

(define (gitea-serialize-value value)
  (cond ((number? value) (number->string value))
        ((boolean? value) (if value "true" "false"))
        ((string? value) value)
        ((list? value) #~(string-join (list #$@(map gitea-serialize-value value)) ","))
        ((file-like? value) value)
        (else (error (format #f "Invalid type for gitea-serialize-value: ~a" value)))))

(define (all pred struct)
  (match struct
         ('() #t)
         ((a . b) (and (all pred a) (all pred b)))
         (leaf (pred leaf))))

(define gitea-service-type
  (service-type
    (name 'gitea)
    (extensions
      (list (service-extension account-service-type gitea-accounts)
            (service-extension activation-service-type gitea-activation)
            (service-extension shepherd-root-service-type gitea-shepherd-service)
            (service-extension nginx-service-type gitea-nginx)
            (service-extension certbot-service-type gitea-certbot)
            (service-extension postgresql-role-service-type gitea-postgresql-roles)))
    (description "Run the gitea server")
    (default-value (gitea-configuration))))