zilch/core/src/file.sld

(define-library (zilch file)
  (import
    (scheme base) (scheme case-lambda)
    (zilch magic) (zilch nix binproto) (zilch nix daemon) (zilch nix drv) (zilch zexpr)
    (chicken base) (chicken format)
    (srfi 128) (srfi 132) (srfi 146) (srfi 151))
  (export zfile zsymlink zdir 
          zfile->store)

  (begin
    (define-record-type <z-file>
      (make-z-file contents executable cache)
      z-file?
      (contents z-file-contents)
      (executable z-file-executable)
      (cache z-file-cache z-file-set-cache))

    (define-record-printer (<z-file> file out)
      (if (z-file-executable file)
        (fprintf out "#<z-file (executable)>")
        (fprintf out "#<z-file>")))

    (define-record-type <z-directory>
      (make-z-directory contents cache)
      z-directory?
      (contents z-directory-contents)
      (cache z-directory-cache z-directory-set-cache))

    (define-record-printer (<z-directory> dir out)
      (fprintf out "#<z-directory")
      (for-each (lambda (kv) (fprintf out " ~S -> ~S" (car kv) (cdr kv))) (z-directory-contents dir))
      (fprintf out ">"))

    (define-record-type <z-symlink>
      (make-z-symlink target cache)
      z-symlink?
      (target z-symlink-target)
      (cache z-symlink-cache z-symlink-set-cache))

    (define-record-printer (<z-symlink> symlink out)
      (fprintf out "#<z-symlink -> ~S>" (z-symlink-target symlink)))

    (define (env-pair<? l r) (string<? (car l) (car r)))

    ;; `(zfile CONTENTS [EXECUTABLE])`
    ;;
    ;; Create a `<z-file>` object with given contents and optional `executable` flag.
    ;; The contents may either be a string or a `<zexp>`.
    (define zfile
      (case-lambda
        ((contents) (make-z-file contents #f #f))
        ((contents executable) (make-z-file contents executable #f))))

    ;; Create a `<z-symlink>` record. The target may be any string, *or* a `<zexp>` containing one.
    (define (zsymlink target) (make-z-symlink target #f))

    ;; `(zdir CONTENTS)`
    ;;
    ;; Create a `<z-directory>` record. The contents is an alist of file name -> zfile/zsymlink/zdir.
    ;; For simplicity, one can also write e.g. `(zdir "key" value "key2" value)`.
    (define zdir
      (case-lambda
        ((contents) (make-z-directory (list-sort env-pair<? contents) #f))
        (rest (do
                ((out '()))
                ((eq? rest '()) (make-z-directory (list-sort env-pair<? out) #f))
                (set! out (cons (cons (car rest) (cadr rest)) out))
                (set! rest (cddr rest))))))
   
    ; Here is where the weirdness starts.
    ; To make it possible to build store paths that depend on non-fixed-output dependencies,
    ; with as little system-specific dependencies as possible, this is implemented in a bit of a weird way.
    ; To do this, it uses the builtin:unpack-channel builder. This builder unpacks a tarball or zip file
    ; (or other formats, in some older versions of CppNix and Lix) and moves the one top-level file to a known name.
    ; To do this, we implement a tiny ustar serializer.

    ; First, build the baseline header used for every item in the tarball. This has precalculated checksums, so is cheap to modify and rechecksum.
    (define baseline-ustar-header (make-bytevector 512 0))
    ; TODO(puck): should we default to 0 instead?
    (do ((i 100 (+ i 1))) ((= i 157) #f) (bytevector-u8-set! baseline-ustar-header i 32))
    (for-each (lambda (i) (bytevector-u8-set! baseline-ustar-header i 0)) '(108 116 136 329 337))
    ; TODO(puck): are these needed still?
    (for-each (lambda (i) (bytevector-u8-set! baseline-ustar-header i (char->integer #\a))) '(0 157))
    (bytevector-copy! baseline-ustar-header 257 (string->utf8 "ustar\x00;00"))
    ; We subtract 32*21 here to exclude the mode, size, and typeflag fields from the baseline checksum.
    (define baseline-ustar-header-checksum
      (do ((i 0 (+ i 1)) (csum 0 csum))
          ((= i 512) (- csum (* 32 21)))
          (set! csum (+ csum (bytevector-u8-ref baseline-ustar-header i)))))

    ;; Write a tar header with specified mode, content length, and type byte.
    ;; For simplicity, all paths and link paths must be defined in PAX attributes.
    (define (make-ustar-header mode size type)
        (define output (bytevector-copy baseline-ustar-header))
        (define octal-mode (number->string mode 8))
        (bytevector-copy! output 100 (string->utf8 octal-mode))
        (define octal-size (number->string size 8))
        (bytevector-copy! output 124 (string->utf8 octal-size))
        (bytevector-u8-set! output 156 (char->integer type))
   
        (define csum (+ baseline-ustar-header-checksum (char->integer type)))
        (do ((i 100 (+ i 1))) ((= i 108) #f) (set! csum (+ csum (bytevector-u8-ref output i))))
        (do ((i 124 (+ i 1))) ((= i 136) #f) (set! csum (+ csum (bytevector-u8-ref output i))))
        (define octal-csum (number->string csum 8))
        (bytevector-copy! output 148 (string->utf8 octal-csum))

        output)
   
    ;; PAX extended attributes contain the length of the entire line, including the length bytes.
    ;; Calculate the length of " {key}={value}\n" and the length of that length in decimal.
    ;; If adding the length of the length would make the length overflow, add one more byte; then
    ;; return the full serialized key-value pair as a string.
    (define make-pax-extended-header
      (case-lambda
       ((key value) (make-pax-extended-header key value (string-length value)))
       ((key value value-length)
        (define kv-length (+ (string-length key) value-length 3))
        (define length-length (string-length (number->string kv-length)))
        (unless (eqv? length-length (string-length (number->string (+ length-length kv-length)))) (set! length-length (+ 1 length-length)))
        (string-append (number->string (+ length-length kv-length)) " " key "=" value "\n"))))

    (define padding-block (make-bytevector 512 0))
    (define (write-padding len)
        (define rem (bitwise-and len 511))
        (unless (= rem 0)
          (write-bytevector padding-block (current-output-port) 0 (- 512 rem))))
   
    (define (unwrap-zexp-to-placeholder zexp)
      (define contents-zexp (zexp-unwrap zexp))
      (define contents (zexp-evaluation-value contents-zexp))
      (zexp-context-register-items (zexp-evaluation-drvs contents-zexp) (zexp-evaluation-srcs contents-zexp))
      (when (string? contents)
        (set! contents (string->utf8 contents)))
      (define placeholder-mapping (mapping (make-default-comparator)))
      (define has-mapping #f)
      (for-each
       (lambda (drv)
        (for-each
         (lambda (output)
           (define output-obj (cdr (assoc output (derivation-outputs (car drv)))))
           (when (derivation-output-placeholder? output-obj)
             (set! placeholder-mapping (mapping-set! placeholder-mapping (derivation-output-path output-obj) (derivation-output-path-length (car drv) output)))
             (set! has-mapping #t)))
         (cdr drv)))
       (zexp-evaluation-drvs contents-zexp))
      (define contents-length (bytevector-length contents))
      (define sliced (make-bytevector 53))
      (when has-mapping
       (do ((i 0 (+ 1 i)) (ref #f #f))
           ((> i (- (bytevector-length contents) 53)) #f)
           (when (= (bytevector-u8-ref contents i) #x2F)
            (bytevector-copy! sliced 0 contents i (+ i 53))
            (set! ref (mapping-ref/default placeholder-mapping (utf8->string sliced) #f))
            (when ref (set! contents-length (+ (- contents-length 53) ref))))))
      (values contents contents-length))

    (define (write-pax-directory path)
        (define header (string->utf8 (make-pax-extended-header "path" path)))
        (write-bytevector (make-ustar-header 0 (bytevector-length header) #\x))
        (write-bytevector header)
        (write-padding (bytevector-length header))
        (write-bytevector (make-ustar-header #o777 0 #\5)))

    (define (write-pax-file path executable contents-zexp)
        (define-values (contents contents-length) (unwrap-zexp-to-placeholder contents-zexp))
        (define header (string->utf8 (make-pax-extended-header "path" path)))
        (write-bytevector (make-ustar-header 0 (bytevector-length header) #\x))
        (write-bytevector header)
        (write-padding (bytevector-length header))
        (write-bytevector (make-ustar-header (if executable #o555 #o444) contents-length #\0))
        (if (bytevector? contents) (write-bytevector contents) (write-string contents))
        (write-padding contents-length))

    (define (write-pax-symlink path linkpath-zexp)
        (define-values (linkpath linkpath-length) (unwrap-zexp-to-placeholder linkpath-zexp))
        (define header (string->utf8 (string-append (make-pax-extended-header "path" path) (make-pax-extended-header "linkpath" (utf8->string linkpath) linkpath-length))))
        (define total-len (+ (bytevector-length header) (- linkpath-length (bytevector-length linkpath))))
        (write-bytevector (make-ustar-header 0 total-len #\x))
        (write-bytevector header)
        (write-padding total-len)
        (write-bytevector (make-ustar-header #o777 0 #\2)))
   
    ;; Serialize the specified structure as a ustar-style (with pax extensions) tape archive to the standard output port. The filename is specified by `name`.
    (define (serialize-as-tar f name)
      (cond
        ((z-file? f) (write-pax-file name (z-file-executable f) (z-file-contents f)))
        ((z-directory? f)
         (write-pax-directory name)
         (map (lambda (entry) (serialize-as-tar (cdr entry) (string-append name "/" (car entry)))) (z-directory-contents f)))
        ((z-symlink? f) (write-pax-symlink name (z-symlink-target f)))))
   
    ;; Serialize a file-like (`zfile`, `zsymlink`, `zdir`) to a `<store-path>`.
    ;; This function should not depend on the system of the builder.
    ;; TODO(puck): due to limitations, whatever you pass in ends up at `<store-path>/-` instead.
    (define (zfile->store val)
     (define cached
       (cond
         ((z-file? val) (z-file-cache val))
         ((z-directory? val) (z-directory-cache val))
         ((z-symlink? val) (z-symlink-cache val))))
     (unless cached
      (set! cached
       (let*
        ((bvport (open-output-bytevector))
         (serialized (zexp-with-context (lambda () (parameterize ((current-output-port bvport)) (serialize-as-tar val "-")))))
         (bv (get-output-bytevector bvport))
         (intermediate #f)
         (drv #f))
        (close-port bvport)
        ;(set! intermediate
        ;  (zexp-with-injected-context
        ;     (zexp
        ;        (zexp-unquote (store-path-for-text "file" bv)))
        ;     (cadr serialized)
        ;     (car (cddr serialized))))
        (set! drv
          (store-path-for-ca-drv* "zilchfile" "builtin"
            (zexp ("builtin:unpack-channel"))
            (zexp (("src" . ".attr-1s42g1c76fxb77skzq0b4wdhcrg8jmzb54czmxvh1qm7psgsbcni")
                   ("contents" . (zexp-unquote (call-with-port (open-output-bytevector) (lambda (port) (parameterize ((current-output-port port)) (serialize-as-tar val "-")) (get-output-bytevector port)))))
                   ("passAsFile" . "contents")
                   ("channelName" . "-")))
            '("out")))
        (cdar drv))))
     (cond
       ((z-file? val) (z-file-set-cache val cached))
       ((z-directory? val) (z-directory-set-cache val cached))
       ((z-symlink? val) (z-symlink-set-cache val cached)))
     cached)

   
    (zexp-add-unquote-handler
      (lambda (val)
        (if (or (z-file? val) (z-symlink? val) (z-directory? val))
            (string-append (zexp-unquote (zfile->store val)) "/-")
            #f)))))