;;; SPDX-License-Identifier: CC0-1.0
;;;
;;; Copyright © 2023, 2024 Wojtek Kosior <koszko@koszko.org>
;;; Additions and modifications by Wojtek Kosior are additionally
;;; dual-licensed under the Creative Commons Zero v1.0.

(define-module (gnu services overlayfs)
  #:use-module ((srfi srfi-1) #:select (concatenate))
  #:use-module ((guix records) #:select
                (define-record-type* match-record-lambda))
  #:use-module ((guix gexp) #:select (gexp))
  #:use-module ((gnu services) #:select
                (service-extension activation-service-type service-type))
  #:export (overlayfs-service-type
            overlayfs-mount-configuration
            overlayfs-mount-configuration?
            overlayfs-mount-configuration-lower
            overlayfs-mount-configuration-upper
            overlayfs-mount-configuration-work))

(define-record-type* <overlayfs-mount-configuration>
  overlayfs-mount-configuration
  make-overlayfs-mount-configuration overlayfs-mount-configuration?
  (upper  overlayfs-mount-configuration-upper)
  (lower  overlayfs-mount-configuration-lower)
  (work   overlayfs-mount-configuration-work)
  (target overlayfs-mount-configuration-target))

(define (overlayfs-activation configs)
  #~(begin
      (use-modules ((srfi srfi-1) #:select (filter-map))
                   ((srfi srfi-26) #:select (cut))
                   ((ice-9 textual-ports) #:select (get-string-all))
                   ((ice-9 regex) #:select (string-match match:substring))
                   ((ice-9 format) #:select (format)))

      (let* ((overlay-configs
              '#$(map (match-record-lambda <overlayfs-mount-configuration>
                          (upper lower work target)
                        (list upper lower work target))
                      configs))

             (current-mounts
              (filter-map (compose (cut and=> <> (cut match:substring <> 1))
                                   (cut string-match "^\\S+ (\\S+)" <>))
                          (string-split (call-with-input-file "/proc/mounts"
                                          get-string-all)
                                        #\newline)))

             (mount-overlay
              (lambda (upper lower work target)
                (unless (member target current-mounts)
                  (system* "mount" "dummy" target "-t" "overlay"
                           "-o" (format #f "~{~a=~a~^,~}"
                                        (list "lowerdir" lower
                                              "upperdir" upper
                                              "workdir"  work)))))))

        (for-each (lambda (config-values)
                    (for-each mkdir-p config-values)
                    (apply mount-overlay config-values))
                  overlay-configs))))

(define overlayfs-service-type
  (service-type
   (name 'overlayfs)
   (extensions
    (list (service-extension activation-service-type overlayfs-activation)))
   (compose concatenate)
   (extend append)
   (default-value '())
   (description "Automatically mount overlay filesystems.")))