;;; SPDX-License-Identifier: CC0-1.0
;;;
;;; Copyright © 2023, 2024 Wojtek Kosior <koszko@koszko.org>

(define-module (gnu services ca)
  #:use-module ((srfi srfi-1) #:select (concatenate))
  #:use-module ((guix records) #:select (define-record-type* match-record))
  #:use-module ((guix gexp) #:select (gexp file-append))
  #:use-module ((gnu services) #:select
                (service-extension activation-service-type service-type))
  #:use-module ((gnu packages tls) #:select (openssl))
  #:export (snakeoil-service-type
            snakeoil-configuration
            snakeoil-configuration?
            snakeoil-cert-configuration))

(define-record-type* <snakeoil-cert-configuration> snakeoil-cert-configuration
  make-snakeoil-cert-configuration snakeoil-cert-configuration?
  (name            snakeoil-cert-configuration-name
                   (default #f))
  (domains         snakeoil-cert-configuration-domains
                   (default '()))
  (key-group-owner snakeoil-cert-configuration-key-group-owner
                   (default #f)))

(define-record-type* <snakeoil-configuration> snakeoil-configuration
  make-snakeoil-configuration snakeoil-configuration?
  (openssl      snakeoil-configuration-openssl
                (default openssl))
  (owner        snakeoil-configuration-owner
                (default "root"))
  (group-owner  snakeoil-configuration-group-owner
                (default #f))
  (rsa-key-size snakeoil-configuration-rsa-key-size
                (default 4096))
  (certificates snakeoil-configuration-certificates
                (default '())))

(define (snakeoil-activation config)
  (match-record config <snakeoil-configuration>
    (openssl owner group-owner rsa-key-size certificates)
    #~(begin
        (use-modules (ice-9 format)
                     (ice-9 textual-ports))

        (define openssl
          #$(file-append openssl "/bin/openssl"))

        (define pwnam
          (getpw #$owner))

        (define grnam
          (and=> #$group-owner getgr))

        (define (chown-file filename)
          (chown filename (passwd:uid pwnam) (or (and=> grnam group:gid) -1)))

        (define (generate-private-key path)
          (let ((initial-umask (umask))
                (tmp-path (string-append path ".tmp.pem")))
            (umask #o027)
            (system* openssl "genrsa" "-out" tmp-path
                     #$(number->string rsa-key-size))
            (rename-file tmp-path path)
            (umask initial-umask)))

        (mkdir-p "/etc/snakeoil/certs")

        (unless (false-if-exception
                 (stat "/etc/snakeoil/private/key.pem"))
          (mkdir-p "/etc/snakeoil/private/")
          (generate-private-key "/etc/snakeoil/private/key.pem"))

        (unless (false-if-exception
                 (stat "/etc/snakeoil/root-cert.pem"))
          ;; Self-sign a local certificate authority.
          (system* openssl "req"
                   "-x509" "-new" "-nodes" "-sha256"
                   "-days" (number->string (* 20 365))
                   "-out" "/etc/snakeoil/root-cert.pem"
                   "-key" "/etc/snakeoil/private/key.pem"
                   "-subj" "/CN=snakeoil-root"))

        (chown-file "/etc/snakeoil")
        (chown-file "/etc/snakeoil/certs")
        (chown-file "/etc/snakeoil/private")
        (chown-file "/etc/snakeoil/private/key.pem")
        (chown-file "/etc/snakeoil/root-cert.pem")

        (define (issue-cert cert-name domains key-group-owner)
          (let* ((cert-name* (or cert-name (car domains)))
                 (cert-dir (format #f "/etc/snakeoil/certs/~a" cert-name*))
                 (tmp-dir (format #f "/etc/snakeoil/certs-tmp/~a" cert-name*))
                 (cert-path (format #f "~a/cert.pem" tmp-dir))
                 (chain-link-path (format #f "~a/chain.pem" tmp-dir))
                 (key-path (format #f "~a/privkey.pem" tmp-dir))
                 (fullchain-path (format #f "~a/fullchain.pem" tmp-dir))
                 (csr-path (format #f "~a/csr.pem" tmp-dir)))
            (unless (false-if-exception (stat cert-dir))
              (system* "rm" "-rf" tmp-dir)
              (mkdir-p tmp-dir)

              (generate-private-key key-path)

              (system* openssl "req"
                       "-new" "-nodes" "-out" csr-path
                       "-key" key-path
                       "-subj" (format #f "/CN=~a" (car domains))
                       "-addext" (format #f "subjectAltName=~{DNS:~a~^,~}"
                                         domains))

              (system* openssl "x509"
                       "-req" "-sha256" "-CAcreateserial"
                       "-days" (number->string (* 20 365))
                       "-copy_extensions=copyall"
                       "-in" csr-path
                       "-CA" "/etc/snakeoil/root-cert.pem"
                       "-CAkey" "/etc/snakeoil/private/key.pem"
                       "-out" cert-path "-days" (number->string (* 20 365)))

              (symlink "../../../snakeoil/root-cert.pem" chain-link-path)

              ;; Concatenate cert.pem and chain.pem into fullchain.pem.
              (with-output-to-file fullchain-path
                (lambda _
                  (for-each (lambda (part)
                              (call-with-input-file part
                                (compose display get-string-all)))
                            (list cert-path chain-link-path))))

              (delete-file csr-path)

              (map chown-file
                   (list tmp-dir cert-path fullchain-path))

              (when key-group-owner
                (chown key-path -1  (if (integer? key-group-owner)
                                        key-group-owner
                                        (group:gid (getgr key-group-owner))))
                (chmod key-path #o640))

              (rename-file tmp-dir cert-dir))))

        (map issue-cert
             '#$(map snakeoil-cert-configuration-name certificates)
             '#$(map snakeoil-cert-configuration-domains certificates)
             '#$(map snakeoil-cert-configuration-key-group-owner
                     certificates)))))

(define snakeoil-service-type
  (service-type
   (name 'snakeoil)
   (extensions
    (list (service-extension activation-service-type snakeoil-activation)))
   (compose concatenate)
   (extend (lambda (config extra-certificates)
             (snakeoil-configuration
              (inherit config)
              (certificates (append
                             (snakeoil-configuration-certificates config)
                             extra-certificates)))))
   (default-value (snakeoil-configuration))
   (description "Generate self-issued TLS certificates.")))