;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 build install)
  #:use-module ((guix build union) #:select (relative-file-name))
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (guix build store-copy)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (install-boot-config
            evaluate-populate-directive
            make-symlink->directives
            populate-root-file-system
            install-database-and-gc-roots
            populate-single-profile-directory
            mount-cow-store
            unmount-cow-store))

;;; Commentary:
;;;
;;; This module supports the installation of the GNU system on a hard disk.
;;; It is meant to be used both in a build environment (in derivations that
;;; build VM images), and on the bare metal (when really installing the
;;; system.)
;;;
;;; Code:

(define (install-boot-config bootcfg bootcfg-location mount-point)
  "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
that the caller must make sure that BOOTCFG is registered as a GC root so
that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  (let* ((target (string-append mount-point bootcfg-location))
         (pivot  (string-append target ".new")))
    (mkdir-p (dirname target))

    ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
    ;; work when /boot is on a separate partition.  Do that atomically.
    (copy-file bootcfg pivot)
    (rename-file pivot target)))

(define* (evaluate-populate-directive directive target
                                      #:key
                                      (default-gid 0)
                                      (default-uid 0)
                                      (error-on-dangling-symlink? #t))
  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller.  If the directive matches those defaults then,
'chown' won't be run.  When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
error when a dangling symlink would be created."
  (define target* (if (string-suffix? "/" target)
                      target
                      (string-append target "/")))
  (let loop ((directive directive))
    (catch 'system-error
      (lambda ()
        (match directive
          (('directory name)
           (mkdir-p (string-append target* name)))
          (('directory name uid gid)
           (let ((dir (string-append target* name)))
             (mkdir-p dir)
             ;; If called from a context without "root" permissions, "chown"
             ;; to root will fail.  In that case, do not try to run "chown"
             ;; and assume that the file will be chowned elsewhere (when
             ;; interned in the store for instance).
             (or (and (= uid default-uid) (= gid default-gid))
                 (chown dir uid gid))))
          (('directory name uid gid mode)
           (loop `(directory ,name ,uid ,gid))
           (chmod (string-append target* name) mode))
          (('file name)
           (call-with-output-file (string-append target* name)
             (const #t)))
          (('file name (? string? content))
           (call-with-output-file (string-append target* name)
             (lambda (port)
               (display content port))))
          ((new '-> old)
           (let ((new* (string-append target* new)))
             (let try ()
               (catch 'system-error
                 (lambda ()
                   (when error-on-dangling-symlink?
                     ;; When the symbolic link points to a relative path,
                     ;; checking if its target exists must be done relatively
                     ;; to the link location.
                     (unless (if (string-prefix? "/" old)
                                 (file-exists? old)
                                 (with-directory-excursion (dirname new*)
                                   (file-exists? old)))
                       (error (format #f "symlink `~a' points to nonexistent \
file `~a'" new* old))))
                   (symlink old new*))
                 (lambda args
                   ;; When doing 'guix system init' on the current '/', some
                   ;; symlinks may already exists.  Override them.
                   (if (= EEXIST (system-error-errno args))
                       (begin
                         (delete-file new*)
                         (try))
                       (apply throw args)))))))))
      (lambda args
        ;; Usually we can only get here when installing to an existing root,
        ;; as with 'guix system init foo.scm /'.
        (format (current-error-port)
                "error: failed to evaluate directive: ~s~%"
                directive)
        (apply throw args)))))

(define (make-symlink->directives directory)
  "Return a procedure that turn symlinks specs into directives that target
DIRECTORY."
  (match-lambda
    ((source '-> target)
     (let ((target (string-append directory "/" target))
           (parent (dirname source)))
       ;; Never add a 'directory' directive for "/" so as to preserve its
       ;; ownership and avoid adding the same entries multiple times.
       `(,@(if (string=? parent "/")
               '()
               `((directory ,parent)))
         ;; Note: a relative file name is used for compatibility with
         ;; relocatable packs.
         (,source -> ,(relative-file-name parent target)))))))

(define (directives store)
  "Return a list of directives to populate the root file system that will host
STORE."
  `((directory ,store 0 0 #o1775)

    (directory "/etc")
    (directory "/var/log")                          ; for shepherd
    (directory "/var/guix/gcroots")
    (directory "/var/empty")                        ; for no-login accounts
    (directory "/var/db")                           ; for dhclient, etc.
    (directory "/var/run")
    (directory "/run")
    (directory "/mnt")
    (directory "/var/guix/profiles/per-user/root" 0 0)

    ;; Link to the initial system generation.
    ("/var/guix/profiles/system" -> "system-1-link")

    ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
    ("/var/guix/gcroots/current-system" -> "/run/current-system")
    ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")

    (directory "/bin")
    (directory "/tmp" 0 0 #o1777)                 ; sticky bit
    (directory "/var/tmp" 0 0 #o1777)
    (directory "/var/lock" 0 0 #o1777)

    (directory "/home" 0 0)))

(define* (populate-root-file-system system target
                                    #:key (extras '()))
  "Make the essential non-store files and directories on TARGET.  This
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate
TARGET."
  ;; It's expected that some symbolic link targets do not exist yet, so do not
  ;; error on dangling links.
  (for-each (cut evaluate-populate-directive <> target
                 #:error-on-dangling-symlink? #f)
            (append (directives (%store-directory)) extras))

  ;; Add system generation 1.
  (let ((generation-1 (string-append target
                                     "/var/guix/profiles/system-1-link")))
    (let try ()
      (catch 'system-error
        (lambda ()
          (symlink system generation-1))
        (lambda args
          ;; If GENERATION-1 already exists, overwrite it.
          (if (= EEXIST (system-error-errno args))
              (begin
                (delete-file generation-1)
                (try))
              (apply throw args)))))))

(define %root-profile
  "/var/guix/profiles/per-user/root")

(define* (install-database-and-gc-roots root database profile
                                        #:key (profile-name "guix-profile"))
  "Install DATABASE, the store database, under directory ROOT.  Create
PROFILE-NAME and have it link to PROFILE, a store item."
  (define (scope file)
    (string-append root "/" file))

  (define (mkdir-p* dir)
    (mkdir-p (scope dir)))

  (define (symlink* old new)
    (symlink old (scope new)))

  (install-file database (scope "/var/guix/db/"))
  (chmod (scope "/var/guix/db/db.sqlite") #o644)
  (mkdir-p* "/var/guix/profiles")
  (mkdir-p* "/var/guix/gcroots")
  (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")

  ;; Make root's profile, which makes it a GC root.
  (mkdir-p* %root-profile)
  (symlink* profile
            (string-append %root-profile "/" profile-name "-1-link"))
  (symlink* (string-append profile-name "-1-link")
            (string-append %root-profile "/" profile-name)))

(define* (populate-single-profile-directory directory
                                            #:key profile closure
                                            (profile-name "guix-profile")
                                            database)
  "Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE.

When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
DIRECTORY/var/guix/gcroots and friends.

PROFILE-NAME is the name of the profile being created under
/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".

This is used to create the self-contained tarballs with 'guix pack'."
  (define (scope file)
    (string-append directory "/" file))

  (define (mkdir-p* dir)
    (mkdir-p (scope dir)))

  (define (symlink* old new)
    (symlink old (scope new)))

  ;; Populate the store.
  (populate-store (list closure) directory
                  #:deduplicate? #f)

  (when database
    (install-database-and-gc-roots directory database profile
                                   #:profile-name profile-name))

  (match profile-name
    ("guix-profile"
     (mkdir-p* "/root")
     (symlink* (string-append %root-profile "/guix-profile")
               "/root/.guix-profile"))
    ("current-guix"
     (mkdir-p* "/root/.config/guix")
     (symlink* (string-append %root-profile "/current-guix")
               "/root/.config/guix/current"))
    (_
     #t)))

(define (mount-cow-store target backing-directory)
  "Make the store copy-on-write, using TARGET as the backing store.  This is
useful when TARGET is on a hard disk, whereas the current store is on a RAM
disk."
  (define (set-store-permissions directory)
    "Set the right perms on DIRECTORY to use it as the store."
    (chown directory 0 30000)      ;use the fixed 'guixbuild' GID
    (chmod directory #o1775))

  (let ((tmpdir (string-append target "/tmp")))
    (mkdir-p tmpdir)
    (mount tmpdir "/tmp" "none" MS_BIND))

  (let* ((rw-dir (string-append target backing-directory))
         (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
    (mkdir-p rw-dir)
    (mkdir-p work-dir)
    (mkdir-p "/.rw-store")
    (set-store-permissions rw-dir)
    (set-store-permissions "/.rw-store")

    ;; Mount the overlay, then atomically make it the store.
    (mount "none" "/.rw-store" "overlay" 0
           (string-append "lowerdir=" (%store-directory) ","
                          "upperdir=" rw-dir ","
                          "workdir=" work-dir))
    (mount "/.rw-store" (%store-directory) "" MS_MOVE)
    (rmdir "/.rw-store")))

(define (unmount-cow-store target backing-directory)
  "Unmount copy-on-write store."
  (let ((tmp-dir "/remove"))
    (mkdir-p tmp-dir)
    (mount (%store-directory) tmp-dir "" MS_MOVE)
    (umount tmp-dir)
    (rmdir tmp-dir)
    (delete-file-recursively
     (string-append target backing-directory))))

;;; install.scm ends here