0.0.002

ddat interop with dat js
cable interop with cabal js
ddat's frontend = dat-thang
cable fe = cable-thang
dillo support based on cel's dillo-dat
bootstrap node
xplatform support

Signed-off-by: divo <418@cryspace.space>

scheme/cable-room.scm

@@ -0,0 +1,14 @@
+;;; Cable room records are S-expressions signed by each peer's persistent key.
+;;; C handles the authenticated Cesspool/uTP transport; S7 owns the record form.
+(define (cable:room-event->wire kind timestamp nick channel text)
+  (list 'cable-room-event kind timestamp nick channel text))
+
+(define (cable:room-wire-event? value)
+  (and (list? value)
+       (= (length value) 6)
+       (eq? (car value) 'cable-room-event)
+       (integer? (cadr value))
+       (integer? (caddr value))
+       (string? (list-ref value 3))
+       (string? (list-ref value 4))
+       (string? (list-ref value 5))))

scheme/dat-init.scm

@@ -0,0 +1,42 @@
+;;; Host-level conventions shared by the Dat Scheme application layer.
+;;; S7 intentionally leaves policy and application modules to its embedding.
+
+(define dat:runtime-version "1")
+
+(define (dat:module-name->file name)
+  (if (not (symbol? name))
+      (error 'wrong-type-arg "Dat module name must be a symbol" name)
+      (if (eq? name 'dat:record)
+          "dat-record.scm"
+          (if (eq? name 'dat:wire)
+              "dat-wire.scm"
+              (let* ((text (symbol->string name))
+                     (path (string-append text ".scm")))
+                (do ((i 0 (+ i 1))) ((= i (string-length text)))
+                  (if (char=? (string-ref text i) #\:)
+                      (string-set! path i #\/)))
+                path)))))
+
+(define (dat:require feature)
+  (let ((name (if (symbol? feature) feature (string->symbol feature))))
+    (if (not (provided? name))
+        (begin
+          (load (dat:module-name->file name))
+          (if (not (provided? name))
+              (error 'dat-module-error "module did not declare its feature" name))))
+    name))
+
+(define (dat:with-archive archive procedure)
+  (if (not (procedure? procedure))
+      (error 'wrong-type-arg "expected a procedure" procedure)
+      (dynamic-wind
+        (lambda () #f)
+        (lambda () (procedure archive))
+        (lambda () (dat-close archive)))))
+
+(define (dat:call-with-archive directory procedure . create?)
+  (let ((archive ((if (and (pair? create?) (car create?)) dat-create dat-open)
+                  directory)))
+    (dat:with-archive archive procedure)))
+
+(provide 'dat:runtime)

scheme/dat-json.scm

@@ -0,0 +1,244 @@
+;;; Strict JSON reader shared by the S7-backed Dat application layer.
+;;; Objects become (json:object ("key" . value) ...), arrays become
+;;; (json:array value ...), and JSON null is the symbol json:null.
+
+(define (json:codepoint->utf8 code)
+  (if (<= code #x7f)
+      (list (integer->char code))
+      (if (<= code #x7ff)
+          (list
+           (integer->char (+ #xc0 (quotient code 64)))
+           (integer->char (+ #x80 (modulo code 64))))
+          (if (<= code #xffff)
+              (list
+               (integer->char (+ #xe0 (quotient code 4096)))
+               (integer->char (+ #x80 (modulo (quotient code 64) 64)))
+               (integer->char (+ #x80 (modulo code 64))))
+              (list
+               (integer->char (+ #xf0 (quotient code 262144)))
+               (integer->char (+ #x80 (modulo (quotient code 4096) 64)))
+               (integer->char (+ #x80 (modulo (quotient code 64) 64)))
+               (integer->char (+ #x80 (modulo code 64))))))))
+
+(define (dat:json-parse source)
+  (if (not (string? source))
+      (error 'wrong-type-arg "dat:json-parse expects a string" source))
+  (let ((port (open-input-string source)))
+    (define (fail message)
+      (error 'json-parse-error message))
+    (define (peek) (peek-char port))
+    (define (take) (read-char port))
+    (define (ws?)
+      (let ((c (peek)))
+        (and (char? c)
+             (or (char=? c #\space) (char=? c #\tab)
+                 (char=? c #\newline) (char=? c #\return)))))
+    (define (skip-ws)
+      (do () ((not (ws?))) (take)))
+    (define (expect character)
+      (if (or (not (char? (peek))) (not (char=? (take) character)))
+          (fail (string-append "expected " (string character)))))
+    (define (hex-value c)
+      (cond ((and (char>=? c #\0) (char<=? c #\9))
+             (- (char->integer c) (char->integer #\0)))
+            ((and (char>=? c #\a) (char<=? c #\f))
+             (+ 10 (- (char->integer c) (char->integer #\a))))
+            ((and (char>=? c #\A) (char<=? c #\F))
+             (+ 10 (- (char->integer c) (char->integer #\A))))
+            (else (fail "invalid hexadecimal escape"))))
+    (define (hex4)
+      (let loop ((left 4) (value 0))
+        (if (= left 0) value
+            (let ((c (take)))
+              (if (not (char? c)) (fail "incomplete unicode escape"))
+              (loop (- left 1) (+ (* value 16) (hex-value c)))))))
+    (define (parse-string)
+      (expect #\")
+      (let loop ((reversed '()))
+        (let ((c (take)))
+          (cond ((not (char? c)) (fail "unterminated string"))
+                ((char=? c #\") (list->string (reverse reversed)))
+                ((char=? c #\\)
+                 (let ((escape (take)))
+                   (cond ((not (char? escape)) (fail "incomplete escape"))
+                         ((char=? escape #\") (loop (cons #\" reversed)))
+                         ((char=? escape #\\) (loop (cons #\\ reversed)))
+                         ((char=? escape #\/) (loop (cons #\/ reversed)))
+                         ((char=? escape #\b) (loop (cons (integer->char 8) reversed)))
+                         ((char=? escape #\f) (loop (cons (integer->char 12) reversed)))
+                         ((char=? escape #\n) (loop (cons #\newline reversed)))
+                         ((char=? escape #\r) (loop (cons #\return reversed)))
+                         ((char=? escape #\t) (loop (cons #\tab reversed)))
+                         ((char=? escape #\u)
+                          (let* ((first (hex4))
+                                 (code
+                                  (cond ((and (>= first #xd800) (<= first #xdbff))
+                                         (expect #\\) (expect #\u)
+                                         (let ((second (hex4)))
+                                           (if (or (< second #xdc00) (> second #xdfff))
+                                               (fail "invalid unicode surrogate pair"))
+                                           (+ #x10000 (* (- first #xd800) #x400)
+                                              (- second #xdc00))))
+                                        ((and (>= first #xdc00) (<= first #xdfff))
+                                         (fail "unpaired unicode low surrogate"))
+                                        (else first))))
+                            (if (< code 32) (fail "invalid control character escape"))
+                            (loop (append (reverse (json:codepoint->utf8 code))
+                                          reversed))))
+                         (else (fail "invalid string escape")))))
+                ((< (char->integer c) 32) (fail "unescaped control character"))
+                (else (loop (cons c reversed)))))))
+    (define (digit? c)
+      (and (char? c) (char>=? c #\0) (char<=? c #\9)))
+    (define (parse-number)
+      (let loop ((chars '()))
+        (let ((c (peek)))
+          (if (and (char? c)
+                   (or (digit? c) (memv c '(#\- #\+ #\. #\e #\E))))
+              (begin (take) (loop (cons c chars)))
+              (let* ((text (list->string (reverse chars)))
+                     (number (string->number text)))
+                (if (or (string=? text "") (not number)
+                        (not (json:number-token? text)))
+                    (fail "invalid JSON number"))
+                number)))))
+    (define (parse-array)
+      (expect #\[)
+      (skip-ws)
+      (if (and (char? (peek)) (char=? (peek) #\]))
+          (begin (take) '(json:array))
+          (let loop ((values '()))
+            (let ((value (parse-value)))
+              (skip-ws)
+              (cond ((and (char? (peek)) (char=? (peek) #\]))
+                     (take) (cons 'json:array (reverse (cons value values))))
+                    ((and (char? (peek)) (char=? (peek) #\,))
+                     (take) (skip-ws) (loop (cons value values)))
+                    (else (fail "expected comma or closing bracket")))))))
+    (define (parse-object)
+      (expect #\{)
+      (skip-ws)
+      (if (and (char? (peek)) (char=? (peek) #\}))
+          (begin (take) '(json:object))
+          (let loop ((fields '()))
+            (if (or (not (char? (peek))) (not (char=? (peek) #\")))
+                (fail "object key must be a string"))
+            (let ((key (parse-string)))
+              (skip-ws) (expect #\:) (skip-ws)
+              (let ((field (cons key (parse-value))))
+                (skip-ws)
+                (cond ((and (char? (peek)) (char=? (peek) #\}))
+                       (take) (cons 'json:object (reverse (cons field fields))))
+                      ((and (char? (peek)) (char=? (peek) #\,))
+                       (take) (skip-ws) (loop (cons field fields)))
+                      (else (fail "expected comma or closing brace"))))))))
+    (define (literal token value)
+      (for-each (lambda (expected)
+                  (if (or (not (char? (peek)))
+                          (not (char=? (take) expected)))
+                      (fail "invalid JSON literal")))
+                (string->list token))
+      value)
+    (define (parse-value)
+      (skip-ws)
+      (let ((c (peek)))
+        (cond ((not (char? c)) (fail "expected a JSON value"))
+              ((char=? c #\") (parse-string))
+              ((char=? c #\{) (parse-object))
+              ((char=? c #\[) (parse-array))
+              ((char=? c #\t) (literal "true" #t))
+              ((char=? c #\f) (literal "false" #f))
+              ((char=? c #\n) (literal "null" 'json:null))
+              ((or (digit? c) (char=? c #\-)) (parse-number))
+              (else (fail "unexpected character in JSON")))))
+    (let ((value (parse-value)))
+      (skip-ws)
+      (if (not (eof-object? (peek))) (fail "trailing data after JSON value"))
+      value)))
+
+;;; Validate the RFC 8259 number grammar before string->number, which accepts
+;;; Scheme-specific forms that are not valid JSON.
+(define (json:number-token? text)
+  (let* ((n (string-length text)) (i 0))
+    (define (at c) (and (< i n) (char=? (string-ref text i) c)))
+    (define (digits)
+      (let ((start i))
+        (do () ((or (>= i n)
+                    (not (char<=? #\0 (string-ref text i) #\9))))
+          (set! i (+ i 1)))
+        (> i start)))
+    (if (at #\-) (set! i (+ i 1)))
+    (let ((integer-ok
+           (cond ((at #\0) (set! i (+ i 1)) (not (and (< i n) (char<=? #\0 (string-ref text i) #\9))))
+                 (else (and (< i n) (char<=? #\1 (string-ref text i) #\9)
+                            (begin (set! i (+ i 1)) (digits) #t))))))
+      (and integer-ok
+           (or (not (at #\.))
+               (begin (set! i (+ i 1)) (digits)))
+           (or (not (or (at #\e) (at #\E)))
+               (begin (set! i (+ i 1))
+                      (if (or (at #\+) (at #\-)) (set! i (+ i 1)))
+                      (digits)))
+           (= i n)))))
+
+(define (dat:json-object-ref object key . fallback)
+  (if (or (not (pair? object)) (not (eq? (car object) 'json:object)))
+      (error 'wrong-type-arg "expected a parsed JSON object" object)
+      (let ((field (assoc key (cdr object))))
+        (if field (cdr field) (if (pair? fallback) (car fallback) #f)))))
+
+;;; Encode the same tagged values returned by dat:json-parse. Scheme records
+;;; remain the native representation; this is the narrow adapter used when a
+;;; compatible peer requires JSON bytes on the wire.
+(define (dat:json-stringify value)
+  (define (write-unicode-escape n port)
+    (let ((digits "0123456789abcdef"))
+      (display "\\u" port)
+      (for-each
+       (lambda (shift)
+         (write-char (string-ref digits (modulo (quotient n shift) 16)) port))
+       '(4096 256 16 1))))
+  (define (string-encode text)
+    (let ((port (open-output-string)))
+      (write-char #\" port)
+      (for-each
+       (lambda (c)
+         (let ((n (char->integer c)))
+           (cond ((char=? c #\") (display "\\\"" port))
+                 ((char=? c #\\) (display "\\\\" port))
+                 ((char=? c #\backspace) (display "\\b" port))
+                 ((char=? c #\newline) (display "\\n" port))
+                 ((char=? c #\return) (display "\\r" port))
+                 ((char=? c #\tab) (display "\\t" port))
+                 ((< n 32) (write-unicode-escape n port))
+                 (else (write-char c port)))))
+       (string->list text))
+      (write-char #\" port)
+      (get-output-string port)))
+  (define (encode item)
+    (cond ((string? item) (string-encode item))
+          ((eq? item 'json:null) "null")
+          ((eq? item #t) "true")
+          ((eq? item #f) "false")
+          ((number? item)
+           (let ((text (number->string item)))
+             (if (json:number-token? text) text
+                 (error 'json-encode-error "number is not representable in JSON" item))))
+          ((and (pair? item) (eq? (car item) 'json:array))
+           (string-append "[" (join "," (map encode (cdr item))) "]"))
+          ((and (pair? item) (eq? (car item) 'json:object))
+           (string-append "{" (join ","
+             (map (lambda (field)
+                    (if (or (not (pair? field)) (not (string? (car field))))
+                        (error 'json-encode-error "object keys must be strings" field))
+                    (string-append (string-encode (car field)) ":" (encode (cdr field))))
+                  (cdr item))) "}"))
+          (else (error 'json-encode-error "unsupported JSON value" item))))
+  (define (join separator strings)
+    (if (null? strings) ""
+        (let loop ((rest (cdr strings)) (out (car strings)))
+          (if (null? rest) out
+              (loop (cdr rest) (string-append out separator (car rest)))))))
+  (encode value))
+
+(provide 'dat:json)

scheme/dat-record.scm

@@ -0,0 +1,42 @@
+;;; Shared record conventions for Scheme-facing Dat APIs.
+;;; A record is (tag (field . value) ...); payload bytes stay bytevectors.
+
+(define (dat:record? value . wanted-tag)
+  (and (pair? value)
+       (symbol? (car value))
+       (or (null? wanted-tag) (eq? (car value) (car wanted-tag)))
+       (let loop ((fields (cdr value)) (seen '()))
+         (if (null? fields)
+             #t
+             (and (pair? fields)
+                  (pair? (car fields))
+                  (symbol? (caar fields))
+                  (not (memq (caar fields) seen))
+                  (loop (cdr fields) (cons (caar fields) seen)))))))
+
+(define (dat:record-ref record field . fallback)
+  (if (not (dat:record? record))
+      (error 'wrong-type-arg "expected a Dat record" record)
+      (if (not (symbol? field))
+          (error 'wrong-type-arg "record field name must be a symbol" field)
+          (let ((entry (assq field (cdr record))))
+            (if entry
+                (cdr entry)
+                (if (pair? fallback) (car fallback) #f))))))
+
+(define (dat:record-set record field value)
+  (if (not (dat:record? record))
+      (error 'wrong-type-arg "expected a Dat record" record)
+      (if (not (symbol? field))
+          (error 'wrong-type-arg "record field name must be a symbol" field)
+          (let loop ((fields (cdr record)) (reversed '()) (found #f))
+            (if (null? fields)
+                (cons (car record)
+                      (reverse (if found reversed
+                                   (cons (cons field value) reversed))))
+                (let ((entry (car fields)))
+                  (if (eq? (car entry) field)
+                      (loop (cdr fields) (cons (cons field value) reversed) #t)
+                      (loop (cdr fields) (cons entry reversed) found))))))))
+
+(provide 'dat:record)

scheme/dat-wire.scm

@@ -0,0 +1,31 @@
+;;; The C codec owns framing and protocol bytes. Scheme owns the readable view.
+;;; Wire records have named fields, so optional fields can be added without
+;;; changing positional call sites or the peer-visible protocol.
+
+(define (dat:wire-message channel type payload)
+  (if (not (and (integer? channel) (exact? channel) (>= channel 0)))
+      (error 'out-of-range "wire channel must be a non-negative exact integer" channel))
+  (if (not (and (integer? type) (exact? type) (>= type 0)))
+      (error 'out-of-range "wire type must be a non-negative exact integer" type))
+  (if (not (byte-vector? payload))
+      (error 'wrong-type-arg "wire payload must be a bytevector" payload))
+  (list 'dat:wire-message
+        (cons 'channel channel)
+        (cons 'type type)
+        (cons 'payload payload)))
+
+(define (dat:wire-message? value)
+  (and (dat:record? value 'dat:wire-message)
+       (integer? (dat:record-ref value 'channel #f))
+       (integer? (dat:record-ref value 'type #f))
+       (byte-vector? (dat:record-ref value 'payload #f))))
+
+(define (dat:wire-frame->record bytes)
+  (dat-wire->sexp bytes))
+
+(define (dat:record->wire-frame record)
+  (if (not (dat:wire-message? record))
+      (error 'wrong-type-arg "expected a dat:wire-message record" record)
+      (dat-sexp->wire record)))
+
+(provide 'dat:wire)