summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2021-02-28 14:39:54 +0100
committerpukkamustard <pukkamustard@posteo.net>2021-02-28 14:39:54 +0100
commit52a3dd0989c3b9c965d327696f14e2accf5cf7cb (patch)
tree3286cc4e4e03b528f5be15fdeaf44692edea172a
parent7e8d59e07542378e1ffb318dd29a884b9054e9d2 (diff)
(cbor): Move everyhing to a single module
-rw-r--r--Makefile.am6
-rw-r--r--cbor.scm286
-rw-r--r--cbor/decode.scm132
-rw-r--r--cbor/encode.scm128
-rw-r--r--cbor/indefinite-length.scm16
-rw-r--r--cbor/tag.scm19
-rw-r--r--hall.scm6
-rw-r--r--tests/cbor.scm2
8 files changed, 283 insertions, 312 deletions
diff --git a/Makefile.am b/Makefile.am
index a60d70f..73ec9ae 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,11 +34,7 @@ SUFFIXES = .scm .go
.scm.go:
$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<"
-SOURCES = cbor.scm \
- cbor/decode.scm \
- cbor/encode.scm \
- cbor/tag.scm \
- cbor/indefinite-length.scm
+SOURCES = cbor.scm
TESTS = tests/cbor.scm
diff --git a/cbor.scm b/cbor.scm
index 475016b..5faa619 100644
--- a/cbor.scm
+++ b/cbor.scm
@@ -3,22 +3,298 @@
; SPDX-License-Identifier: GPL-3.0-or-later
(define-module (cbor)
+
+ #:use-module (rnrs arithmetic bitwise)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
- #:use-module (cbor encode)
- #:use-module (cbor decode)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-43)
#:export (scm->cbor
- cbor->scm))
+ cbor->scm
+
+ <cbor-tag>
+ make-cbor-tag
+ cbor-tag?
+ cbor-tag-number
+ cbor-tag-content
+
+ <cbor-indefinite-length>
+ make-cbor-indefinite-length
+ cbor-indefinite-length?
+ cbor-indefinite-length-value
+
+
+ put-cbor-data-item
+ get-cbor-data-item))
+
+;; CBOR tags
+
+(define-record-type <cbor-tag>
+ (make-cbor-tag number content)
+ cbor-tag?
+ (number cbor-tag-number)
+ (content cbor-tag-content))
+
+;; Indefinite-length arrays and maps
+
+(define-record-type <cbor-indefinite-length>
+ (make-cbor-indefinite-length value)
+ cbor-indefinite-length?
+ (value cbor-indefinite-length-value))
+
+;; Encoding
+
+(define (put-cbor-initial-byte port major-type additional-info)
+ (put-u8 port
+ (bitwise-ior
+ ;; shift major-type to upper 3 bits
+ (bitwise-arithmetic-shift major-type 5)
+ additional-info)))
+
+(define (put-uint-network-order port uint size)
+ (let ((bv (make-bytevector size)))
+ (bytevector-uint-set! bv 0 uint (endianness big) size)
+ (put-bytevector port bv)))
+
+(define (put-cbor-integer port major-type uint)
+ (let ((arg-length (ceiling-quotient (integer-length uint) 8)))
+ (cond
+ ;; directly encode value in additional info
+ ((< uint 24)
+ (put-cbor-initial-byte port major-type uint))
+
+ ;; fits in one byte
+ ((<= arg-length 1)
+ (put-cbor-initial-byte port major-type 24)
+ (put-uint-network-order port uint 1))
+
+ ((<= arg-length 2)
+ (put-cbor-initial-byte port major-type 25)
+ (put-uint-network-order port uint 2))
+
+ ((<= arg-length 4)
+ (put-cbor-initial-byte port major-type 26)
+ (put-uint-network-order port uint 4))
+
+ ((<= arg-length 8)
+ (put-cbor-initial-byte port major-type 27)
+ (put-uint-network-order port uint 8))
+
+ ;; TODO error integer out of bound
+ (else 'oops))))
+
+(define (put-cbor-indefinite-length port value)
+ (cond
+
+ ;; Indefinite-length array
+ ((vector? value)
+ (put-cbor-initial-byte port 4 31)
+ (vector-for-each (lambda (_ sub-value)
+ (put-cbor-data-item port sub-value))
+ value)
+ (put-cbor-initial-byte port 7 31))
+
+ ;; Indefinite-length map
+ ((list? value)
+ (put-cbor-initial-byte port 5 31)
+ (for-each (lambda (key-value)
+ (put-cbor-data-item port (car key-value))
+ (put-cbor-data-item port (cdr key-value)))
+ value)
+ (put-cbor-initial-byte port 7 31))))
+
+(define (put-cbor-data-item port value)
+ "Write CBOR encoding of @var{value} to @var{port}, a binary output port."
+ (cond
+
+ ;; unsigned integer
+ ((and (exact-integer? value) (<= 0 value))
+ (put-cbor-integer port 0 value))
+
+ ;; negative integer
+ ((and (exact-integer? value) (> 0 value))
+ (put-cbor-integer port 1 (- -1 value)))
+
+ ((bytevector? value)
+ (put-cbor-integer port 2 (bytevector-length value))
+ (put-bytevector port value))
+
+ ((string? value)
+ (let ((as-bytes (string->utf8 value)))
+ (put-cbor-integer port 3 (bytevector-length as-bytes))
+ (put-bytevector port as-bytes)))
+
+ ((vector? value)
+ (put-cbor-integer port 4 (vector-length value))
+ (vector-for-each (lambda (_ sub-value)
+ (put-cbor-data-item port sub-value))
+ value))
+
+ ((list? value)
+ (put-cbor-integer port 5 (length value))
+ (for-each (lambda (key-value)
+ (put-cbor-data-item port (car key-value))
+ (put-cbor-data-item port (cdr key-value)))
+ value))
+
+ ((cbor-tag? value)
+ (put-cbor-integer port 6 (cbor-tag-number value))
+ (put-cbor-data-item port (cbor-tag-content value)))
+
+ ((cbor-indefinite-length? value)
+ (put-cbor-indefinite-length port (cbor-indefinite-length-value value)))
+
+ ((real? value)
+ (let ((bv (make-bytevector 8)))
+ (put-cbor-initial-byte port 7 27)
+ (bytevector-ieee-double-set! bv 0 value (endianness big))
+ (put-bytevector port bv)))
+
+ ((equal? value #f)
+ (put-cbor-initial-byte port 7 20))
+
+ ((equal? value #t)
+ (put-cbor-initial-byte port 7 21))
+
+ ((nil? value)
+ (put-cbor-initial-byte port 7 22))))
+
+;; Decoding
+
+(define (get-uint-network-order port n)
+ "Read a unsigned integer of size @code{n} in network order (big endian) from
+@code{port}"
+ (bytevector-uint-ref (get-bytevector-n port n)
+ 0 (endianness big) n))
+
+(define (get-argument port additional-information)
+ (cond
+ ((< additional-information 24)
+ ;; the argument's value is the value of the additional information
+ additional-information)
+
+ ((eqv? additional-information 24)
+ (get-uint-network-order port 1))
+
+ ((eqv? additional-information 25)
+ (get-uint-network-order port 2))
+
+ ((eqv? additional-information 26)
+ (get-uint-network-order port 4))
+
+ ((eqv? additional-information 27)
+ (get-uint-network-order port 8))
+
+ ((eqv? additional-information 31)
+ 'indefinite-length)
+
+ ;; TODO: error handling
+ (else 'not-well-formed)))
+
+(define (get-cbor-data-item port)
+ "Read a single CBOR data item from @code{port}"
+ (let* ((initial-byte (get-u8 port))
+ ;; major type is in the higher-order 3 bits
+ (major-type (bit-extract initial-byte 5 8))
+ ;; additional information is in the lower-order 5 bits
+ (additional-information (bit-extract initial-byte 0 5))
+ ;; read argument value
+ (argument (get-argument port additional-information)))
+
+ (case major-type
+
+ ;; unsigned integer
+ ((0) argument)
+
+ ;; negative integer
+ ((1) (- -1 argument))
+
+ ;; byte string
+ ((2) (get-bytevector-n port argument))
+
+ ;; text string
+ ((3) (utf8->string (get-bytevector-n port argument)))
+
+ ;; array of data items
+ ((4) (if (eqv? argument 'indefinite-length)
+
+ ;; Read values until we get a 'break
+ (reverse-list->vector
+ (let loop ((value (get-cbor-data-item port))
+ (lst '()))
+ (if (eqv? value 'break)
+ lst
+ (loop (get-cbor-data-item port)
+ (cons value lst)))))
+
+ ;; Read argument many values
+ (vector-unfold
+ (lambda (_) (get-cbor-data-item port))
+ argument)))
+
+ ;; map of pairs of data items
+ ((5) (if (eqv? argument 'indefinite-length)
+
+ ;; Read values until we get a 'break
+ (reverse
+ (let loop ((lst '()))
+ ;; read the key
+ (let ((key (get-cbor-data-item port)))
+ (if (eqv? key 'break)
+ lst
+ (loop (cons (cons key
+ ;; get the value
+ (get-cbor-data-item port))
+ lst))))))
+
+ ;; Read argument many key-value pairs
+ (map (lambda (_) (cons (get-cbor-data-item port)
+ (get-cbor-data-item port)))
+ (iota argument))))
+
+ ;; tagged data item
+ ((6) (make-cbor-tag argument
+ (get-cbor-data-item port)))
+
+ ;; floating-point number and simple values
+ ((7) (case additional-information
+ ((20) #f)
+ ((21) #t)
+ ((22) #nil)
+
+ ;; TODO error handling
+ ((25) 'not-supported)
+
+ ;; re-encode argument as bytevector and decode as float
+ ;; FIXME this is ineficient
+ ((26) (let ((bv (make-bytevector 4)))
+ (bytevector-u32-set! bv 0 argument (endianness big))
+ (bytevector-ieee-single-ref bv 0 (endianness big))))
+
+ ((27) (let ((bv (make-bytevector 8)))
+ (bytevector-u64-set! bv 0 argument (endianness big))
+ (display bv)
+ (bytevector-ieee-double-ref bv 0 (endianness big))))
+
+ ((31) 'break)
+
+ ;; TODO error handling
+ (else 'not-well-formed))))))
+
+
+;; Simple interface
-(define (scm->cbor native)
+(define (scm->cbor value)
+ "Returns the CBOR encoding of the Scheme value @var{value} as bytevector."
(call-with-values open-bytevector-output-port
(lambda (port get-bytevector)
- (put-cbor-data-item port native)
+ (put-cbor-data-item port value)
(get-bytevector))))
(define (cbor->scm port-or-bv)
+ "Returns the Scheme value of CBOR that is read from the port or bytevector @var{port-or-bv}."
(if (port? port-or-bv)
(get-cbor-data-item port-or-bv)
(cbor->scm (open-bytevector-input-port port-or-bv))))
diff --git a/cbor/decode.scm b/cbor/decode.scm
deleted file mode 100644
index 01c9535..0000000
--- a/cbor/decode.scm
+++ /dev/null
@@ -1,132 +0,0 @@
-; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
-;
-; SPDX-License-Identifier: GPL-3.0-or-later
-
-(define-module (cbor decode)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
- #:use-module (srfi srfi-43)
-
- #:use-module (cbor tag)
-
- #:export (get-cbor-data-item))
-
-(define (get-uint-network-order port n)
- "Read a unsigned integer of size @code{n} in network order (big endian) from
-@code{port}"
- (bytevector-uint-ref (get-bytevector-n port n)
- 0 (endianness big) n))
-
-(define (get-argument port additional-information)
- (cond
- ((< additional-information 24)
- ;; the argument's value is the value of the additional information
- additional-information)
-
- ((eqv? additional-information 24)
- (get-uint-network-order port 1))
-
- ((eqv? additional-information 25)
- (get-uint-network-order port 2))
-
- ((eqv? additional-information 26)
- (get-uint-network-order port 4))
-
- ((eqv? additional-information 27)
- (get-uint-network-order port 8))
-
- ((eqv? additional-information 31)
- 'indefinite-length)
-
- ;; TODO: error handling
- (else 'not-well-formed)))
-
-(define (get-cbor-data-item port)
- "Read a single CBOR data item from @code{port}"
- (let* ((initial-byte (get-u8 port))
- ;; major type is in the higher-order 3 bits
- (major-type (bit-extract initial-byte 5 8))
- ;; additional information is in the lower-order 5 bits
- (additional-information (bit-extract initial-byte 0 5))
- ;; read argument value
- (argument (get-argument port additional-information)))
-
- (case major-type
-
- ;; unsigned integer
- ((0) argument)
-
- ;; negative integer
- ((1) (- -1 argument))
-
- ;; byte string
- ((2) (get-bytevector-n port argument))
-
- ;; text string
- ((3) (utf8->string (get-bytevector-n port argument)))
-
- ;; array of data items
- ((4) (if (eqv? argument 'indefinite-length)
-
- ;; Read values until we get a 'break
- (reverse-list->vector
- (let loop ((value (get-cbor-data-item port))
- (lst '()))
- (if (eqv? value 'break)
- lst
- (loop (get-cbor-data-item port)
- (cons value lst)))))
-
- ;; Read argument many values
- (vector-unfold
- (lambda (_) (get-cbor-data-item port))
- argument)))
-
- ;; map of pairs of data items
- ((5) (if (eqv? argument 'indefinite-length)
-
- ;; Read values until we get a 'break
- (reverse
- (let loop ((lst '()))
- ;; read the key
- (let ((key (get-cbor-data-item port)))
- (if (eqv? key 'break)
- lst
- (loop (cons (cons key
- ;; get the value
- (get-cbor-data-item port))
- lst))))))
-
- ;; Read argument many key-value pairs
- (map (lambda (_) (cons (get-cbor-data-item port)
- (get-cbor-data-item port)))
- (iota argument))))
-
- ;; tagged data item
- ((6) (make-cbor-tag argument
- (get-cbor-data-item port)))
-
- ;; floating-point number and simple values
- ((7) (case additional-information
- ((20) #f)
- ((21) #t)
- ((22) #nil)
-
- ;; TODO error handling
- ((25) 'not-supported)
-
- ;; re-encode argument as bytevector and decode as float
- ;; FIXME this is ineficient
- ((26) (let ((bv (make-bytevector 4)))
- (bytevector-u32-set! bv 0 argument (endianness big))
- (bytevector-ieee-single-ref bv 0 (endianness big))))
-
- ((27) (let ((bv (make-bytevector 8)))
- (bytevector-u64-set! bv 0 argument (endianness big))
- (display bv)
- (bytevector-ieee-double-ref bv 0 (endianness big))))
-
- ((31) 'break)
-
- ;; TODO error handling
- (else 'not-well-formed))))))
diff --git a/cbor/encode.scm b/cbor/encode.scm
deleted file mode 100644
index 2e083a3..0000000
--- a/cbor/encode.scm
+++ /dev/null
@@ -1,128 +0,0 @@
-; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
-;
-; SPDX-License-Identifier: GPL-3.0-or-later
-
-(define-module (cbor encode)
- #:use-module (rnrs arithmetic bitwise)
- #:use-module (rnrs base)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
-
- #:use-module (cbor tag)
- #:use-module (cbor indefinite-length)
-
- #:export (put-cbor-data-item))
-
-(define (put-cbor-initial-byte port major-type additional-info)
- (put-u8 port
- (bitwise-ior
- ;; shift major-type to upper 3 bits
- (bitwise-arithmetic-shift major-type 5)
- additional-info)))
-
-(define (put-uint-network-order port uint size)
- (let ((bv (make-bytevector size)))
- (bytevector-uint-set! bv 0 uint (endianness big) size)
- (put-bytevector port bv)))
-
-(define (put-cbor-integer port major-type uint)
- (let ((arg-length (ceiling-quotient (integer-length uint) 8)))
- (cond
- ;; directly encode value in additional info
- ((< uint 24)
- (put-cbor-initial-byte port major-type uint))
-
- ;; fits in one byte
- ((<= arg-length 1)
- (put-cbor-initial-byte port major-type 24)
- (put-uint-network-order port uint 1))
-
- ((<= arg-length 2)
- (put-cbor-initial-byte port major-type 25)
- (put-uint-network-order port uint 2))
-
- ((<= arg-length 4)
- (put-cbor-initial-byte port major-type 26)
- (put-uint-network-order port uint 4))
-
- ((<= arg-length 8)
- (put-cbor-initial-byte port major-type 27)
- (put-uint-network-order port uint 8))
-
- ;; TODO error integer out of bound
- (else 'oops))))
-
-(define (put-cbor-indefinite-length port value)
- (cond
-
- ;; Indefinite-length array
- ((vector? value)
- (put-cbor-initial-byte port 4 31)
- (vector-for-each (lambda (sub-value)
- (put-cbor-data-item port sub-value))
- value)
- (put-cbor-initial-byte port 7 31))
-
- ;; Indefinite-length map
- ((list? value)
- (put-cbor-initial-byte port 5 31)
- (for-each (lambda (key-value)
- (put-cbor-data-item port (car key-value))
- (put-cbor-data-item port (cdr key-value)))
- value)
- (put-cbor-initial-byte port 7 31))))
-
-(define (put-cbor-data-item port value)
- (cond
-
- ;; unsigned integer
- ((and (exact-integer? value) (<= 0 value))
- (put-cbor-integer port 0 value))
-
- ;; negative integer
- ((and (exact-integer? value) (> 0 value))
- (put-cbor-integer port 1 (- -1 value)))
-
- ((bytevector? value)
- (put-cbor-integer port 2 (bytevector-length value))
- (put-bytevector port value))
-
- ((string? value)
- (let ((as-bytes (string->utf8 value)))
- (put-cbor-integer port 3 (bytevector-length as-bytes))
- (put-bytevector port as-bytes)))
-
- ((vector? value)
- (put-cbor-integer port 4 (vector-length value))
- (vector-for-each (lambda (sub-value)
- (put-cbor-data-item port sub-value))
- value))
-
- ((list? value)
- (put-cbor-integer port 5 (length value))
- (for-each (lambda (key-value)
- (put-cbor-data-item port (car key-value))
- (put-cbor-data-item port (cdr key-value)))
- value))
-
- ((cbor-tag? value)
- (put-cbor-integer port 6 (cbor-tag-number value))
- (put-cbor-data-item port (cbor-tag-content value)))
-
- ((cbor-indefinite-length? value)
- (put-cbor-indefinite-length port (cbor-indefinite-length-value value)))
-
- ((real? value)
- (let ((bv (make-bytevector 8)))
- (put-cbor-initial-byte port 7 27)
- (bytevector-ieee-double-set! bv 0 value (endianness big))
- (put-bytevector port bv)))
-
- ((equal? value #f)
- (put-cbor-initial-byte port 7 20))
-
- ((equal? value #t)
- (put-cbor-initial-byte port 7 21))
-
- ((nil? value)
- (put-cbor-initial-byte port 7 22))))
diff --git a/cbor/indefinite-length.scm b/cbor/indefinite-length.scm
deleted file mode 100644
index 38a12ea..0000000
--- a/cbor/indefinite-length.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
-;
-; SPDX-License-Identifier: GPL-3.0-or-later
-
-(define-module (cbor indefinite-length)
- #:use-module (srfi srfi-9)
-
- #:export (<cbor-indefinite-length>
- make-cbor-indefinite-length
- cbor-indefinite-length?
- cbor-indefinite-length-value))
-
-(define-record-type <cbor-indefinite-length>
- (make-cbor-indefinite-length value)
- cbor-indefinite-length?
- (value cbor-indefinite-length-value))
diff --git a/cbor/tag.scm b/cbor/tag.scm
deleted file mode 100644
index 94bb37a..0000000
--- a/cbor/tag.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
-;
-; SPDX-License-Identifier: GPL-3.0-or-later
-
-(define-module (cbor tag)
- #:use-module (srfi srfi-9)
-
- #:export (<cbor-tag>
- make-cbor-tag
- cbor-tag?
- cbor-tag-number
- cbor-tag-content))
-
-(define-record-type <cbor-tag>
- (make-cbor-tag number content)
- cbor-tag?
- (number cbor-tag-number)
- (content cbor-tag-content))
-
diff --git a/hall.scm b/hall.scm
index 4aa057a..4e732bd 100644
--- a/hall.scm
+++ b/hall.scm
@@ -12,11 +12,7 @@ Object Representation (CBOR) as defined by RFC 8949.")
(license gpl3+)
(dependencies `())
(files (libraries
- ((scheme-file "cbor")
- (directory "cbor" ((scheme-file "decode")
- (scheme-file "encode")
- (scheme-file "tag")
- (scheme-file "indefinite-length")))))
+ ((scheme-file "cbor")))
(tests ((directory "tests" ((scheme-file "cbor")))))
(programs ((directory "scripts" ())))
(documentation
diff --git a/tests/cbor.scm b/tests/cbor.scm
index 4180245..953b388 100644
--- a/tests/cbor.scm
+++ b/tests/cbor.scm
@@ -4,8 +4,6 @@
(define-module (tests cbor)
#:use-module (cbor)
- #:use-module (cbor indefinite-length)
- #:use-module (cbor tag)
#:use-module (rnrs bytevectors)