;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2022, 2025 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guix-forge.
;;;
;;; guix-forge is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; guix-forge is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guix-forge.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (forge webhook)
  #:use-module (srfi srfi-1)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu packages admin) #:select (shadow))
  #:use-module ((gnu packages guile) #:select (guile-json-4))
  #:use-module ((gnu packages web) #:select (webhook))
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system accounts)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix least-authority)
  #:use-module (forge socket)
  #:export (webhook-service-type
            webhook-configuration
            webhook-configuration?
            webhook-configuration-package
            webhook-configuration-socket
            webhook-configuration-log-directory
            webhook-configuration-hooks
            webhook-hook
            webhook-hook?
            webhook-hook-id
            webhook-hook-run))

(define-record-type* <webhook-configuration>
  webhook-configuration make-webhook-configuration
  webhook-configuration?
  (package webhook-configuration-package
           (default webhook))
  (socket webhook-configuration-socket
          (default (forge-ip-socket
                    (ip "127.0.0.1")
                    (port 9000))))
  (log-directory webhook-configuration-log-directory
                 (default "/var/log/webhook"))
  (hooks webhook-configuration-hooks
         (default '())))

(define-record-type* <webhook-hook>
  webhook-hook make-webhook-hook
  webhook-hook?
  (id webhook-hook-id)
  (run webhook-hook-run))

(define %webhook-accounts
  (list (user-account
         (name "webhook")
         (group "webhook")
         (system? #t)
         (comment "webhook user")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))
        (user-group
         (name "webhook")
         (system? #t))))

(define (webhook-activation config)
  (match-record config <webhook-configuration>
    (log-directory)
    #~(begin
        ;; Create log directory and set permissions.
        (mkdir-p #$log-directory)
        (let ((user (getpw "webhook")))
          (for-each (lambda (file)
                      (chown file (passwd:uid user) (passwd:gid user)))
                    (find-files #$log-directory #:directories? #t))))))

(define (hooks-json-gexp config)
  (with-extensions (list guile-json-4)
    #~(begin
        (use-modules (srfi srfi-26)
                     (json))
        
        (call-with-output-file #$output
          (cut scm->json
               ;; We convert from list to vector on the build-side
               ;; because a vector cannot be lowered correctly into a
               ;; G-expression.
               (list->vector
                ;; We build a true dotted association list in this
                ;; roundabout way because a true dotted association
                ;; list cannot be lowered correctly into a
                ;; G-expression.
                (map (cut map (cut apply cons <>) <>)
                     '#$(map (lambda (hook)
                               `(("id" ,(webhook-hook-id hook))
                                 ("execute-command" ,(program-file (string-append (webhook-hook-id hook)
                                                                                  "-webhook")
                                                                   (webhook-hook-run hook)))))
                             (webhook-configuration-hooks config))))
               <>)))))

(define (webhook-shepherd-service config)
  (shepherd-service
   (documentation "Run webhook.")
   (provision '(webhook))
   (requirement '(networking))
   (start
    (let ((hooks-json (computed-file "hooks.json" (hooks-json-gexp config))))
      #~(make-forkexec-constructor
         (list #$(least-authority-wrapper
                  (file-append (webhook-configuration-package config)
                               "/bin/webhook")
                  #:name "webhook"
                  #:mappings (list (file-system-mapping
                                    (source hooks-json)
                                    (target source))
                                   (file-system-mapping
                                    (source (webhook-configuration-log-directory config))
                                    (target source)
                                    (writable? #t)))
                  ;; TODO: If socket is a Unix socket, run in a
                  ;; network namespace. We can't do this yet due to
                  ;; https://yhetil.org/guix/m1ilknoi5r.fsf@fastmail.net/
                  #:namespaces (delq 'net %namespaces))
               "-hooks" #$hooks-json
               "-ip" #$(forge-ip-socket-ip (webhook-configuration-socket config))
               "-port" #$(number->string (forge-ip-socket-port (webhook-configuration-socket config)))
               "-logfile" #$(string-append (webhook-configuration-log-directory config)
                                           "/webhook.log"))
         #:user "webhook"
         #:group "webhook"
         #:log-file "/var/log/webhook.log")))
   (stop #~(make-kill-destructor))))

(define webhook-service-type
  (service-type
   (name 'webhook)
   (description "Run webhook.")
   (extensions (list (service-extension account-service-type
                                        (const %webhook-accounts))
                     (service-extension activation-service-type
                                        webhook-activation)
                     (service-extension shepherd-root-service-type
                                        (compose list webhook-shepherd-service))))
   (compose concatenate)
   (extend (lambda (config hook-extensions)
             (webhook-configuration
              (inherit config)
              (hooks (append (webhook-configuration-hooks config)
                             hook-extensions)))))
   (default-value (webhook-configuration))))