;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.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 file-systems)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (guix build utils)
  #:use-module (guix build bournish)
  #:use-module ((guix build syscalls)
                #:hide (file-system-type))
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 string-fun)
  #:use-module (system foreign)
  #:autoload   (system repl repl) (start-repl)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (disk-partitions
            partition-label-predicate
            partition-uuid-predicate
            partition-luks-uuid-predicate
            find-partition-by-label
            find-partition-by-uuid
            find-partition-by-luks-uuid
            canonicalize-device-spec

            read-partition-label
            read-partition-uuid
            read-luks-partition-uuid

            cleanly-unmounted-ext2?

            bind-mount

            system*/tty
            mount-flags->bit-mask
            check-file-system
            mount-file-system

            swap-space->flags-bit-mask))

;;; Commentary:
;;;
;;; This modules provides tools to deal with disk partitions, and to mount and
;;; check file systems.
;;;
;;; Code:

(define (system*/console program . args)
  "Run PROGRAM with ARGS in a tty on top of /dev/console.  The return value is
as for 'system*'."
  (match (primitive-fork)
    (0
     (dynamic-wind
       (const #t)
       (lambda ()
         (login-tty (open-fdes "/dev/console" O_RDWR))
         (apply execlp program program args))
       (lambda ()
         (primitive-_exit 127))))
    (pid
     (cdr (waitpid pid)))))

(define (system*/tty program . args)
  "Run PROGRAM with ARGS, creating a tty if its standard input isn't one.
The return value is as for 'system*'.

This is necessary for commands such as 'cryptsetup open' or 'fsck' that may
need to interact with the user but might be invoked from shepherd, where
standard input is /dev/null."
  (apply (if (isatty? (current-input-port))
             system*
             system*/console)
         program args))

(define (call-with-input-file file proc)
  "Like 'call-with-input-file', but pass O_CLOEXEC."
  (let ((port #f))
    (dynamic-wind
      (lambda ()
        (set! port (open file (logior O_RDONLY O_CLOEXEC))))
      (lambda ()
        (proc port))
      (lambda ()
        (close-port port)
        (set! port #f)))))

(define (bind-mount source target)
  "Bind-mount SOURCE at TARGET."
  (mount source target "" MS_BIND))

(define (seek* fd/port offset whence)
  "Like 'seek' but return -1 instead of throwing to 'system-error' upon
EINVAL.  This makes it easier to catch cases like OFFSET being too large for
FD/PORT."
  (catch 'system-error
    (lambda ()
      (seek fd/port offset whence))
    (lambda args
      (if (= EINVAL (system-error-errno args))
          -1
          (apply throw args)))))

(define (read-superblock device offset size magic?)
  "Read a superblock of SIZE from OFFSET and DEVICE.  Return the raw
superblock on success, and #f if no valid superblock was found.  MAGIC?
takes a bytevector and returns #t when it's a valid superblock."
  (call-with-input-file device
    (lambda (port)
      (and (= offset (seek* port offset SEEK_SET))
           (let ((block (make-bytevector size)))
             (match (get-bytevector-n! port block 0 (bytevector-length block))
               ((? eof-object?)
                #f)
               ((? number? len)
                (and (= len (bytevector-length block))
                     (and (magic? block)
                          block)))))))))

(define null-terminated-latin1->string
  (cut latin1->string <> zero?))

(define (bytevector-utf16-length bv)
  "Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
determine where the NUL terminator is and return its index.  If there's no
NUL terminator, return the size of the bytevector."
  (let ((length (bytevector-length bv)))
    (let loop ((index 0))
      (if (< index length)
          (if (zero? (bytevector-u16-ref bv index 'little))
              index
              (loop (+ index 2)))
          length))))

(define* (bytevector->u16-list bv endianness #:optional (index 0))
  (if (< index (bytevector-length bv))
      (cons (bytevector-u16-ref bv index endianness)
            (bytevector->u16-list bv endianness (+ index 2)))
      '()))

;; The initrd doesn't have iconv data, so do the conversion ourselves.
(define (utf16->string bv endianness)
  (list->string
   (map integer->char
        (reverse
         (let loop ((remainder (bytevector->u16-list bv endianness))
                    (result '()))
             (match remainder
              (() result)
              ((a) (cons a result))
              ((a b x ...)
               (if (and (>= a #xD800) (< a #xDC00) ; high surrogate
                        (>= b #xDC00) (< b #xE000)) ; low surrogate
                   (loop x (cons (+ #x10000
                                    (* #x400 (- a #xD800))
                                    (- b #xDC00))
                                 result))
                   (loop (cons b x) (cons a result))))))))))

(define (null-terminated-utf16->string bv endianness)
  (utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
                 endianness))


;;;
;;; Ext2 file systems.
;;;

;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.

(define-syntax %ext2-endianness
  ;; Endianness of ext2 file systems.
  (identifier-syntax (endianness little)))