481 lines
17 KiB
Scheme
481 lines
17 KiB
Scheme
(define (filter p list)
|
|
(let loop ((newlist '()) (list list))
|
|
(if (null? list) (reverse newlist)
|
|
(loop (if (p (car list)) (cons (car list) newlist) newlist)
|
|
(cdr list)))))
|
|
|
|
(define (find p list)
|
|
(cond ((null? list) #f)
|
|
((p (car list)) (car list))
|
|
(else (find p (cdr list)))))
|
|
|
|
(define (butlast list)
|
|
(if (null? list) (error "butlast: empty list")
|
|
(let loop ((newlist '()) (list list))
|
|
(if (null? (cdr list)) (reverse newlist)
|
|
(loop (cons (car list) newlist) (cdr list))))))
|
|
|
|
(define (bytevector-concatenate bytevectors)
|
|
(fold (lambda (part whole) (bytevector-append whole part))
|
|
(bytevector) bytevectors))
|
|
|
|
(define (string-index str char)
|
|
(let loop ((i 0))
|
|
(cond ((= i (string-length str)) #f)
|
|
((char=? char (string-ref str i)) i)
|
|
(else (loop (+ i 1))))))
|
|
|
|
(define (string-every? p str)
|
|
(let loop ((i 0))
|
|
(or (= i (string-length str))
|
|
(and (p (string-ref str i))
|
|
(loop (+ i 1))))))
|
|
|
|
(define (string-prefix? fix str)
|
|
(let ((fixlen (string-length fix))
|
|
(strlen (string-length str)))
|
|
(cond ((< fixlen strlen) (string=? fix (string-copy str 0 fixlen)))
|
|
((= fixlen strlen) (string=? fix str))
|
|
(else #f))))
|
|
|
|
(define (string-drop str n)
|
|
(string-copy str n (string-length str)))
|
|
|
|
(define (string-pad str n char)
|
|
(let ((lack (- n (string-length str))))
|
|
(if (<= lack 0) str (string-append str (make-string lack char)))))
|
|
|
|
(define (u8 u)
|
|
(bytevector u))
|
|
|
|
(define (u16l u)
|
|
(bytevector (bitwise-and #xff u)
|
|
(bitwise-and #xff (arithmetic-shift u -8))))
|
|
|
|
(define (u32l u)
|
|
(bytevector (bitwise-and #xff u)
|
|
(bitwise-and #xff (arithmetic-shift u -8))
|
|
(bitwise-and #xff (arithmetic-shift u -16))
|
|
(bitwise-and #xff (arithmetic-shift u -24))))
|
|
|
|
;;
|
|
|
|
(define bytes/sector 512) ; Do not change.
|
|
(define sectors/cluster 8)
|
|
|
|
(define physical-sectors/track 0)
|
|
(define heads 0)
|
|
|
|
(define (bytes->clusters bytes)
|
|
(ceiling (/ bytes (* bytes/sector sectors/cluster))))
|
|
|
|
(define-record-type fat-directory
|
|
(make-fat-directory* name entries)
|
|
fat-directory?
|
|
(name fat-directory-name)
|
|
(entries fat-directory-entries fat-directory-set-entries!)
|
|
(first-cluster fat-directory-first-cluster
|
|
fat-directory-set-first-cluster!))
|
|
|
|
(define-record-type fat-file
|
|
(make-fat-file name contents)
|
|
fat-file?
|
|
(name fat-file-name)
|
|
(contents fat-file-contents)
|
|
(first-cluster fat-file-first-cluster fat-file-set-first-cluster!))
|
|
|
|
(define-record-type drive
|
|
(make-drive* number root-directory)
|
|
drive?
|
|
(number drive-number)
|
|
(first-sector drive-first-sector)
|
|
(sector-count drive-sector-count drive-set-sector-count!)
|
|
(max-space drive-max-space)
|
|
(free-space drive-free-space)
|
|
(root-directory drive-root-directory))
|
|
|
|
(define first-drive-letter #\c)
|
|
(define last-drive-letter #\f)
|
|
|
|
(define max-drives
|
|
(+ 1 (- (char->integer last-drive-letter)
|
|
(char->integer first-drive-letter))))
|
|
|
|
(define drives (make-vector max-drives #f))
|
|
|
|
(define (get-used-drives)
|
|
(filter drive? (vector->list drives)))
|
|
|
|
(define (drive-letter drive)
|
|
(string (integer->char (+ (char->integer first-drive-letter)
|
|
(drive-number drive)))))
|
|
|
|
(define (drive-by-letter letter)
|
|
(let ((number (- (char->integer letter) first-drive-letter)))
|
|
(if (and (>= number 0) (< number (vector-length drives)))
|
|
(vector-ref drives number)
|
|
(error "No such drive"))))
|
|
|
|
(define (parse-drive-number drive-letter-string)
|
|
(define (bad) (error "Bad drive letter" drive-letter-string))
|
|
(unless (= 1 (string-length drive-letter-string)) (bad))
|
|
(let ((char (string-ref drive-letter-string 0)))
|
|
(unless (char<=? #\a char #\z) (bad))
|
|
(let ((number (- (char->integer char) (char->integer #\a))))
|
|
(if (< number max-drives) number
|
|
(error "Too many drives" drive-letter-string)))))
|
|
|
|
(define (get-drive drive-letter-string)
|
|
(let ((number (parse-drive-number drive-letter-string)))
|
|
(vector-ref drives number)))
|
|
|
|
(define (get-or-create-drive drive-letter-string)
|
|
(let ((number (parse-drive-number drive-letter-string)))
|
|
(or (vector-ref drives number)
|
|
(let ((drive (make-drive number)))
|
|
(vector-set! drives number drive)
|
|
drive))))
|
|
|
|
(define (make-fat-directory name)
|
|
(make-fat-directory* name '()))
|
|
|
|
(define (make-drive number)
|
|
(make-drive* number (make-fat-directory* #f '())))
|
|
|
|
(define (fat-directory-entry-name entry)
|
|
(cond ((fat-directory? entry) (fat-directory-name entry))
|
|
((fat-file? entry) (fat-file-name entry))
|
|
(else (error "What?" entry))))
|
|
|
|
(define (fat-directory-entry-first-cluster entry)
|
|
(cond ((fat-directory? entry) (fat-directory-first-cluster entry))
|
|
((fat-file? entry) (fat-file-first-cluster entry))
|
|
(else (error "What?" entry))))
|
|
|
|
(define fat-directory-entry-size 32)
|
|
|
|
(define fat-directory-entries/cluster
|
|
(ceiling (/ fat-directory-entry-size
|
|
(* bytes/sector sectors/cluster))))
|
|
|
|
(define root-directory-entries 512)
|
|
|
|
(define (fat-directory-entry-cluster-count entry)
|
|
(bytes->clusters
|
|
(cond ((fat-directory? entry) fat-directory-entry-size)
|
|
((fat-file? entry) (fat-file-size entry))
|
|
(else (error "What?" entry)))))
|
|
|
|
(define (fat-directory-insert-entry! directory entry)
|
|
(let ((name (fat-directory-entry-name entry))
|
|
(head (cons #f (fat-directory-entries directory))))
|
|
(let loop ((tail head))
|
|
(if (or (null? (cdr tail))
|
|
(string-ci<? name (fat-directory-entry-name (cadr tail))))
|
|
(set-cdr! tail (cons entry (cdr tail)))
|
|
(loop (cdr tail))))
|
|
(fat-directory-set-entries! directory (cdr head))))
|
|
|
|
(define (create-directory directory path)
|
|
(if (null? path) directory
|
|
(let* ((name (car path))
|
|
(path (cdr path))
|
|
(subdir (make-fat-directory name)))
|
|
(fat-directory-insert-entry! directory subdir)
|
|
(create-directory subdir path))))
|
|
|
|
(define (drive-get-or-create-directory drive path)
|
|
(let loop ((directory (drive-root-directory drive)) (path path))
|
|
(if (null? path) directory
|
|
(let* ((name (car path))
|
|
(entry (find (lambda (entry)
|
|
(equal? name (fat-directory-entry-name entry)))
|
|
(fat-directory-entries directory))))
|
|
(cond ((not entry)
|
|
(create-directory directory path))
|
|
((fat-directory? entry)
|
|
(loop entry (cdr path)))
|
|
(else
|
|
(error "Can't decide if entry is file or directory")))))))
|
|
|
|
(define (fat-file-size file)
|
|
(bytevector-length (fat-file-contents file)))
|
|
|
|
(define (tar-read-entry)
|
|
|
|
(define (bytevector-every? match? bytes)
|
|
(let loop ((i 0))
|
|
(or (= i (bytevector-length bytes))
|
|
(and (match? (bytevector-u8-ref bytes i))
|
|
(loop (+ i 1))))))
|
|
|
|
(define (read-exactly-n-bytes n)
|
|
(let ((bytes (read-bytevector n)))
|
|
(let ((bytes (if (eof-object? bytes) (bytevector) bytes)))
|
|
(if (< (bytevector-length bytes) n)
|
|
(error "Short read")
|
|
bytes))))
|
|
|
|
(let ((header (read-bytevector 512)))
|
|
|
|
(define (tar-string-copy offset len)
|
|
(utf8->string
|
|
(bytevector-copy
|
|
header offset
|
|
(let loop ((end (+ offset len)))
|
|
(let ((i (- end 1)))
|
|
(if (< i offset) (error "tar string")
|
|
(if (zero? (bytevector-u8-ref header i))
|
|
(loop i)
|
|
end)))))))
|
|
|
|
(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 (truncate-remainder
|
|
(- 512 (truncate-remainder nbyte 512))
|
|
512))
|
|
(bytes (read-exactly-n-bytes nbyte)))
|
|
(read-exactly-n-bytes nnull)
|
|
(list (cons 'path (tar-string-copy 0 100))
|
|
(cons 'type
|
|
(let ((type
|
|
(integer->char
|
|
(bytevector-u8-ref header 156))))
|
|
(case type
|
|
((#\0 #\nul) 'file)
|
|
((#\5) 'directory)
|
|
(else (error "Weird tar entry type" type)))))
|
|
(cons 'contents bytes)))))))
|
|
|
|
(define (tar-split-path whole)
|
|
(let ((parts
|
|
(let loop ((a 0) (b 0) (parts '()))
|
|
(cond ((= a b (string-length whole))
|
|
(reverse parts))
|
|
((= b (string-length whole))
|
|
(loop b b (cons (string-copy whole a b) parts)))
|
|
((char=? #\/ (string-ref whole b))
|
|
(loop (+ b 1) (+ b 1) (cons (string-copy whole a b) parts)))
|
|
(else
|
|
(loop a (+ b 1) parts))))))
|
|
parts))
|
|
|
|
(define (input-entry entry)
|
|
(let ((path (tar-split-path (cdr (assq 'path entry)))))
|
|
(when (null? path)
|
|
(error "blank path in tar file"))
|
|
(let ((first (car path)))
|
|
(cond ((equal? "boot" first)
|
|
(error "Boot"))
|
|
((string-prefix? "drive_" first)
|
|
(let ((drive (get-or-create-drive
|
|
(string-drop first (string-length "drive_"))))
|
|
(path (cdr path)))
|
|
(case (cdr (assq 'type entry))
|
|
((directory)
|
|
(drive-get-or-create-directory drive path))
|
|
((file)
|
|
(let* ((name (last path))
|
|
(path (butlast path)))
|
|
(fat-directory-insert-entry!
|
|
(drive-get-or-create-directory drive path)
|
|
(make-fat-file name
|
|
(cdr (assq 'contents entry)))))))))))))
|
|
|
|
(define (input)
|
|
(let loop ()
|
|
(let ((entry (tar-read-entry)))
|
|
(unless (eof-object? entry)
|
|
(input-entry entry)
|
|
(loop)))))
|
|
|
|
(define (build-file-allocation-table drive)
|
|
(let ((next-free-cluster 0))
|
|
(define (allocate! bytes)
|
|
(set! next-free-cluster (+ next-free-cluster (bytes->clusters bytes))))
|
|
(let allocate-tree ((directory (drive-root-directory drive)))
|
|
(for-each (lambda (entry)
|
|
(cond ((fat-directory? entry)
|
|
(fat-directory-set-first-cluster!
|
|
entry next-free-cluster)
|
|
(let ((entries (fat-directory-entries entry)))
|
|
(allocate! (* fat-directory-entry-size
|
|
(length entries)))))
|
|
((fat-file? entry)
|
|
(fat-file-set-first-cluster! entry next-free-cluster)
|
|
(allocate! (fat-file-size entry)))
|
|
(else
|
|
(error "What?" entry))))
|
|
(fat-directory-entries directory))
|
|
(for-each allocate-tree
|
|
(filter fat-directory? (fat-directory-entries directory))))))
|
|
|
|
(define (encode-file-allocation-table drive)
|
|
(let ((table (vector))
|
|
(next-free-cluster 0))
|
|
(define (ensure-room-for-entry!)
|
|
(let ((capacity (vector-length table)))
|
|
(when (= next-free-cluster capacity)
|
|
(let ((newtable (make-vector (max 16 (* 2 capacity)) 0)))
|
|
(vector-copy! newtable 0 table)
|
|
(set! table newtable)))))
|
|
(define (append-entry! i)
|
|
(ensure-room-for-entry!)
|
|
(vector-set! table next-free-cluster i)
|
|
(set! next-free-cluster (+ next-free-cluster 1)))
|
|
(define end-of-chain #xffff)
|
|
(let allocate-tree ((directory (drive-root-directory drive)))
|
|
(for-each (lambda (entry)
|
|
(let* ((first (fat-directory-entry-first-cluster entry))
|
|
(count (fat-directory-entry-cluster-count entry))
|
|
(last (+ first count -1)))
|
|
(let loop ((this first))
|
|
(if (>= this last)
|
|
(append-entry! end-of-chain)
|
|
(let ((next (+ this 1)))
|
|
(append-entry! next)
|
|
(loop next))))))
|
|
(fat-directory-entries directory))
|
|
(for-each allocate-tree
|
|
(filter fat-directory? (fat-directory-entries directory))))
|
|
table))
|
|
|
|
(define (ascii-alphanumeric? char)
|
|
(or (char<=? #\0 char #\9)
|
|
(char<=? #\A char #\Z)
|
|
(char<=? #\a char #\z)))
|
|
|
|
(define (valid-fat-filename-stem? str)
|
|
(and (<= (string-length str) 8)
|
|
(string-every? ascii-alphanumeric? str)))
|
|
|
|
(define (valid-fat-filename-extension? str)
|
|
(and (<= (string-length str) 3)
|
|
(string-every? ascii-alphanumeric? str)))
|
|
|
|
(define (encode-8.3-filename str)
|
|
(let* ((dot (string-index str #\.))
|
|
(stem (if dot (string-copy str 0 dot) str))
|
|
(ext (if dot (string-copy str (+ dot 1) (string-length str)) "")))
|
|
(unless (valid-fat-filename-stem? stem)
|
|
(error "stem" stem))
|
|
(unless (valid-fat-filename-extension? ext)
|
|
(error "ext" dot ext stem))
|
|
(if (and (valid-fat-filename-stem? stem)
|
|
(valid-fat-filename-extension? ext))
|
|
(string->utf8 (string-append (string-pad stem 8 #\space)
|
|
(string-pad ext 3 #\space)))
|
|
(error "Bad 8.3 filename" str))))
|
|
|
|
(define (encode-directory-entry entry)
|
|
(let ((attributes (bitwise-ior #x20 (if (fat-directory? entry) #x10 0))))
|
|
(bytevector-append
|
|
(encode-8.3-filename (fat-directory-entry-name entry))
|
|
(u8 attributes)
|
|
(u8 0) ; misc non-portable info
|
|
(u8 0) ; misc non-portable info
|
|
(u16l 0) ; create time-of-day
|
|
(u16l 0) ; create date
|
|
(u16l 0) ; access date
|
|
(u16l 0) ; misc non-portable info
|
|
(u16l 0) ; modify time-of-day
|
|
(u16l 0) ; modify date
|
|
(u16l (if (fat-file? entry) (fat-file-first-cluster entry) 0))
|
|
(u32l (if (fat-file? entry) (fat-file-size entry) 0)))))
|
|
|
|
(define (write-directory-padding n-entries)
|
|
(define nulls (make-bytevector fat-directory-entry-size 0))
|
|
(when (> n-entries 0)
|
|
(write-bytevector nulls)
|
|
(write-directory-padding (- n-entries 1))))
|
|
|
|
(define (write-directory-shallow directory min-entries)
|
|
(let ((entries (fat-directory-entries directory)))
|
|
(for-each write-bytevector (map encode-directory-entry entries))
|
|
(write-directory-padding (- min-entries (length entries)))))
|
|
|
|
(define (write-directory-subtrees directory)
|
|
(write-directory-shallow directory 0)
|
|
(for-each write-directory-subtrees
|
|
(filter fat-directory? (fat-directory-entries directory))))
|
|
|
|
(define (write-file-allocation-table drive)
|
|
(vector-for-each (lambda (fat-entry) (write-bytevector (u16l fat-entry)))
|
|
(encode-file-allocation-table drive)))
|
|
|
|
(define (encode-volume-boot-record)
|
|
(bytevector-append
|
|
;; 11 bytes
|
|
(bytevector #xeb #x3c #x90) ; x86 jump instruction
|
|
(string->utf8 "TAR2FAT ") ; OEM Name
|
|
;; BIOS parameter block - DOS 2.0 values:
|
|
(u16l bytes/sector)
|
|
(u8 sectors/cluster)
|
|
(u16l 1) ; reserved-sectors
|
|
(u8 2) ; fats
|
|
(u16l root-directory-entries)
|
|
(u16l 0) ; sectors
|
|
(u8 #xf8) ; Media descriptor: Hard disk partition.
|
|
(u16l 200) ; sectors/fat
|
|
;; BIOS parameter block - DOS 3.31 values:
|
|
(u16l physical-sectors/track)
|
|
(u16l heads)
|
|
(u32l 0) ; hidden-sectors
|
|
(u32l 0) ; large-sectors
|
|
;; Boot code:
|
|
(make-bytevector 473 0)
|
|
;; Physical drive number:
|
|
(u8 0)
|
|
;; Boot sector signature:
|
|
(u8 #x55)
|
|
(u8 #xaa)))
|
|
|
|
(define (write-drive drive)
|
|
(write-bytevector (encode-volume-boot-record))
|
|
(write-file-allocation-table drive)
|
|
(write-file-allocation-table drive)
|
|
(write-directory-shallow (drive-root-directory drive)
|
|
root-directory-entries)
|
|
(write-directory-subtrees (drive-root-directory drive)))
|
|
|
|
(define (display-drive drive)
|
|
(parameterize ((current-output-port (current-error-port)))
|
|
(define (emit nest str)
|
|
(write-string (make-string (* 2 nest) #\space))
|
|
(write-string str)
|
|
(newline))
|
|
(define (dump-directory-entries nest directory)
|
|
(for-each (lambda (entry)
|
|
(emit nest (fat-directory-entry-name entry))
|
|
(when (fat-directory? entry)
|
|
(dump-directory-entries (+ nest 1) entry)))
|
|
(fat-directory-entries directory)))
|
|
(emit 0 (drive-letter drive))
|
|
(dump-directory-entries 1 (drive-root-directory drive))))
|
|
|
|
(define (main)
|
|
(input)
|
|
(for-each build-file-allocation-table (get-used-drives))
|
|
(for-each display-drive (get-used-drives))
|
|
(for-each write-drive (get-used-drives)))
|
|
|
|
(main)
|