;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix least-authority)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module ((guix store) #:select (%store-prefix))
  #:autoload   (gnu build linux-container) (%namespaces)
  #:autoload   (gnu system file-systems) (file-system-mapping
                                          file-system-mapping-source
                                          spec->file-system
                                          file-system->spec
                                          file-system-mapping->bind-mount)
  #:export (least-authority-wrapper))

;;; Commentary:
;;;
;;; This module provides tools to execute programs with the least authority
;;; necessary, using Linux namespaces.
;;;
;;; Code:

(define %precious-variables
  ;; Environment variables preserved by the wrapper by default.
  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))

(define* (least-authority-wrapper program
                                  #:key (name "pola-wrapper")
                                  (guest-uid 1000)
                                  (guest-gid 1000)
                                  (mappings '())
                                  (namespaces %namespaces)
                                  (directory "/")
                                  (preserved-environment-variables
                                   %precious-variables))
  "Return a wrapper of PROGRAM that executes it with the least authority.

PROGRAM is executed in separate namespaces according to NAMESPACES, a list of
symbols; it runs with GUEST-UID and GUEST-GID.  MAPPINGS is a list of
<file-system-mapping> records indicating directories mirrored inside the
execution environment of PROGRAM.  DIRECTORY is the working directory of the
wrapped process.  Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
is preserved; other environment variables are erased."
  (define code
    (with-imported-modules (source-module-closure
                            '((gnu system file-systems)
                              (gnu build shepherd)
                              (gnu build linux-container)))
      #~(begin
          (use-modules (gnu system file-systems)
                       (gnu build linux-container)
                       ((gnu build shepherd) #:select (default-mounts))
                       (srfi srfi-1))

          (define variables
            (filter-map (lambda (variable)
                          (let ((value (getenv variable)))
                            (and value
                                 (string-append variable "=" value))))
                        '#$preserved-environment-variables))

          (define (read-file file)
            (call-with-input-file file read))

          (define references
            (delete-duplicates
             (append-map read-file
                         '#$(map references-file
                                 (cons program
                                       (map file-system-mapping-source
                                            mappings))))))

          (define (store? file-system)
            (string=? (file-system-mount-point file-system)
                      #$(%store-prefix)))

          (define mounts
            (append (map (lambda (item)
                           (file-system-mapping->bind-mount
                            (file-system-mapping (source item)
                                                 (target item))))
                         references)
                    (remove store?
                            (default-mounts
                              #:namespaces '#$namespaces))
                    (map spec->file-system
                         '#$(map (compose file-system->spec
                                          file-system-mapping->bind-mount)
                                 mappings))))

          (define (reify-exit-status status)
            (cond ((status:exit-val status) => exit)
                  ((or (status:term-sig status)
                       (status:stop-sig status))
                   => (lambda (signal)
                        (format (current-error-port)
                                "~a terminated with signal ~a~%"
                                #$program signal)
                        (exit (+ 128 signal))))))

          ;; Note: 'call-with-container' creates a sub-process that this one
          ;; waits for.  This might seem suboptimal but unshare(2) isn't
          ;; really applicable: the process would still run in the same PID
          ;; namespace.

          (reify-exit-status
           (call-with-container mounts
             (lambda ()
               (chdir #$directory)
               (environ variables)
               (apply execl #$program #$program (cdr (command-line))))

             ;; Don't assume PROGRAM can behave as an init process.
             #:child-is-pid1? #f

             #:guest-uid #$guest-uid
             #:guest-gid #$guest-gid
             #:namespaces '#$namespaces)))))

  (program-file name code))