Paste number 143844: hash rewriting

Paste number 143844: hash rewriting
Pasted by: civodul
When:7 years, 2 months ago
Share:Tweet this! | http://paste.lisp.org/+32ZO
Channel:None
Paste contents:
Raw Source | XML | Display As
(define-module (guix build relocate)
  #:use-module (guix build utils)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:export (replace-store-references
            rewrite-directory))

(define* (replace-store-references input output mapping
                                   #:optional (store (%store-directory)))
  (define pattern
    (let ((nix-base32-chars
           '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
             #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
             #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
      `(,@(map char-set (string->list store))
        ,(char-set #\/)
        ,@(make-list 32 (list->char-set nix-base32-chars))
        ,(char-set #\-))))

  (with-fluids ((%default-port-encoding #f))
    ;; We cannot use `regexp-exec' here because it cannot deal with
    ;; strings containing NUL characters.
    (setvbuf input _IOFBF 65536)
    (setvbuf output _IOFBF 65536)
    (let* ((len     (+ 34 (string-length store)))
           (mapping (map (match-lambda
                          ((origin . replacement)
                           (cons (string-take origin len)
                                 (string-take replacement len))))
                         mapping)))
     (fold-port-matches (lambda (string result)
                          (match (assoc-ref mapping string)
                            (#f
                             (put-bytevector output (string->utf8 string)))
                            ((= string->utf8 replacement)
                             (put-bytevector output replacement)))
                          #t)
                        #f
                        pattern
                        input
                        (lambda (char result)     ;unmatched
                          (put-u8 output (char->integer char))
                          result)))))

(define* (rewrite-directory directory output mapping
                            #:optional (store (%store-directory)))
  "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
file name pairs."
  (define prefix-len
    (string-length directory))

  (define (destination file)
    (string-append output (string-drop file prefix-len)))

  (define (rewrite-leaf file stat result)
    (case (stat:type stat)
      ((symlink)
       (let ((target (readlink file)))
         (symlink (or (assoc-ref mapping target) target)
                  (destination file))))
      ((regular)
       (with-fluids ((%default-port-encoding #f))
         (call-with-input-file file
           (lambda (input)
             (call-with-output-file (destination file)
               (lambda (output)
                 (replace-store-references input output mapping
                                           store)
                 (chmod output (stat:perms stat))))))))
      (else
       (error "unsupported file type" stat))))

  (file-system-fold (const #t)
                    rewrite-leaf
                    (lambda (directory stat result) ;down
                      (mkdir (destination directory)))
                    (const #t)                      ;up
                    (const #f)                      ;skip
                    (lambda (file stat errno result) ;error
                      (error "read error" file stat errno))
                    #f
                    directory
                    lstat))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(use-modules (guix gexp)
             (guix monads)
             (guix packages)
             (guix profiles)
             (guix download)
             (gnu packages guile)
             (gnu packages libunistring))

(define patched-libunistring
  (package (inherit libunistring)
    (source (origin (inherit (package-source libunistring))
              (snippet '(display "This is a fake patch."))))))

(gexp->derivation (package-full-name guile-2.0)
                  #~(begin
                      (use-modules (guix build relocate))

                      (rewrite-directory #$guile-2.0 #$output
                                         (list (cons #$libunistring
                                                      #$patched-libunistring)
                                               (cons #$guile-2.0 #$output))))
                  #:modules '((guix build utils)
                              (guix build relocate)))

This paste has no annotations.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.