;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 (gnu services fs-entry)
  #:use-module stuff ...)
;;;
;;; Create directory structures for services with security context,
;;; without race conditions.  Symbolic links are not followed.
;;;

;; Values passed in extensions to @code{fs-entry-service-type}.
;; TODO maybe also allow defining SELinux, SMACK and POSIX ACL.
(define-record-type* <fs-entry>
  fs-entry make-fs-entry fs-entry?
  (where fs-entry-where) ; /name/of/file
  (bits  fs-entry-bits) ; permission bits
  (type  fs-entry-type) ; directory, regular or symlink
  (owner fs-entry-owner) ; owner, as a string
  (group fs-entry-group)) ; group, as a string

;; Likewise, but converted to a tree structure.
(define-record-type* <fs-entry/tree>
  fs-entry/tree make-fs-entry/tree fs-entry/tree?
  (name     fs-entry/tree-where) ; basename
  (bits     fs-entry/tree-bits) ; permission bits
  (type     fs-entry/tree-type) ; directory, regular or symlink
  (owner    fs-entry/tree-owner) ; owner, as a string
  (group    fs-entry/tree-group) ; group, as a string
  ;; boolean, for when <fs-entry> for /a/b is defined,
  ;; but not <fs-entry> for / and /a are defined, in which case
  ;; a ‘filler?’ <fs-entry/tree> for / and /a are created
  ;; in fs-entries->tree, which have as child /a and /a/b
  ;; respectively.
  ;;
  ;; (Note: the security context for / is currently ignored)
  (filler?  fs-entry/tree-filler?
            (default #f))
  ;; list of known children
  (children fs-entry-children))

(define %directory-separator #\/)
(define (fs-entry-name-components x)
  (string-split (fs-entry-where x) %directory-separator))

(define (fs-entries->tree list)
  "Translate @var{list}, a list of @code{fs-entry}, into a tree
structure (of <fs-entry/tree>)."
  ;; Sort list to prepare for a depth-first construction
  (define (list<? component<? x y)
    (cond ((and (null? x) (null? y)) #f)
	  ((null? x) #t)
	  ((null? y) #f)
	  ((component<? (car x) (car y)) #t)
	  ((component<? (car y) (car x)) #f)
	  (else (list<? component<? (cdr x) (cdr y)))))
  (define (entry<? x y)
    (list<? string<?
            (fs-entry-name-components x)
            (fs-entry-name-components y)))
  (define sorted (sort list entry<?))
  ;; Now construct the tree.
  ;; XXX insert filler for ???
  XXX
  ;; XXX make sure there are no inconsistencies
  ;; XXX prevent some screw-ups such as chowning or chmodding
  ;; entries from /gnu/store/.... Maybe that's prevented
  ;; by bind-mounting anyway.
  ;; (e.g. a symlink and directory with the same name).
  )

(define (tree->alist tree)
  `((name . ,(fs-entry/tree-name tree))
    (bits . ,(fs-entry/tree-bits tree))
    (type . ,(fs-entry/tree-type tree))
    (owner . ,(fs-entry/tree-owner tree))
    (group . ,(fs-entry/tree-group tree))
    (filler? . ,(fs-entry/tree-filler? tree))))

(define* (fs-entry-activation tree)
  ;; XXX for efficiency reasons, it might be useful to implement
  ;; some sort of caching mechanism to avoid looking up a uid/gid
  ;; multiple times from user name / user gid.
  #~(let* ((root (open "/" O_RDONLY))
           (ref  (lambda (sexp-tree obj))))
      (use-modules (srfi srfi-26))
      ;; XXX dynamic-wind stuff to close directories
      ;; and leaves.
      ;; XXX bindings to openat, or use chdir
      (define (activate-children! parent-fd parent-tree)
        (for-each (cute activate-child! parent-fd <>)
                  (assq-ref parent-tree 'children)))
      (define (activate-child! parent-fd child-tree)
        (let* ((name (assq-ref child-tree 'name))
               (child
                ;; XXX define
                (false-if-not-found
                 (openat parent-fd (fs-entry/tree-name child-tree)))))
          (if child ;; already exists
              (maybe-fixup-child! child child-tree)
              (create-child! parent-fd name child-tree))))
      (define (maybe-fixup-child! child child-tree)
        ;; First check if any changes need to be made.
        ;; If not, don't perform any write I/O.
        ;; XXX what happens if child is a symbolic link?
        ;; XXX handle (assq-ref child 'filler?)
        (let* ((stat (stat child))
               (child:bits (assq-ref child-tree 'bits))
               (child:uid (xxx (assq-ref child-tree 'uid)))
               (child:gid (xxx (assq-ref child-tree 'gid)))
               (bits-ok? (= (stat:perms child) child:bits))
               (owner-ok? (= (stat:uid child) child:uid))
               (group-ok? (= (stat:gid child) child:gid))
               (type-ok? (eq? (stat:type child)
                              (assq-ref child-tree 'type))))
          ;; XXX if programs hold open files to some files,
          ;; which aren't permitted by the new configuration,
          ;; then these programs ???
          ;; XXX log stuff perhaps
          (cond ((not type-ok?) (xxx-what-now))
                ;; Easy, no risk of accidentally creating
                ;; a setuid/setgid binary.
                ((and group-ok? owner-ok? (not bits-ok?))
                 (chmod child child:bits)
                 (activate-children! child child-tree))
                ;; XXX this relies on the Linux behaviour
                ;; of clearing setuid and setgid at chown
                ;; (in some cases), check the behaviour
                ;; on the Hurd and Linux
                ((not (and group-ok? owner-ok?))
                 ;; XXX check behaviour on symbolic links
                 (chown child child:uid child:gid)
                 (chmod child child:bits)
                 (activate-children! child child-tree))
                ;; Everything is OK!  Descend down the tree.
                ((and bits-ok? owner-ok? group-ok? type-ok?)
                 (activate-children! child child-tree))
                (else (XXX-I-missed-a-case)))))
      (define (create-child! parent-fd name child-tree)
        (case (assq-ref child-tree 'type)
          ((regular)
           ;; XXX default contents? Maybe allow including
           ;; a gexp #~(lambda (file-fd) do-stuff)
           ;; in the <fs-entry>?
           xxx-???-regular)
          ((directory)
           ;; XXX handle filler?
           ;; XXX check security implications of sticky-bit
           (mkdirat parent-fd name (assq-ref child-tree 'bits))
           (chown xxx-the-just-created-dir (assq-ref child-tree 'owner))
           (activate-chilren! xxx-the-just-created-dir child-tree))
          ;; XXX target?  Also, does any service actually require
          ;; this?
          ((symlink) xxx-???-symlink)
          (else ???)))
      (call-with-saved-umask
       (lambda ()
         ;; Prevent a race windows were newly-created directories
         ;; are temporarily world-executable where inappropriate.
         (umask #o777)
         (activate-children! root tree)))))

(define fs-entry-service-type
  (service-type (name 'fs-entries)
                (extensions
                 (list (service-extension activation-service-type
                                          fs-entry-activation)))
                (compose concatenate)
                (extend append)
                (description
                 "Create directory structures, with permission
bits, owner and groups (together called the security context),
without race conditions.  The value of this service is a list
of @code{fs-entry}.  The old security context is overwritten
at activation time, and some inconsistencies are detected at
build time.

If some parent directories of a @code{fs-entry} are not
explicitely specfied, it is required (at activation time)
they are root-owned (both user and group) and
world-unwritable.")))