tissue: Add tissue service.

* guix/forge/tissue.scm: New file.

1 files changed, 296 insertions, 0 deletions

diff --git a/guix/forge/tissue.scm b/guix/forge/tissue.scm
new file mode 100644
index 0000000..4ffdf9f
--- /dev/null
+++ b/guix/forge/tissue.scm
@@ -0,0 +1,296 @@
+;;; guix-forge --- Guix software forge meta-service
+;;; Copyright © 2022 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 packages admin) #:select (shadow))
+  #:use-module ((gnu packages autotools) #:select (autoconf automake))
+  #: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 shadow)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix gexp)
+  #: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.systemreboot.net/skribilo")
+                      (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))))))
+
+;; TODO: Contribute tissue package upstream to Guix after its first
+;; release.
+(define-public tissue
+  (let ((commit "743f2eb0b2f107c8089bbd925dbd5052ff9fa9f9")
+        (revision "0"))
+    (package
+      (name "tissue")
+      (version (git-version "0.1.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://git.systemreboot.net/tissue")
+                      (commit commit)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "1fcxwclhpy0p17m6qingrzmaq0py1ys92v4p2ygyn69hmq9i048f"))))
+      (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))
+      (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))
+     (modules '((gnu build shepherd)
+                (gnu system file-systems)))
+     (start
+      (with-imported-modules (source-module-closure '((gnu build shepherd)
+                                                      (gnu system file-systems)))
+        #~(make-forkexec-constructor/container
+           (list #$(file-append (tissue-configuration-package config)
+                                "/bin/tissue")
+                 "run-web"
+                 (string-append "--config=" #$(computed-file "tissue.conf"
+                                                             (tissue-conf-gexp config))))
+           #:user "tissue"
+           #:group "tissue"
+           #:mappings (append (list (file-system-mapping
+                                     (source #$state-directory)
+                                     (target source))
+                                    (file-system-mapping
+                                     (source "/var/log/tissue.log")
+                                     (target source)
+                                     (writable? #t)))
+                              (if #$(forge-unix-socket? socket)
+                                  (list (file-system-mapping
+                                         (source #$(dirname (forge-unix-socket-path socket)))
+                                         (target source)
+                                         (writable? #t)))
+                                  (list)))
+           #: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))))