-
Notifications
You must be signed in to change notification settings - Fork 6
/
erlenmeyer.scm
158 lines (138 loc) · 5.74 KB
/
erlenmeyer.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
(module erlenmeyer mzscheme
(require (lib "foreign.ss")
(lib "match.ss")) (unsafe!)
(provide for-each-erlang-packet
read-next-packet
fd->input-port
fd->output-port)
; The all-important fd->input port code thanks to Matthew Flatt
(define (fd->input-port fd name)
(scheme_make_fd_input_port fd name 0 0))
(define (fd->output-port fd name)
(scheme_make_fd_output_port fd name 0 0 0))
(define scheme_make_fd_input_port
(get-ffi-obj "scheme_make_fd_input_port" #f
(_fun _int _scheme _int _int -> _scheme)))
(define scheme_make_fd_output_port
(get-ffi-obj "scheme_make_fd_output_port"
#f
(_fun _int _scheme _int _int _int -> _scheme)))
; We'll start with the standard ports
(define erlang-input-port (fd->input-port 3 'erlang-in))
(define erlang-output-port (fd->output-port 4 'erlang-out))
; Data conversion functions
(define ERL_MAGIC_NUMBER #"\203")
(define ERL_SMALL_INT 97)
(define ERL_INT 98)
(define ERL_SMALL_BIGNUM 110)
(define ERL_LARGE_BIGNUM 111)
(define ERL_FLOAT 99)
(define ERL_ATOM 100)
(define ERL_REF 101)
(define ERL_NEW_REF 114)
(define ERL_PORT 102)
(define ERL_PID 103)
(define ERL_SMALL_TUPLE 104)
(define ERL_LARGE_TUPLE 105)
(define ERL_NIL 106)
(define ERL_STRING 107)
(define ERL_LIST 108)
(define ERL_BIN 109)
(define ERL_FUN 117)
(define ERL_NEW_FUN 112)
; Reading primitives
(define (read-stream n) (read-bytes n erlang-input-port))
(define (read-stream-i n)
(let ([data (read-bytes n erlang-input-port)])
(cond
([eof-object? data] (raise 'unexpected-eof))
(else data))))
; Frequently used functions in erlang binary takes a single unsigned byte and maps it to an int.
(define (byte->uint byte)
(integer-bytes->integer (bytes-append #"\0" byte) #f #t))
(define (bytes->int bytes)
(integer-bytes->integer bytes #t #t))
; Specification language macro
(define-syntax define-binary-parser
(syntax-rules ()
[(_ name (byte-value processor-spec) ...)
(define name
(lambda (bytes)
(let ([identifier (bytes-ref bytes 0)]
[dbytes (subbytes bytes 1)])
(let-syntax ((xform
(syntax-rules (small large custom ->)
[(_ (small -> byte-converter)) (parse-sized-entity dbytes 2 byte-converter)]
[(_ (large -> byte-converter)) (parse-sized-entity dbytes 4 byte-converter)]
[(_ (number -> byte-converter)) (parse-raw-entity dbytes number byte-converter)]
[(_ (custom raw-byte-converter)) (raw-byte-converter dbytes)])))
(fprintf (current-error-port) "In term parser! Bytes: ~s~n" bytes)
(cond
[(equal? identifier byte-value)
(fprintf (current-error-port) "Matched ~s to ~s~n" identifier byte-value)
(xform processor-spec)] ...
[else (raise `(unknown-data-type ,identifier ,bytes))])))))]))
; Data mappers
(define-binary-parser erlang-term-parser
[ERL_SMALL_INT (1 -> byte->uint)]
[ERL_INT (4 -> bytes->int)]
[ERL_ATOM (small -> (lambda (bytes) (string->symbol (bytes->string/utf-8 bytes))))]
[ERL_STRING (small -> (lambda (bytes) (bytes->string/utf-8 bytes)))]
[ERL_BIN (large -> (lambda (x) x))]
[ERL_NIL (custom (lambda (x) '()))]
[ERL_LIST (custom list-parser)]
[ERL_SMALL_TUPLE (custom small-tuple-parser)]
)
; Recursive datatype parsers
; Tuples
(define (repeat-parser dbytes size-field-size size-field-converter finalizer)
(let* [(sbytes (subbytes dbytes 0 size-field-size))
(ebytes (subbytes dbytes size-field-size))
(nelems (size-field-converter sbytes))]
(let loop ([b ebytes] [c nelems] [accum (list)])
(cond ((equal? c 0) (cons (finalizer (reverse accum)) b))
(else
(match-let [((val . rbytes) (erlang-term-parser b))]
(loop rbytes (sub1 c) (cons val accum))))))))
(define (small-tuple-parser dbytes) (repeat-parser dbytes 1 byte->uint (lambda (x) (list->vector x))))
(define (large-tuple-parser dbytes) (repeat-parser dbytes 4 bytes->int (lambda (x) (list->vector x))))
(define (list-parser dbytes)
(match-let [((val . rbytes) (repeat-parser dbytes 4 bytes->int (lambda (x) x)))]
(cons val (subbytes rbytes 1)))) ; Skip the trailing nil in lists.
; Parser helpers
(define (parse-raw-entity bytes size processor)
(let [(rem-bytes (subbytes bytes size))
(data-bytes (subbytes bytes 0 size))]
(cons (processor data-bytes) rem-bytes)))
(define (parse-sized-entity bytes size-field-length processor)
(let* [(sizebytes (subbytes bytes 0 size-field-length))
(size (integer-bytes->integer sizebytes #f #t))]
(parse-raw-entity (subbytes bytes size-field-length) size processor)))
(define (read-size-field)
(let ([size-bytes (read-stream 4)])
(cond
[(eof-object? size-bytes) size-bytes]
[else (integer-bytes->integer size-bytes #f #t)])))
(define (read-magic-number)
(let ([mnum (read-stream-i 1)])
(unless (equal? ERL_MAGIC_NUMBER mnum)
(raise `(bad-magic ,mnum)))
mnum))
(define (read-record size)
(let* ([mnum (read-magic-number)]
[data-bytes (read-stream-i (sub1 size))])
(fprintf (current-error-port) "RECORD (~s): ~s~n" mnum data-bytes)
(erlang-term-parser data-bytes)))
(define (read-next-packet)
(let ([size-record (read-size-field)])
(cond
[(eof-object? size-record) (cons size-record #"")]
[else (read-record size-record)])))
(define (for-each-erlang-packet lam)
(display "Waiting on packet to read.\n")
(match-let ([(packet . rembytes) (read-next-packet)])
(cond
[(eof-object? packet) packet]
[(> (bytes-length rembytes) 0) (raise `(unknown-extra-data ,rembytes ,packet))]
[else (lam packet) (for-each-erlang-packet lam)])))
) ; End module