;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2022, 2023, 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 tissue)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module ((forge guile-git) #:select (guile-git))
#:use-module (forge nginx)
#:use-module (forge socket)
#:use-module (gnu build linux-container)
#:use-module ((gnu packages admin) #:select (shadow))
#:use-module ((gnu packages web) #:select (tissue) #:prefix guix:)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services web)
#:use-module (gnu system file-systems)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix git-download)
#:use-module (guix least-authority)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (ice-9 match)
#: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-projects
<tissue-project>
tissue-project
tissue-project-name
tissue-project-user
tissue-project-base-path
tissue-project-upstream-repository))
;; Run an updated version of tissue until the the 0.1.1 release is
;; out.
(define-public tissue
(let ((commit "a9187595cccca4954c7d4920b93b922ea190e179")
(revision "2"))
(package
(inherit guix:tissue)
(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
"0pgdznck8vwmbccmpcqd3xnikbgzb2phxik7bcm80dls6g4n3py2"))))
(inputs
(modify-inputs (package-inputs guix:tissue)
(replace "guile-git" guile-git))))))
(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)
(projects tissue-host-projects
(default '())))
(define-record-type* <tissue-project>
tissue-project make-tissue-project
tissue-project?
this-tissue-project
(name tissue-project-name)
(user tissue-project-user
(default "tissue"))
(base-path tissue-project-base-path
(default (string-append "/"
(tissue-project-name this-tissue-project)
"/"))
(thunked))
(upstream-repository tissue-project-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)
(define project->alist
(match-record-lambda <tissue-project>
(name base-path upstream-repository)
`(,name
(base-path . ,base-path)
(upstream-repository . ,upstream-repository))))
(define host->alist
(match-record-lambda <tissue-host>
(name projects)
`(,name
(projects . ,(map project->alist projects)))))
(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 host->alist 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 if Unix socket.
#$(and (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. The state directory is owned by
;; the tissue user.
(mkdir-p #$state-directory)
(chown #$state-directory (passwd:uid user) (passwd:gid user)))
;; Create project directories if they don't exist, and set
;; permissions. Each project directory may be owned by its
;; own user.
(for-each (match-lambda
((project-name username)
(let ((project-directory (string-append #$state-directory "/" project-name))
(user (getpw username)))
(mkdir-p project-directory)
(for-each (lambda (file)
(chown file (passwd:uid user) (passwd:gid user)))
(find-files project-directory #:directories? #t)))))
'#$(append-map (lambda (host)
(map (match-record-lambda <tissue-project>
(name user)
(list name user))
(tissue-host-projects host)))
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-nginx-server-blocks config)
"Return list of @code{<nginx-server-configuration>} extensions for
tissue configuration @var{config}."
(define (project->location state-directory project)
(nginx-location-configuration
(uri (tissue-project-base-path project))
(body (list (string-append "alias "
state-directory
"/"
(tissue-project-name project)
"/website/;")
"try_files $uri $uri.html $uri/ @tissue-search;"))))
(match-record config <tissue-configuration>
(socket state-directory hosts)
(map (match-record-lambda <tissue-host>
(name projects)
(nginx-server-configuration
(server-name (list name))
(locations
(cons (nginx-location-configuration
(uri "@tissue-search")
(body (list (socket->nginx-proxy-pass socket)
"proxy_set_header Host $host;")))
(append (map (cut project->location state-directory <>)
projects)
;; Reject all other locations, unless there
;; is a project with / as its base path.
(if (member "/" (map tissue-project-base-path
projects))
(list)
(list (nginx-location-configuration
(uri "/")
(body (list "return 404;"))))))))))
hosts)))
(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))
(service-extension forge-nginx-service-type
tissue-nginx-server-blocks)))
(compose concatenate)
(extend (lambda (config host-extensions)
(tissue-configuration
(inherit config)
(hosts (append (tissue-configuration-hosts config)
host-extensions)))))
(default-value (tissue-configuration))))
