From b84c205f0396091f3d75ada3c322ec73d581e655 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 9 Mar 2014 23:43:04 +0900 Subject: [PATCH] Adding tar library. --- lib/chibi/tar.scm | 199 ++++++++++++++++++++++++++++++++++++++++++++ lib/chibi/tar.sld | 21 +++++ tests/tar-tests.scm | 62 ++++++++++++++ 3 files changed, 282 insertions(+) create mode 100644 lib/chibi/tar.scm create mode 100644 lib/chibi/tar.sld create mode 100644 tests/tar-tests.scm diff --git a/lib/chibi/tar.scm b/lib/chibi/tar.scm new file mode 100644 index 00000000..188ef5d2 --- /dev/null +++ b/lib/chibi/tar.scm @@ -0,0 +1,199 @@ + +(define-binary-record-type tar + (make (make-tar)) + (write write-tar-raw) + (block + (path (padded-string 100) (getter tar-path-raw) (setter tar-path-raw-set!)) + (mode (octal 8)) + (uid (octal 8)) + (gid (octal 8)) + (size (octal 12)) + (time (octal 12)) + (checksum (octal 8)) + (type (fixed-string 1)) + (link-name (padded-string 100)) + (ustar (padded-string 6)) + (ustar-version (padded-string 2)) + (owner (padded-string 32)) + (group (padded-string 32)) + (device-major (octal 8)) + (device-minor (octal 8)) + (path-prefix (padded-string 155)) + #u8(0 0 0 0 0 0 0 0 0 0 0 0))) + +(define (tar-compute-checksum tar) + (let ((tmp (open-output-bytevector))) + (write-tar-raw tar tmp) + (let ((bv (get-output-bytevector tmp))) + (do ((i 0 (+ i 1))) ((= i 8)) + (bytevector-u8-set! bv (+ i 148) 32)) + (do ((i 0 (+ i 1)) + (sum 0 (+ sum (bytevector-u8-ref bv i)))) + ((= i 512) sum))))) + +;; wrap the writer to automatically compute the checksum +(define (write-tar tar out) + (tar-checksum-set! tar (tar-compute-checksum tar)) + (write-tar-raw tar out)) + +;; wrap the path to use the prefix +(define (tar-path tar) + (string-append (tar-path-prefix tar) (tar-path-raw tar))) + +(define (tar-path-set! tar path) + (let ((len (string-length path))) + (cond ((< len 100) + (tar-path-raw-set! tar path)) + ((< len 255) + (tar-path-raw-set! tar (substring path (- len 100))) + (tar-path-prefix-set! tar (substring path 0 (- len 100)))) + (else (error "path name too long"))))) + +;; utilities + +(define (read-modulo-bytevector in len mod) + (let ((res (read-bytevector len in)) + (rem (modulo len mod))) + (if (positive? rem) + (read-bytevector (- mod rem) in)) + res)) + +(define (write-modulo-file out file mod) + (let ((in (open-binary-input-file file))) + (let lp () + (let ((bv (read-bytevector mod in))) + (cond + ((eof-object? bv)) + (else + (write-bytevector bv out) + (let ((len (bytevector-length bv))) + (if (< len mod) + (write-bytevector (make-bytevector (- mod len) 0) out) + (lp))))))))) + +;; fundamental iterator +(define (tar-fold src kons knil) + (let ((in (if (string? src) (open-binary-input-file src) src))) + (let lp ((acc knil)) + (cond + ((eof-object? (peek-char in)) + (close-input-port in) + acc) + (else + (let* ((tar (read-tar in)) + (bv (read-modulo-bytevector in (tar-size tar) 512))) + (lp (kons tar bv acc)))))))) + +;; not a tar-bomb and no absolute paths +(define (tar-safe? tarball) + (define (path-top path) + (substring path 0 (string-find path #\/))) + (let ((files (map path-normalize (tar-files tarball)))) + (and (every path-relative? files) + (or (< (length files) 2) + (let ((dir (path-top (car files)))) + (every (lambda (f) (equal? dir (path-top f))) (cdr files))))))) + +(define (tar-for-each tarball proc) + (tar-fold tarball (lambda (tar bv acc) (proc tar bv)) #f)) + +;; list the files in the archive +(define (tar-files tarball) + (reverse (tar-fold tarball (lambda (tar bv acc) (cons (tar-path tar) acc)) '()))) + +;; extract to the current filesystem +(define (tar-extract tarball . o) + (define (safe-path path) + (string-trim-left + (path-strip-leading-parents (path-normalize path)) + #\/)) + (let ((rename (if (pair? o) (car o) safe-path))) + (tar-for-each + tarball + (lambda (tar bv) + (let ((path (rename (tar-path tar)))) + (case (string-ref (tar-type tar) 0) + ((#\0 #\null) + (let ((out (open-output-file-descriptor + (open path + (bitwise-ior open/write + open/create + open/non-block) + (tar-mode tar))))) + (write-bytevector bv out) + (close-output-port out))) + ((#\1) (link-file (rename (tar-link-name tar)) path)) + ((#\2) (symbolic-link-file (rename (tar-link-name tar)) path)) + ((#\5) (create-directory path (tar-mode tar))) + ((#\g #\x)) ;; meta data + ((#\3 #\4 #\6) (error "devices not supported" (tar-type tar))) + (else (error "invalid tar type" (tar-type tar))))))))) + +(define (tar-extract-file tarball file) + (call-with-current-continuation + (lambda (return) + (tar-for-each + tarball + (lambda (tar bv) (if (equal? (tar-path tar) file) (return bv)))) + #f))) + +(define (file->tar file) + (let ((tar (make-tar)) + (st (file-link-status file))) + (tar-path-set! tar file) + (tar-ustar-set! tar "ustar") + (tar-ustar-version-set! tar "00") + (tar-mode-set! tar (file-mode st)) + (tar-uid-set! tar (file-owner st)) + (tar-gid-set! tar (file-group st)) + (tar-owner-set! tar (user-name (user-information (file-owner st)))) + (tar-group-set! tar (group-name (group-information (file-group st)))) + (tar-time-set! tar (+ 1262271600 (file-modification-time st))) + (tar-type-set! tar (cond ((file-link? st) "2") + ((file-character? st) "3") + ((file-block? st) "4") + ((file-directory? st) "5") + (else "0"))) + (if (equal? "0" (tar-type tar)) + (tar-size-set! tar (file-size st))) + (if (file-link? st) + (tar-link-name-set! tar (read-link file))) + tar)) + +;; create an archive for a given file list +(define (tar-create tarball files . o) + (let ((rename (if (pair? o) (car o) (lambda (f) #t)))) + (let ((out (open-binary-output-file tarball))) + (for-each + (lambda (file) + (directory-fold-tree + file + (lambda (dir acc) (write-tar (file->tar dir) out)) + #f + (lambda (path acc) + (let ((f (rename path))) + (if f + (let ((tar (file->tar path))) + (if (string? f) + (tar-path-set! tar f)) + (write-tar tar out) + (if (equal? "0" (tar-type tar)) + (write-modulo-file out path 512)))))))) + files) + (close-output-port out)))) + +(define (main args) + (let ((args (cdr args))) + (cond + ((equal? "t" (car args)) + (for-each (lambda (f) (write-string f) (newline)) (tar-files (cadr args)))) + ((equal? "x" (car args)) + (if (tar-safe? (cadr args)) + (tar-extract (cadr args)) + (error "tar file not a single relative directory" (cadr args)))) + ((equal? "c" (car args)) + (tar-create (cadr args) (cddr args))) + ((equal? "f" (car args)) + (display (utf8->string (tar-extract-file (cadr args) (car (cddr args)))))) + (else + (error "unknown tar command" (car args)))))) diff --git a/lib/chibi/tar.sld b/lib/chibi/tar.sld new file mode 100644 index 00000000..f1a2ca95 --- /dev/null +++ b/lib/chibi/tar.sld @@ -0,0 +1,21 @@ + +(define-library (chibi tar) + (import (scheme base) (scheme file) (srfi 1) (srfi 33) (scheme write) + (chibi string) (chibi binary-record) + (chibi pathname) (chibi filesystem) (chibi system)) + (export + ;; basic + tar make-tar tar? read-tar write-tar + ;; utilities + tar-safe? tar-files tar-fold tar-extract tar-extract-file tar-create + ;; accessors + tar-path tar-mode tar-uid tar-gid + tar-owner tar-group tar-size + tar-time tar-type tar-link-name + tar-path-set! tar-mode-set! tar-uid-set! tar-gid-set! + tar-owner-set! tar-group-set! tar-size-set! + tar-time-set! tar-type-set! tar-link-name-set! + tar-device-major tar-device-major-set! + tar-device-minor tar-device-minor-set! + tar-ustar tar-ustar-set!) + (include "tar.scm")) diff --git a/tests/tar-tests.scm b/tests/tar-tests.scm new file mode 100644 index 00000000..c1675d3c --- /dev/null +++ b/tests/tar-tests.scm @@ -0,0 +1,62 @@ + +(import (scheme base) (scheme write) (chibi tar) (chibi test)) + +(test-begin "tar") + +;; Utility to flatten bytevectors, strings and individual bytes +;; (integers) into a single bytevector for generating readable test +;; data. ( . ) can be used to repeat a byte. +(define (bv . args) + (apply bytevector-append + (map (lambda (x) + (cond ((string? x) (string->utf8 x)) + ((pair? x) (make-bytevector (cdr x) (car x))) + ((integer? x) (bytevector x)) + (else x))) + args))) + +(let ((b (bv "foo" '(0 . 97) + "000644 " 0 + "000765 " 0 + "000765 " 0 + "00000000016 " + "12302104616 " + "011512" 0 " " + "0" + '(0 . 100) + "ustar" 0 "00" + "bob" '(0 . 29) + "bob" '(0 . 29) + "000000 " 0 + "000000 " 0 + '(0 . 155) + '(0 . 12) + ))) + (let ((x (read-tar (open-input-bytevector b)))) + (test "foo" (tar-path x)) + (test 501 (tar-uid x)) + (test "bob" (tar-owner x))) + (let ((x (make-tar))) + (tar-path-set! x "bar") + (tar-mode-set! x #o644) + (tar-uid-set! x 501) + (tar-gid-set! x 502) + (tar-size-set! x 123) + (tar-time-set! x 456) + (tar-ustar-set! x "ustar") + (tar-owner-set! x "john") + (tar-group-set! x "john") + (test "bar" (tar-path x)) + (test-error (tar-mode-set! x "r")) + (let ((out (open-output-bytevector))) + (write-tar x out) + (let ((bv2 (get-output-bytevector out))) + (test-assert (bytevector? bv2)) + (let ((x2 (read-tar (open-input-bytevector bv2)))) + (test-assert "bar" (tar-path x2)) + (test-assert #o644 (tar-mode x2)) + (test-assert 501 (tar-uid x2)) + (test-assert 502 (tar-gid x2)) + (test-assert "john" (tar-owner x2))))))) + +(test-end)