Initial commit

core/src/lib/getopt.sld

@@ -0,0 +1,56 @@
+(define-library (zilch lib getopt)
+  (import (scheme base) (scheme write))
+  (export getopt)
+
+  (begin
+    ; format: (option [requires value] [single char])
+    ; (single-char char) (required? bool) (value bool) (predicate func)
+    (define (is-long-option value) (and (> (string-length value) 3) (string=? (string-copy value 0 2) "--")))
+    (define (is-short-option value) (and (> (string-length value) 1) (char=? (string-ref value 0) #\-) (not (char=? (string-ref value 1) #\-))))
+   
+    (define (find-long-option options val)
+      (cond
+        ((eq? options '()) #f)
+        ((string=? (symbol->string (caar options)) val) (car options))
+        (else (find-long-option (cdr options) val))))
+
+    (define (find-short-option options val)
+      (cond
+        ((eq? options '()) #f)
+        ((and (> (length (car options)) 2) (list-ref (car options) 2) (char=? (list-ref (car options) 2) val)) (car options))
+        (else (find-short-option (cdr options) val))))
+
+    (define (getopt options vals help)
+      (do ((i 0 (+ i 1)) (outputs '() outputs) (rest '() rest))
+          ((>= i (vector-length vals)) (values outputs (reverse rest)))
+          (define val (vector-ref vals i))
+          (define option #f)
+          (cond
+             ;; If we see a "--" entry, take the rest, as this is the end of options.
+             ((string=? val "--")
+              (set! rest (append (reverse (vector->list vals (+ i 1))) rest))
+              (set! i (vector-length vals)))
+
+             ;; If this looks like a long option, look it up + find the argument
+             ((is-long-option val)
+              (set! option (find-long-option options (string-copy val 2)))
+              (unless option (help (string-append "Unknown option " val)))
+              (if (cadr option) ; requires parameter
+                  (begin
+                     (set! outputs (cons (cons (car option) (vector-ref vals (+ i 1))) outputs))
+                     (set! i (+ i 1)))
+                  (set! outputs (cons (cons (car option) #f) outputs))))
+
+             ((is-short-option val)
+              (do ((j 1 (+ j 1))) ((>= j (string-length val)) #f)
+                  (set! option (find-short-option options (string-ref val j)))
+                  (unless option (help (string-append "Unknown option -" (string (string-ref val j)))))
+                  (if (and (cadr option) (< j (- (string-length val) 1))) (help (string-append "Option -" (string (string-ref val j)) " (long option --" (symbol->string (car option)) ") requires argument, but isn't last")))
+                  (if (cadr option)
+                      (begin
+                         (set! outputs (cons (cons (car option) (vector-ref vals (+ i 1))) outputs))
+                         (set! i (+ i 1)))
+                      (set! outputs (cons (cons (car option) #f) outputs)))))
+             (else (set! rest (cons val rest))))))))
+
+        

core/src/lib/hash.scm

@@ -0,0 +1,41 @@
+(define-library (zilch lib hash)
+ (import
+   (scheme base) (scheme write)
+   (chicken foreign)
+   (srfi 151))
+ (export sha256 hex)
+
+ (begin
+   (foreign-declare "#include <sodium/crypto_hash_sha256.h>")
+  
+   (define sodium-sha256 (foreign-lambda void "crypto_hash_sha256" nonnull-u8vector nonnull-u8vector unsigned-integer64))
+   (define sodium-sha256-init (foreign-lambda void "crypto_hash_sha256_init" (nonnull-scheme-pointer "crypto_hash_sha256_state")))
+   (define sodium-sha256-update (foreign-lambda void "crypto_hash_sha256_update" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector unsigned-integer64))
+   (define sodium-sha256-final (foreign-lambda void "crypto_hash_sha256_final" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector))
+
+   (define (sha256 buf)
+     (define out (make-bytevector 32))
+     (cond
+       ((bytevector? buf) (sodium-sha256 out buf (bytevector-length buf)))
+       ((string? buf) (set! buf (string->utf8 buf)) (sodium-sha256 out buf (bytevector-length buf)))
+       ((input-port? buf)
+        (let
+          ((state (make-bytevector (foreign-type-size "crypto_hash_sha256_state") 0))
+           (bbuf (make-bytevector 32 0)))
+          (sodium-sha256-init state)
+          (do
+           ((bytes-read 0 (read-bytevector! bbuf buf)))
+           ((eof-object? bytes-read) (sodium-sha256-final state out))
+           (sodium-sha256-update state bbuf bytes-read))))
+       (else (error "unknown object type passed to ((zilch lib hash) sha256)")))
+    out)
+  
+   (define hexit "0123456789abcdef")
+
+   (define (hex bv)
+     (define out (make-string (* (bytevector-length bv) 2) #\!))
+     (do ((i 0 (+ i 1)))
+         ((>= i (bytevector-length bv)) out)
+       (let* ((val (bytevector-u8-ref bv i)) (q (arithmetic-shift val -4)) (r (bitwise-and val #xF)))
+         (string-set! out (* i 2) (string-ref hexit q))
+         (string-set! out (+ (* i 2) 1) (string-ref hexit r)))))))