Initial commit

LICENSE

@@ -1,21 +1,22 @@
 MIT License
 
-Copyright (c) 2019 Scheme Documentation
+Copyright 2019 Lassi Kortela
 
-Permission is hereby granted, free of charge, to any person obtaining a copy
+Permission is hereby granted, free of charge, to any person obtaining
-of this software and associated documentation files (the "Software"), to deal
+a copy of this software and associated documentation files (the
-in the Software without restriction, including without limitation the rights
+"Software"), to deal in the Software without restriction, including
-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+without limitation the rights to use, copy, modify, merge, publish,
-copies of the Software, and to permit persons to whom the Software is
+distribute, sublicense, and/or sell copies of the Software, and to
-furnished to do so, subject to the following conditions:
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-The above copyright notice and this permission notice shall be included in all
+The above copyright notice and this permission notice shall be
-copies or substantial portions of the Software.
+included in all copies or substantial portions of the Software.
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-SOFTWARE.
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

trivial-tar-writer.scm

@@ -0,0 +1,54 @@
+;;; Copyright (c) 2019 Lassi Kortela
+;;; SPDX-License-Identifier: ISC
+
+(define nulls (make-bytevector 512 0))
+(define zeros (make-bytevector 12 (char->integer #\0)))
+
+(define (tar-poke-string header at nbyte string)
+  (let* ((bytes (string->utf8 string))
+         (nnull (- nbyte (bytevector-length bytes))))
+    (when (< nnull 0) (error "tar: string too long"))
+    (bytevector-copy! header at bytes)))
+
+(define (tar-poke-octal header at nbyte number)
+  (unless (integer? number) (error "tar: not an integer"))
+  (when (< number 0) (error "tar: negative integer"))
+  (let* ((bytes (string->utf8 (number->string number 8)))
+         (nzero (- nbyte 1 (bytevector-length bytes))))
+    (when (< nzero 0) (error "tar: number too big"))
+    (bytevector-copy! header at zeros 0 nzero)
+    (bytevector-copy! header (+ at nzero) bytes)
+    (bytevector-u8-set! header (+ at nbyte -1) 0)))
+
+(define (tar-header-checksum header)
+  (let ((n (bytevector-length header)))
+    (let loop ((i 0) (sum 0))
+      (if (= i n)
+          (truncate-remainder sum (expt 8 6))
+          (loop (+ i 1) (+ sum (bytevector-u8-ref header i)))))))
+
+(define (tar-write-file fake-path bytes)
+  (let* ((header (make-bytevector 512 0))
+         (nbyte (bytevector-length bytes))
+         (nnull (- 512 (truncate-remainder nbyte 512)))
+         (unix-time-now 0))
+    (tar-poke-string header 0 100 fake-path)
+    (tar-poke-octal header 100 8 #o644)
+    (tar-poke-octal header 108 8 0)
+    (tar-poke-octal header 116 8 0)
+    (tar-poke-octal header 124 12 nbyte)
+    (tar-poke-octal header 136 12 unix-time-now)
+    (bytevector-copy! header 148 (make-bytevector 8 (char->integer #\space)))
+    (bytevector-u8-set! header 156 (char->integer #\0))
+    (tar-poke-string header 157 100 "")
+    (tar-poke-string header 257 8 "ustar  ")
+    (tar-poke-string header 265 32 "root")
+    (tar-poke-string header 297 32 "root")
+    (tar-poke-octal header 148 7 (tar-header-checksum header))
+    (write-bytevector header)
+    (write-bytevector bytes)
+    (write-bytevector nulls (current-output-port) 0 nnull)))
+
+(define (tar-poke-end)
+  (write-bytevector nulls)
+  (write-bytevector nulls))

trivial-tar-writer.sld

@@ -0,0 +1,6 @@
+(define-library (trivial-tar-writer)
+  (export tar-write-file)
+  (import (scheme base)
+          (scheme char)
+          (scheme write))
+  (include "trivial-tar-writer.scm"))