;;; 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 guile-git) #:select (guile-git))
#: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 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)
#: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))
;; Run an updated version of tissue until the the 0.1.1 release is
;; out.
(define-public tissue
(let ((commit "0c3d6cb7d781fbc0c12eba1563cc7b7ebb370ba9")
(revision "1"))
(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
"0hdqa5n8dm2nc4ccx39xclgajv3ivwpb1hbz9kpbbv25iizqhnv2"))))
(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)
(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 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 host directories if they don't exist, and set
;; permissions. Each host directory may be owned by its own
;; user.
(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))))
