;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2022, 2023 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 tissue)
  #:use-module (srfi srfi-1)
  #:use-module (forge socket)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu packages admin) #:select (shadow))
  #:use-module ((gnu packages autotools) #:select (autoconf automake))
  #:use-module ((gnu packages compression) #:select (lzip))
  #:use-module ((gnu packages gettext) #:select (gnu-gettext))
  #:use-module ((gnu packages guile) #:select (guile-3.0 guile-git))
  #:use-module ((gnu packages guile-xyz) #:select (guile-filesystem guile-xapian))
  #:use-module ((gnu packages skribilo) #:select (skribilo) #:prefix guix:)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (guix build-system gnu)
  #:use-module (guix download)
  #:use-module (guix gexp)
  #:use-module (guix least-authority)
  #:use-module (guix modules)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:export (tissue-service-type
            <tissue-configuration>
            tissue-configuration
            tissue-configuration?
            tissue-configuration-package
            tissue-configuration-socket
            tissue-configuration-state-directory
            tissue-configuration-hosts
            <tissue-host>
            tissue-host
            tissue-host?
            tissue-host-name
            tissue-host-user
            tissue-host-upstream-repository))

;; tissue requires an unreleased version of skribilo for its gemtext
;; reader.
(define-public skribilo-latest
  (let ((commit "621eb1945aec8f26f5aee4bdf896f2434e145182")
        (revision "1"))
    (package
      (inherit guix:skribilo)
      (name "skribilo")
      (version (git-version "0.9.5" revision commit))
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url "https://git.savannah.gnu.org/git/skribilo.git")
                      (commit commit)))
                (file-name (git-file-name name version))
                (sha256
                 (base32
                  "16rdcvszl9x183y32hjdwns0lkrvkmwd2fsshymspb12k4cxj6i4"))))
      (native-inputs
       (modify-inputs (package-native-inputs guix:skribilo)
         (prepend autoconf)
         (prepend automake)
         (prepend gnu-gettext))))))

;; We use this commit of guile-xapian until the 0.4.0 release.
(define guile-xapian-latest
  (let ((commit "93162fd60dbc0cce726113a82c13d88783a279b6")
        (revision "1"))
    (package
      (inherit guile-xapian)
      (name "guile-xapian")
      (version (git-version (package-version guile-xapian) revision commit))
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url "https://git.systemreboot.net/guile-xapian")
                      (commit commit)))
                (file-name (git-file-name name version))
                (sha256
                 (base32
                  "0g9w10wsjw11ayi9l5y0k6lz4mq2qfhq2hwbxbqgdj7jmllwirgp")))))))

