guix-pkgs/nongnu/services/fhs.scm

(define-module (nongnu services fhs)
  #:use-module (ice-9 ftw) ;; for creating recursive list of directories of libs for FHS  #:use-module (guix download)
  #:use-module (srfi srfi-1) ;; For filter-map
  #:use-module (guix records) ;; For defining record types
  #:use-module (guix profiles) ;; for  manifest-entries
  #:use-module (gnu services) ;; For defining services
  #:use-module (guix gexp) ;; For computed-file and other things
  #:use-module (guix packages) ;; For package
  #:use-module (gnu packages) ;; For specifications->manifest
  #:use-module (gnu packages base) ;; For glibc

  #:export (fhs-binaries-compatibility-service-type
            fhs-binaries-compatibility-service
            fhs-configuration))

(define (32bit-package pkg)
  (package (inherit pkg)
           (name (string-append (package-name pkg) "-i686-linux"))
	   (arguments
	    `(#:system "i686-linux"
	      ,@(package-arguments pkg)))))

(define glibc-for-fhs
  (package (inherit glibc)
           (name "glibc-for-fhs") ;; Maybe rename this to "glibc-with-ldconfig-for-fhs"
           (source (origin
                    (inherit (package-source glibc))
                    (snippet #f))))) ;; Re-enable ldconfig


(define (packages->ld.so.conf packages)
  (computed-file
   "ld.so.conf"
   (with-imported-modules
    `((guix build union)
      (guix build utils))
    #~(begin
        (use-modules (guix build union)
                     (guix build utils))
        (let* ((packages '#$packages) ;; Need to quote "#$packages" as #$packages tries to "apply" the first item to the rest, like a procedure.
               (find-lib-directories-in-single-package
                (lambda (package)
                  (find-files (string-append package "/lib")
                              (lambda (file stat)
                                ;; setting keyword "stat" to "stat" means it will follow
                                ;; symlinks, unlike what it's set to by default ("lstat").
                                (eq? 'directory (stat:type stat)))
                              #:stat stat
                              #:directories? #t)))
               (find-lib-directories-in-all-packages
                (lambda (packages)
                  (apply append ;; Concatenate the directory lists from "map" into one list
                         (map (lambda (package)
                                (find-lib-directories-in-single-package package))
                              packages))))
               (fhs-lib-dirs
                (find-lib-directories-in-all-packages packages)))
          (with-output-to-file
              #$output
            (lambda _
              (format #t
                      (string-join fhs-lib-dirs "\n"))
              #$output)))))))

(define (ld.so.conf->ld.so.cache ld-conf)
  (computed-file "ld.so.cache"
                 (with-imported-modules `((guix build utils))
                                        #~(begin
                                            (use-modules (guix build utils))
                                            (let* ((ldconfig (string-append #$glibc-for-fhs "/sbin/ldconfig")))
                                              (invoke ldconfig
                                                      "-X" ;; Don't update symbolic links
                                                      "-f" #$ld-conf ;; Use #$configuration as configuration file
                                                      "-C" #$output)))))) ;; Use #$output as cache file

(define (packages->ld.so.cache packages)
  (ld.so.conf->ld.so.cache (packages->ld.so.conf packages)))

(define-record-type* <fhs-configuration>
  fhs-configuration
  make-fhs-configuration
  fhs-configuration?
  (lib-packages                   fhs-configuration-lib-packages
                                  (default '()))
  (additional-profile-packages    fhs-configuration-additional-profile-packages ;; For putting programs in $PATH and for share data
                                  (default '()))
  (additional-special-files       fhs-configuration-additional-special-files
                                  (default '())))

(define* (union name packages #:key options)
  (computed-file name
                 (with-imported-modules `((guix build union))
                                        #~(begin
                                            (use-modules (guix build union))
                                            (union-build #$output '#$packages)))
                 #:options options))

(define* (fhs-libs-union packages #:key system)
  (let* ((name (if system
                   (string-append "fhs-libs-" system)
                   "fhs-libs")))
    (union name
           packages
           #:options `(#:system ,system))))

(define (fhs-special-files-service config)
  "Return the list of special files for the fhs service"
  (let* ((fhs-lib-packages (fhs-configuration-lib-packages config))
         (fhs-lib-package-unions (append fhs-lib-packages
                                         `(,(fhs-libs-union fhs-lib-packages #:system "i686-linux"))))
         (fhs-glibc-special-files
          `(("/etc/ld.so.cache" ,(packages->ld.so.cache fhs-lib-package-unions))
            ("/etc/ld.so.conf" ,(packages->ld.so.conf fhs-lib-package-unions)) ;;Not needed to function, but put it here anyway for debugging purposes
            ("/lib64/ld-linux-x86-64.so.2" ,(file-append (canonical-package glibc-for-fhs) "/lib/ld-linux-x86-64.so.2"))
            ("/lib/ld-linux.so.2" ,(file-append (canonical-package (32bit-package glibc-for-fhs)) "/lib/ld-linux.so.2"))))
         ;;             ("/fhs/libs" ,(file-append (canonical-package fhs-libs-64) "/lib"))
         (fhs-additional-special-files (fhs-configuration-additional-special-files config)))
    (append fhs-glibc-special-files
            fhs-additional-special-files)))

(define (fhs-profile-service config)
  "Return the list of packages to add to the system profile"
  ;; Get list of packages from config to add to system profile and return them
  (fhs-configuration-additional-profile-packages config))


(define fhs-binaries-compatibility-service-type
  (service-type (name 'fhs-compatibility-service)
                (extensions
                 (list (service-extension special-files-service-type
                                          fhs-special-files-service)
                       (service-extension profile-service-type
                                          fhs-profile-service)
                       ))
                (description
                 "Support binaries compiled for the filesystem hierarchy standard.")
                (default-value (fhs-configuration))))

(define fhs-binaries-compatibility-service
  (service fhs-binaries-compatibility-service-type))