lassik
/
feather
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit

This commit is contained in:
Lassi Kortela 2024-04-12 15:16:55 +03:00
commit e81c5d7084
3 changed files with 189 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
LICENSE Normal file
View File

@ -0,0 +1,13 @@
Copyright 2024 Lassi Kortela
Permission to use, copy, modify, and distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

78
crc.sld Normal file
View File

@ -0,0 +1,78 @@
(define-library (crc)
(export
crc-update-byte
crc-update-bytes
crc-update-length
crc-complement)
(import (scheme base) (srfi 4) (srfi 151))
(begin
(define crc-table
#u32(#x00000000 #x04c11db7 #x09823b6e #x0d4326d9 #x130476dc #x17c56b6b
#x1a864db2 #x1e475005 #x2608edb8 #x22c9f00f #x2f8ad6d6 #x2b4bcb61
#x350c9b64 #x31cd86d3 #x3c8ea00a #x384fbdbd #x4c11db70 #x48d0c6c7
#x4593e01e #x4152fda9 #x5f15adac #x5bd4b01b #x569796c2 #x52568b75
#x6a1936c8 #x6ed82b7f #x639b0da6 #x675a1011 #x791d4014 #x7ddc5da3
#x709f7b7a #x745e66cd #x9823b6e0 #x9ce2ab57 #x91a18d8e #x95609039
#x8b27c03c #x8fe6dd8b #x82a5fb52 #x8664e6e5 #xbe2b5b58 #xbaea46ef
#xb7a96036 #xb3687d81 #xad2f2d84 #xa9ee3033 #xa4ad16ea #xa06c0b5d
#xd4326d90 #xd0f37027 #xddb056fe #xd9714b49 #xc7361b4c #xc3f706fb
#xceb42022 #xca753d95 #xf23a8028 #xf6fb9d9f #xfbb8bb46 #xff79a6f1
#xe13ef6f4 #xe5ffeb43 #xe8bccd9a #xec7dd02d #x34867077 #x30476dc0
#x3d044b19 #x39c556ae #x278206ab #x23431b1c #x2e003dc5 #x2ac12072
#x128e9dcf #x164f8078 #x1b0ca6a1 #x1fcdbb16 #x018aeb13 #x054bf6a4
#x0808d07d #x0cc9cdca #x7897ab07 #x7c56b6b0 #x71159069 #x75d48dde
#x6b93dddb #x6f52c06c #x6211e6b5 #x66d0fb02 #x5e9f46bf #x5a5e5b08
#x571d7dd1 #x53dc6066 #x4d9b3063 #x495a2dd4 #x44190b0d #x40d816ba
#xaca5c697 #xa864db20 #xa527fdf9 #xa1e6e04e #xbfa1b04b #xbb60adfc
#xb6238b25 #xb2e29692 #x8aad2b2f #x8e6c3698 #x832f1041 #x87ee0df6
#x99a95df3 #x9d684044 #x902b669d #x94ea7b2a #xe0b41de7 #xe4750050
#xe9362689 #xedf73b3e #xf3b06b3b #xf771768c #xfa325055 #xfef34de2
#xc6bcf05f #xc27dede8 #xcf3ecb31 #xcbffd686 #xd5b88683 #xd1799b34
#xdc3abded #xd8fba05a #x690ce0ee #x6dcdfd59 #x608edb80 #x644fc637
#x7a089632 #x7ec98b85 #x738aad5c #x774bb0eb #x4f040d56 #x4bc510e1
#x46863638 #x42472b8f #x5c007b8a #x58c1663d #x558240e4 #x51435d53
#x251d3b9e #x21dc2629 #x2c9f00f0 #x285e1d47 #x36194d42 #x32d850f5
#x3f9b762c #x3b5a6b9b #x0315d626 #x07d4cb91 #x0a97ed48 #x0e56f0ff
#x1011a0fa #x14d0bd4d #x19939b94 #x1d528623 #xf12f560e #xf5ee4bb9
#xf8ad6d60 #xfc6c70d7 #xe22b20d2 #xe6ea3d65 #xeba91bbc #xef68060b
#xd727bbb6 #xd3e6a601 #xdea580d8 #xda649d6f #xc423cd6a #xc0e2d0dd
#xcda1f604 #xc960ebb3 #xbd3e8d7e #xb9ff90c9 #xb4bcb610 #xb07daba7
#xae3afba2 #xaafbe615 #xa7b8c0cc #xa379dd7b #x9b3660c6 #x9ff77d71
#x92b45ba8 #x9675461f #x8832161a #x8cf30bad #x81b02d74 #x857130c3
#x5d8a9099 #x594b8d2e #x5408abf7 #x50c9b640 #x4e8ee645 #x4a4ffbf2
#x470cdd2b #x43cdc09c #x7b827d21 #x7f436096 #x7200464f #x76c15bf8
#x68860bfd #x6c47164a #x61043093 #x65c52d24 #x119b4be9 #x155a565e
#x18197087 #x1cd86d30 #x029f3d35 #x065e2082 #x0b1d065b #x0fdc1bec
#x3793a651 #x3352bbe6 #x3e119d3f #x3ad08088 #x2497d08d #x2056cd3a
#x2d15ebe3 #x29d4f654 #xc5a92679 #xc1683bce #xcc2b1d17 #xc8ea00a0
#xd6ad50a5 #xd26c4d12 #xdf2f6bcb #xdbee767c #xe3a1cbc1 #xe760d676
#xea23f0af #xeee2ed18 #xf0a5bd1d #xf464a0aa #xf9278673 #xfde69bc4
#x89b8fd09 #x8d79e0be #x803ac667 #x84fbdbd0 #x9abc8bd5 #x9e7d9662
#x933eb0bb #x97ffad0c #xafb010b1 #xab710d06 #xa6322bdf #xa2f33668
#xbcb4666d #xb8757bda #xb5365d03 #xb1f740b4))
(define (crc-update-byte crc byte)
(let ((left (arithmetic-shift crc 8))
(right (arithmetic-shift crc -24)))
(bitwise-and #xffffffff
(bitwise-xor left
(u32vector-ref crc-table
(bitwise-xor right byte))))))
(define (crc-update-bytes crc bytes)
(let loop ((crc crc) (i 0))
(if (< i (bytevector-length bytes))
(loop (crc-update-byte crc (bytevector-u8-ref bytes i))
(+ i 1))
crc)))
(define (crc-update-length crc len)
(let loop ((crc crc) (len len))
(if (> len 0)
(loop (crc-update-byte crc (bitwise-and len 255))
(arithmetic-shift len -8))
crc)))
(define (crc-complement crc)
(bitwise-xor #xffffffff crc))))

98
feather-pack.scm Normal file
View File

@ -0,0 +1,98 @@
(import (scheme base)
(scheme file)
(srfi 19)
(srfi 132)
(srfi 170)
(srfi 193)
(crc))
(define space (char->integer #\space))
(define equal (char->integer #\=))
(define linefeed (char->integer #\newline))
(define (add-length-digits length)
(let fixed-point ((count 1))
(let* ((digits (number->string (+ count length)))
(new-count (string-length digits)))
(if (= count new-count) digits (fixed-point new-count)))))
(define (record-length-digits keyword-length value-length)
(add-length-digits (+ 1 keyword-length 1 value-length 1)))
(define (begin-record keyword value-length)
(let* ((keyword-bytes (string->utf8 keyword))
(keyword-length (bytevector-length keyword-bytes)))
(write-bytevector
(string->utf8 (record-length-digits keyword-length value-length)))
(write-u8 space)
(write-bytevector keyword-bytes)
(write-u8 equal)))
(define (pack-string keyword value)
(let* ((value-bytes (string->utf8 value))
(value-length (bytevector-length value-bytes)))
(begin-record keyword value-length)
(write-bytevector value-bytes)
(write-u8 linefeed)))
(define (pack-number keyword value)
(pack-string keyword (number->string value)))
(define (pack-timestamp keyword time)
(let ((date (time-utc->date time 0)))
(pack-string keyword (date->string date "~s"))))
(define (pack-header path info)
(let ((user (user-info (file-info:uid info)))
(group (group-info (file-info:gid info))))
(pack-string "path" path)
(when user (pack-string "uname" (user-info:name user)))
(when group (pack-string "gname" (group-info:name group)))
(pack-number "uid" (file-info:uid info))
(pack-number "gid" (file-info:gid info))
(pack-timestamp "mtime" (file-info:mtime info))
(pack-number "size" (file-info:size info))))
(define (pack-data path info)
(let ((size (file-info:size info)))
(begin-record "data" (+ 2 size))
(write-u8 linefeed)
(write-u8 linefeed)
(call-with-port (open-binary-input-file path)
(lambda (input)
(let ((chunk (expt 2 18)))
(let loop ((crc 0) (remain size))
(cond ((positive? remain)
(let ((bytes (read-bytevector (min chunk remain) input)))
(when (eof-object? bytes) (error "Truncated file"))
(write-bytevector bytes)
(loop (crc-update-bytes crc bytes)
(- remain (bytevector-length bytes)))))
(else
(write-u8 linefeed)
(let ((crc (crc-update-length crc size)))
(pack-number "cksum" (crc-complement crc)))))))))))
(define (pack-file path)
(let ((info (file-info path #f)))
(pack-header path info)
(cond ((file-info-directory? info)
(pack-files path))
((file-info-symlink? info)
(error "Symlink" path))
((file-info-regular? info)
(pack-data path info))
(else
(error "Cannot pack" path)))))
(define (pack-files dir)
(for-each (lambda (name)
(pack-file (string-append dir "/" name)))
(list-sort string<? (directory-files dir))))
(define (main)
(write-string "#! /usr/bin/env feather-archive")
(newline)
(for-each pack-file (command-args)))
(main)