;; TODO: Contribute tissue package upstream to Guix after release of
;; its guile-xapian and skribilo dependencies.
(define-public tissue
  (package
    (name "tissue")
    (version "0.1.0")
    (source (origin
              (method url-fetch)
              (uri (string-append "https://tissue.systemreboot.net/releases/tissue-"
                                  version ".tar.lz"))
              (sha256
               (base32
                "0vsybgnzv8nnwf58pnxrs4101xczl8jvxd1wzmk4vmdyrp8a2kkm"))))
    (build-system gnu-build-system)
    (arguments
     (list #:make-flags #~(list (string-append "prefix=" #$output))
           #:modules `(((guix build guile-build-system)
                        #:select (target-guile-effective-version))
                       ,@%gnu-build-system-modules)
           #:phases
           (with-imported-modules '((guix build guile-build-system))
             #~(modify-phases %standard-phases
                 (replace 'patch-source-shebangs
                   (lambda* (#:key inputs #:allow-other-keys)
                     (substitute* "bin/tissue"
                       (("^exec guile")
                        (string-append "exec " (search-input-file inputs "/bin/guile"))))))
                 (delete 'configure)
                 (add-after 'install 'wrap
                   (lambda* (#:key inputs outputs #:allow-other-keys)
                     (let ((out (assoc-ref outputs "out"))
                           (effective-version (target-guile-effective-version)))
                       (wrap-program (string-append out "/bin/tissue")
                         `("GUILE_LOAD_PATH" prefix
                           (,(string-append out "/share/guile/site/" effective-version)
                            ,(getenv "GUILE_LOAD_PATH")))
                         `("GUILE_LOAD_COMPILED_PATH" prefix
                           (,(string-append out "/lib/guile/" effective-version "/site-ccache")
                            ,(getenv "GUILE_LOAD_COMPILED_PATH")))))))))))
    (inputs (list guile-3.0 guile-filesystem guile-git guile-xapian-latest))
    (native-inputs
     (list lzip))
    (propagated-inputs
     (list skribilo-latest))
    (home-page "https://tissue.systemreboot.net")
    (synopsis "Text based project information management system")
    (description
     "tissue is an issue tracker and project information management system
built on plain text files and git.  It features a static site
generator to build a project website and a powerful search interface
to search through project issues and documentation.  The search
interface is built on the Xapian search engine library, and is
available both as a command-line program and as a web server.")
    (license license:gpl3+)))

(define-record-type* <tissue-configuration>
  tissue-configuration make-tissue-configuration
  tissue-configuration?
  (package tissue-configuration-package
           (default tissue))
  (socket tissue-configuration-socket
          (default (forge-unix-socket
                    (path "/var/run/tissue/socket"))))
  (state-directory tissue-configuration-state-directory
                   (default "/var/lib/tissue"))
  (hosts tissue-configuration-hosts
         (default '())))

(define-record-type* <tissue-host>
  tissue-host make-tissue-host
  tissue-host?
  (name tissue-host-name)
  (user tissue-host-user
        (default "tissue"))
  (upstream-repository tissue-host-upstream-repository))

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

(define (tissue-conf-gexp config)
  (match-record config <tissue-configuration>
    (socket state-directory hosts)
    #~(begin
        (use-modules (ice-9 pretty-print))

        (call-with-output-file #$output
          (lambda (port)
            (pretty-print
             '((listen . #$(cond
                            ((forge-ip-socket? socket)
                             (match-record socket <forge-ip-socket>
                               (ip port)
                               (string-append (if (ipv4-address? ip)
                                                  ip
                                                  (string-append "[" ip "]"))
                                              ":"
                                              (number->string port))))
                            ((forge-unix-socket? socket)
                             (string-append "unix:" (forge-unix-socket-path socket)))
                            (else (raise (condition
                                          (make-message-condition
                                           "Socket must be a <forge-ip-socket> or <forge-unix-socket> record")
                                          (make-irritants-condition socket))))))
               (state-directory . #$state-directory)
               (hosts . #$(map (lambda (host)
                                 (match-record host <tissue-host>
                                   (name upstream-repository)
                                   `(,name (upstream-repository . ,upstream-repository))))
                               hosts)))
             port))))))

;; We cannot just pass the configuration file on the command-line
;; because we need future `tissue pull' invocations to find it. These
;; `tissue pull' invocations are beyond the scope of this service, and
;; will need to find the configuration at a standard location.
(define (tissue-etc-files config)
  `(("tissue.conf" ,(computed-file "tissue.conf"
                                   (tissue-conf-gexp config)))))

(define (tissue-activation config)
  (match-record config <tissue-configuration>
    (socket state-directory hosts)
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 match))

          (let ((user (getpw "tissue")))
            ;; Create socket directory.
            (when #$(forge-unix-socket? socket)
              (let ((socket-directory #$(dirname (forge-unix-socket-path socket))))
                (mkdir-p socket-directory)
                (chown socket-directory (passwd:uid user) (passwd:gid user))))
            ;; Create state directory.
            (mkdir-p #$state-directory)
            (chown #$state-directory (passwd:uid user) (passwd:gid user)))
          ;; Create host directories if they don't exist, and set
          ;; permissions.
          (for-each (match-lambda
                      ((hostname username)
                       (let ((host-directory (string-append #$state-directory "/" hostname))
                             (user (getpw username)))
                         (mkdir-p host-directory)
                         (for-each (lambda (file)
                                     (chown file (passwd:uid user) (passwd:gid user)))
                                   (find-files host-directory #:directories? #t)))))
                    '#$(map (lambda (host)
                              (match-record host <tissue-host>
                                (name user)
                                (list name user)))
                            hosts))))))

(define (tissue-shepherd-service config)
  (match-record config <tissue-configuration>
    (socket state-directory)
    (shepherd-service
     (documentation "Run tissue web server.")
     (provision '(tissue))
     (requirement '(networking))
     (start
      (let ((tissue-conf (computed-file "tissue.conf" (tissue-conf-gexp config))))
        #~(make-forkexec-constructor
           (list #$(least-authority-wrapper
                    (file-append (tissue-configuration-package config)
                                 "/bin/tissue")
                    #:name "tissue"
                    #:mappings (cons* (file-system-mapping
                                       (source tissue-conf)
                                       (target source))
                                      (file-system-mapping
                                       (source state-directory)
                                       (target source))
                                      (if (forge-unix-socket? socket)
                                          (list (file-system-mapping
                                                 (source (dirname (forge-unix-socket-path socket)))
                                                 (target source)
                                                 (writable? #t)))
                                          (list)))
                    ;; 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))
                 "web"
                 (string-append "--config=" #$tissue-conf))
           #:user "tissue"
           #:group "tissue"
           #:log-file "/var/log/tissue.log")))
     (stop #~(make-kill-destructor)))))

(define tissue-service-type
  (service-type
   (name 'tissue)
   (description "Run tissue web server.")
   (extensions
    (list (service-extension account-service-type
                             (const %tissue-accounts))
          (service-extension etc-service-type
                             tissue-etc-files)
          (service-extension activation-service-type
                             tissue-activation)
          (service-extension shepherd-root-service-type
                             (compose list tissue-shepherd-service))))
   (compose concatenate)
   (extend (lambda (config host-extensions)
             (tissue-configuration
              (inherit config)
              (hosts (append (tissue-configuration-hosts config)
                             host-extensions)))))
   (default-value (tissue-configuration))))