fruix-bootstrap/modules/fruix/system/freebsd/utils.scm

(define-module (fruix system freebsd utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 hash-table)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-13)
  #:use-module (rnrs io ports)
  #:export (getenv*
            trim-trailing-newlines
            command-output
            safe-command-output
            write-file
            sha256-string
            store-hash-string
            make-store-path
            file-hash
            directory-entries
            path-signature
            tree-content-signature
            install-plan-signature
            native-build-source-tree-sha256
            copy-regular-file
            copy-node
            materialize-plan-entry
            delete-path-if-exists
            stage-tree-into-output
            string-replace-all
            rewrite-text-file
            delete-file-if-exists
            copy-tree-contents
            path-basename
            read-lines
            run-command
            store-reference-closure
            copy-store-items-into-rootfs
            copy-rootfs-for-image
            mktemp-directory))

(define (getenv* name default)
  (or (getenv name) default))

(define (trim-trailing-newlines str)
  (let loop ((len (string-length str)))
    (if (and (> len 0)
             (char=? (string-ref str (- len 1)) #\newline))
        (loop (- len 1))
        (substring str 0 len))))

(define (command-output program . args)
  (let* ((port   (apply open-pipe* OPEN_READ program args))
         (output (get-string-all port))
         (status (close-pipe port)))
    (unless (zero? status)
      (error (format #f "command failed: ~a ~s => ~a" program args status)))
    (trim-trailing-newlines output)))

(define (safe-command-output program . args)
  (false-if-exception (apply command-output program args)))

(define (write-file path content)
  (mkdir-p (dirname path))
  (call-with-output-file path
    (lambda (port)
      (display content port))))

(define (sha256-string text)
  (let ((tmp (command-output "mktemp"
                             (string-append (getenv* "TMPDIR" "/tmp")
                                            "/fruix-system-hash.XXXXXX"))))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (write-file tmp text)
        (command-output "sha256" "-q" tmp))
      (lambda ()
        (delete-file-if-exists tmp)))))

(define store-hash-visible-length 40)
(define store-hash-scheme-version "1")

(define (store-identity-field value)
  (cond ((symbol? value)
         (symbol->string value))
        ((string? value)
         value)
        (else
         (object->string value))))

(define* (store-hash-string payload #:key (kind 'item) name (output "out"))
  (let* ((identity `((scheme . "fruix-store-path")
                     (version . ,store-hash-scheme-version)
                     (kind . ,(store-identity-field kind))
                     (name . ,(store-identity-field (or name "")))
                     (output . ,(store-identity-field output))
                     (payload . ,payload)))
         (digest (sha256-string (object->string identity))))
    (string-take digest store-hash-visible-length)))

(define* (make-store-path store-dir display-name payload
                          #:key
                          (kind 'item)
                          name
                          (output "out"))
  (string-append store-dir "/"
                 (store-hash-string payload
                                    #:kind kind
                                    #:name (or name display-name)
                                    #:output output)
                 "-"
                 display-name))

(define (file-hash path)
  (command-output "sha256" "-q" path))


(define (directory-entries path)
  (sort (filter (lambda (entry)
                  (not (member entry '("." ".."))))
                (scandir path))
        string<?))

(define (path-signature path)
  (let ((st (lstat path)))
    (case (stat:type st)
      ((regular)
       (string-append "file:" path ":" (file-hash path)))
      ((symlink)
       (string-append "symlink:" path ":" (readlink path)))
      ((directory)
       (string-join
        (cons (string-append "directory:" path)
              (apply append
                     (map (lambda (entry)
                            (list (path-signature (string-append path "/" entry))))
                          (directory-entries path))))
        "\n"))
      (else
       (string-append "other:" path ":" (symbol->string (stat:type st)))))))

(define (tree-content-signature root)
  (define (walk path relative)
    (let ((st (lstat path)))
      (case (stat:type st)
        ((regular)
         (string-append "file:" relative ":" (file-hash path)))
        ((symlink)
         (string-append "symlink:" relative ":" (readlink path)))
        ((directory)
         (string-join
          (cons (string-append "directory:" relative)
                (apply append
                       (map (lambda (entry)
                              (let ((child-relative (if (string=? relative ".")
                                                        entry
                                                        (string-append relative "/" entry))))
                                (list (walk (string-append path "/" entry)
                                            child-relative))))
                            (directory-entries path))))
          "\n"))
        (else
         (string-append "other:" relative ":" (symbol->string (stat:type st)))))))
  (walk root "."))

(define (install-plan-signature entry)
  (match entry
    (('file source target)
     (string-append "file-target:" target "\n" (path-signature source)))
    (('directory source target)
     (string-append "directory-target:" target "\n" (path-signature source)))
    (_
     (error (format #f "unsupported install plan entry: ~s" entry)))))

(define (native-build-source-tree-sha256 source-root)
  (let* ((mtree-output (command-output "mtree" "-c" "-k" "type,link,size,mode,sha256digest" "-p" source-root))
         (stable-lines (filter (lambda (line)
                                 (not (string-prefix? "#" line)))
                               (string-split mtree-output #\newline))))
    (sha256-string (string-join stable-lines "\n"))))

(define (copy-regular-file source destination)
  (let ((mode (stat:perms (stat source))))
    (copy-file source destination)
    (chmod destination mode)))

(define (copy-node source destination)
  (let ((kind (stat:type (lstat source))))
    (mkdir-p (dirname destination))
    (case kind
      ((directory)
       (mkdir-p destination)
       (for-each (lambda (entry)
                   (copy-node (string-append source "/" entry)
                              (string-append destination "/" entry)))
                 (directory-entries source)))
      ((symlink)
       (symlink (readlink source) destination))
      (else
       (copy-regular-file source destination)))))

(define (materialize-plan-entry output-path entry)
  (match entry
    (('file source target)
     (copy-node source (string-append output-path "/" target)))
    (('directory source target)
     (copy-node source (string-append output-path "/" target)))
    (_
     (error (format #f "unsupported install plan entry: ~s" entry)))))

(define (clear-file-flags path)
  (false-if-exception (system* "chflags" "-R" "noschg,nouchg" path)))

(define (delete-path-if-exists path)
  (when (or (file-exists? path) (false-if-exception (readlink path)))
    (clear-file-flags path)
    (let ((kind (stat:type (lstat path))))
      (case kind
        ((directory) (delete-file-recursively path))
        (else (delete-file path))))))

(define (stage-tree-into-output stage-root output-path)
  (mkdir-p output-path)
  (for-each (lambda (entry)
              (copy-node (string-append stage-root "/" entry)
                         (string-append output-path "/" entry)))
            (directory-entries stage-root)))


(define (string-replace-all str old new)
  (let ((old-len (string-length old)))
    (let loop ((start 0) (chunks '()))
      (let ((index (string-contains str old start)))
        (if index
            (loop (+ index old-len)
                  (cons new
                        (cons (substring str start index) chunks)))
            (apply string-append
                   (reverse (cons (substring str start) chunks))))))))

(define (rewrite-text-file path replacements)
  (when (file-exists? path)
    (let* ((mode (stat:perms (stat path)))
           (original (call-with-input-file path get-string-all))
           (updated (fold (lambda (replacement text)
                            (string-replace-all text (car replacement) (cdr replacement)))
                          original
                          replacements)))
      (unless (string=? original updated)
        (write-file path updated)
        (chmod path mode)))))

(define (delete-file-if-exists path)
  (when (file-exists? path)
    (delete-file path)))


(define (copy-tree-contents source-root target-root)
  (mkdir-p target-root)
  (for-each (lambda (entry)
              (copy-node (string-append source-root "/" entry)
                         (string-append target-root "/" entry)))
            (directory-entries source-root)))


(define (path-basename path)
  (let ((parts (filter (lambda (part) (not (string-null? part)))
                       (string-split path #\/))))
    (if (null? parts)
        path
        (last parts))))

(define (read-lines path)
  (if (file-exists? path)
      (filter (lambda (line) (not (string-null? line)))
              (string-split (call-with-input-file path get-string-all) #\newline))
      '()))

(define (run-command . args)
  (let ((status (apply system* args)))
    (unless (zero? status)
      (error "command failed" args status))
    #t))

(define (store-reference-closure roots)
  (let ((seen (make-hash-table))
        (result '()))
    (define (visit item)
      (unless (hash-ref seen item #f)
        (hash-set! seen item #t)
        (set! result (cons item result))
        (for-each visit (read-lines (string-append item "/.references")))))
    (for-each visit roots)
    (reverse result)))

(define (copy-store-items-into-rootfs rootfs store-dir items)
  (let ((store-root (string-append rootfs store-dir)))
    (mkdir-p store-root)
    (for-each (lambda (item)
                (copy-node item (string-append store-root "/" (path-basename item))))
              items)))

(define (copy-rootfs-for-image source-rootfs image-rootfs)
  (when (file-exists? image-rootfs)
    (delete-file-recursively image-rootfs))
  (copy-node source-rootfs image-rootfs))

(define (mktemp-directory pattern)
  (command-output "mktemp" "-d" pattern))