diff --git a/pandoc.egg b/pandoc.egg index d35fad4..340fab4 100644 --- a/pandoc.egg +++ b/pandoc.egg @@ -11,14 +11,18 @@ (dependencies cjson http-client medea scsh-process) (test-dependencies) (distribution-files - "pandoc.server.chicken.scm" - "pandoc.chicken.scm" - "pandoc.egg" "pandoc.r5rs.scm" + "pandoc.chicken.scm" + "pandoc.server.chicken.scm" + "pandoc.tar.chicken.scm" + "pandoc.egg" "pandoc.release-info") (components (extension pandoc (source "pandoc.chicken.scm")) (extension pandoc.server (source "pandoc.server.chicken.scm") + (component-dependencies pandoc)) + (extension pandoc.tar + (source "pandoc.tar.chicken.scm") (component-dependencies pandoc)))) diff --git a/pandoc.tar.chicken.scm b/pandoc.tar.chicken.scm new file mode 100644 index 0000000..dbb42af --- /dev/null +++ b/pandoc.tar.chicken.scm @@ -0,0 +1,173 @@ +(module (pandoc tar) + + (pandoc-tar-command + pandoc-tar-strings->json + pandoc-tar-strings->sxml + pandoc-tar-files->json + pandoc-tar-files->sxml) + + (import (scheme) + (chicken base) + (cjson) + (srfi 4) + (scheme base) + (only (chicken io) read-byte read-string write-byte write-string) + (only (chicken port) + copy-port with-input-from-string with-output-to-string) + (only (chicken process) process process-wait) + (only (scsh-process) run/port run/string) + (only (pandoc) pandoc-json->sxml)) + + ;; (define (eof-object) #!eof) + ;; (define (string->utf8 str) str) + ;; (define (utf8->string str) str) + ;; (define bytevector string) + ;; (define (bytevector-append bvs) + ;; (let ((target (make-u8vector + ;; (define bytevector-length u8vector-length) + ;; (define (bytevector-u8-ref s i) (char->integer (string-ref s i))) + ;; (define make-bytevector make-u8vector) + ;; (define read-bytevector read-string) + ;; (define truncate-remainder remainder) + ;; (define write-bytevector write-string) + + (define (generator->list generator) ; SRFI 158 + (let loop ((list '())) + (let ((elem (generator))) + (if (eof-object? elem) (reverse list) (loop (cons elem list)))))) + + (define pandoc-tar-command + (make-parameter "pandoc-tar")) + + (define (bytevector-every? predicate bytes) + (let loop ((i 0)) + (or (= i (bytevector-length bytes)) + (and (predicate (bytevector-u8-ref bytes i)) + (loop (+ i 1)))))) + + (define (tar-read-file) + + (define (read-exactly-n-bytes n) + (let ((bytes (read-bytevector n))) + (if (or (eof-object? bytes) (< (bytevector-length bytes) n)) + (error "Short read") + bytes))) + + (let ((header (read-bytevector 512))) + + (define (tar-octal-ref offset len) + (let loop ((offset offset) (len len) (value 0)) + (if (<= len 0) value + (let ((dig0 (char->integer #\0)) + (dig7 (char->integer #\7)) + (byte (bytevector-u8-ref header offset))) + (loop (+ offset 1) (- len 1) + (if (<= dig0 byte dig7) + (let ((digit (- byte dig0))) + (+ digit (* value 8))) + value)))))) + + (cond ((eof-object? header) + (eof-object)) + ((bytevector-every? zero? header) + (eof-object)) + (else + (unless (= 512 (bytevector-length header)) + (error "Short read")) + (let* ((nbyte (tar-octal-ref 124 12)) + (nnull (- 512 (truncate-remainder nbyte 512))) + (bytes (read-exactly-n-bytes nbyte))) + (read-exactly-n-bytes nnull) + bytes))))) + + (define (tar-write-file filename bytes) + + (define nulls (make-bytevector 512 0)) + (define blank-checksum (make-bytevector 7 (char->integer #\space))) + + (define (bytevector-sum bv) + (let loop ((i (- (bytevector-length bv) 1)) (sum 0)) + (if (< i 0) sum (loop (- i 1) (+ sum (bytevector-u8-ref bv i)))))) + + (define (tar-string nbyte string) + (let* ((bytes (string->utf8 string)) + (nnull (- nbyte (bytevector-length bytes)))) + (when (< nnull 1) (error "tar: string too long")) + (bytevector-append bytes (make-bytevector nnull 0)))) + + (define (tar-octal nbyte number) + (let* ((bytes (string->utf8 (number->string number 8))) + (nzero (- nbyte 1 (bytevector-length bytes)))) + (bytevector-append (make-bytevector nzero (char->integer #\0)) + bytes (bytevector 0)))) + + (let* ((nbyte (bytevector-length bytes)) + (nnull (- 512 (truncate-remainder nbyte 512))) + (header-before-checksum + (bytevector-append + (tar-string 100 filename) + (tar-octal 8 #o444) + (tar-octal 8 0) + (tar-octal 8 0) + (tar-octal 12 nbyte) + (tar-octal 12 0))) + (header-after-checksum + (bytevector-append + (bytevector (char->integer #\space)) + (bytevector (char->integer #\0)) + (tar-string 100 "") + (tar-string 8 "ustar ") + (tar-string 32 "") + (tar-string 32 "") + (make-bytevector 183 0))) + (checksum + (let ((sum (+ (bytevector-sum header-before-checksum) + (bytevector-sum blank-checksum) + (bytevector-sum header-after-checksum)))) + (tar-octal 7 (truncate-remainder sum (expt 8 6)))))) + (write-bytevector header-before-checksum) + (write-bytevector checksum) + (write-bytevector header-after-checksum) + (write-bytevector bytes) + (write-bytevector nulls (current-output-port) 0 nnull))) + + (define (write-all-to-tar inputs) + (let loop ((i 0) (inputs inputs)) + (unless (null? inputs) + (let ((filename (string-append (number->string i) ".md"))) + (tar-write-file filename (car inputs)) + (loop (+ i 1) (cdr inputs)))))) + + (define (pandoc-tar-bytevectors->json input-format input-bytevectors) + (let* ((pandoc-tar + (string->symbol (pandoc-tar-command))) + (stdin + (with-output-to-string + (lambda () + (write-all-to-tar input-bytevectors)))) + (stdout + (run/string (,pandoc-tar --from ,input-format --to json) + (<< ,stdin)))) + (map (lambda (bytes) + (cjson-schemify (string->cjson (utf8->string bytes)))) + (with-input-from-string stdout + (lambda () (generator->list tar-read-file)))))) + + (define (pandoc-tar-strings->json input-format input-strings) + (pandoc-tar-bytevectors->json + input-format + (map string->utf8 input-strings))) + + (define (pandoc-tar-files->json input-format input-filenames) + (pandoc-tar-strings->json + input-format + (map (lambda (filename) (with-input-from-file filename read-string)) + input-filenames))) + + (define (pandoc-tar-strings->sxml input-format input-strings) + (map pandoc-json->sxml + (pandoc-tar-strings->json input-format input-strings))) + + (define (pandoc-tar-files->sxml input-format input-filenames) + (map pandoc-json->sxml + (pandoc-tar-files->json input-format input-filenames))))