macro version of constraints
[packedobjects:packedobjects.git] / src / packedobjects.scm
1 (define-module (packedobjects))
2 (export make-buffer make-buffer-from-string pdu-from-buffer make-encoder make-decoder)
3
4 (export integer-constraint string-constraint)
5
6 (load-extension "libpackedobjects.so" "init_packedobjects")
7
8 (use-modules (srfi srfi-1))
9 (use-modules (ice-9 syncase))
10
11 (define constraints:lb cadr)
12 (define constraints:ub caddr)
13
14
15 (define-syntax integer-constraint
16   (syntax-rules (range min max)
17     ((_ ())
18       'unconstrained)
19     ((_ (range min max))
20       'unconstrained)
21     ((_ (range min ub))
22       'signed-semi-constrained)
23     ((_ (range lb max))
24       (if (negative? lb)
25         'signed-semi-constrained
26         'unsigned-semi-constrained))
27     ((_ (range lb ub))
28       (if (negative? lb)
29         'signed-constrained
30         'unsigned-constrained))))
31
32 (define (po:check-integer range)
33   (primitive-eval (cons 'integer-constraint `(,range))))
34
35
36 (define-syntax string-constraint
37   (syntax-rules (size min max)
38     ((_ ())
39       'semi-constrained)
40     ((_ (size min max))
41       'semi-constrained)
42     ((_ (size min ub))
43       'constrained)
44     ((_ (size lb max))
45       'semi-constrained)
46     ((_ (size lb ub))
47       'constrained)
48     ((_ (size bound))
49       'fixed-length)))
50
51 (define (po:check-string size)
52   (primitive-eval (cons 'string-constraint `(,size))))
53
54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55
56 (define-macro (first-string s)
57   `(string-ref ,s 0))
58 (define-macro (rest-string s)
59   `(string-drop ,s 1))
60
61 (define encode:datatype cadar)
62 (define encode:value cadr)
63 (define encode:constraint caddar) 
64
65 (define (po:encode t p)
66   
67   (define (encode-simple-type)
68     
69     (define (encode-integer)
70       (let* ( (range (encode:constraint t)) (type (po:check-integer range)) )
71         (case type
72           ((unconstrained)
73            (encode-unconstrained-integer p (encode:value t)))
74           ((unsigned-semi-constrained)
75            (encode-unsigned-semi-constrained-integer p (encode:value t) (constraints:lb range)))
76           ((unsigned-constrained)
77            (encode-unsigned-constrained-integer p (encode:value t) (constraints:lb range) (constraints:ub range)))
78           ((signed-semi-constrained)
79            (encode-signed-semi-constrained-integer p (encode:value t) (constraints:lb range)))
80           ((signed-constrained)
81            (encode-signed-constrained-integer p (encode:value t) (constraints:lb range) (constraints:ub range))))))
82     
83     (define (encode-string)
84       (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
85         (case type
86           ((semi-constrained)
87            (encode-semi-constrained-string p (encode:value t)))
88           ((fixed-length)
89            (encode-fixed-length-string p (encode:value t) (constraints:lb size)))
90           ((constrained)
91            (let ((lbv (constraints:lb size)))
92              (encode-constrained-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))
93     
94     (define (encode-octet-string)
95       (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
96         (case type
97           ((semi-constrained)
98            (encode-semi-constrained-octet-string p (encode:value t)))
99           ((fixed-length)
100            (encode-fixed-length-octet-string p (encode:value t) (constraints:lb size)))
101           ((constrained)
102            (let ((lbv (constraints:lb size)))
103              (encode-constrained-octet-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))
104     
105     (define (encode-hex-string)
106       (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
107         (case type
108           ((semi-constrained)
109            (encode-semi-constrained-hex-string p (encode:value t)))
110           ((fixed-length)
111            (encode-fixed-length-hex-string p (encode:value t) (constraints:lb size)))
112           ((constrained)
113            (let ((lbv (constraints:lb size)))
114              (encode-constrained-hex-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))    
115
116     (define (encode-numeric-string)
117       (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
118         (case type
119           ((semi-constrained)
120            (encode-semi-constrained-numeric-string p (encode:value t)))
121           ((fixed-length)
122            (encode-fixed-length-numeric-string p (encode:value t) (constraints:lb size)))
123           ((constrained)
124            (let ((lbv (constraints:lb size)))
125              (encode-constrained-numeric-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))) 
126
127     
128     (define (encode-bit-string)
129         (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
130           (case type
131             ((semi-constrained)
132              (encode-semi-constrained-bit-string p (encode:value t)))
133             ((fixed-length)
134              (encode-fixed-length-bit-string p (encode:value t) (constraints:lb size)))
135             ((constrained)
136              (let ((lbv (constraints:lb size)))
137                (encode-constrained-bit-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))    
138       
139       
140       (define (encode-boolean-type)
141         (encode-boolean p (encode:value t)))
142       
143       (define (encode-enumerated-type)
144         (let* ((enum (caddar t))
145                (enum-len (length enum))
146                (index (list-index (lambda (x) (eq? x (encode:value t))) enum)))
147           (if index
148               (encode-enumerated p index enum-len)
149               (error "enumeration failed" (encode:value t) enum))))
150
151       (define (encode-null)
152         'do-nothing)
153       
154       (let ((type (encode:datatype t)))
155         (case type
156           ((integer)
157            (encode-integer))
158           ((boolean)
159            (encode-boolean-type))
160           ((octet-string)
161            (encode-octet-string))
162           ((hex-string)
163            (encode-hex-string))
164           ((numeric-string)
165            (encode-numeric-string))
166           ((bit-string)
167            (encode-bit-string))
168           ((enumerated)
169            (encode-enumerated-type))
170           ((null)
171            (encode-null))
172           ((string)
173            (encode-string)))))
174   
175   
176   (define (encode-complex-type)
177     (define (recur-sequence seq)
178       (cond ((null? seq) 'done-sequence)
179             (else
180              (po:encode (car seq) p)
181              (recur-sequence (cdr seq)))))
182     
183     (define (recur-sequence-of seq)
184       (cond ((null? seq) 'done-sequence-of)
185             (else
186              (recur-sequence (car seq))
187              (recur-sequence-of (cdr seq)))))     
188     (define (encode-sequence)
189       (recur-sequence (cdr t)))
190     (define (encode-sequence-of)
191       (encode-sequence-of-length p (caddar t))
192       (recur-sequence-of (cdr t)))  
193     
194     (define (encode-set)
195       (define (recur-set bit order)
196         (cond ((null? order) 'done-set)
197               (else
198                (cond ((eq? (first-string bit) #\1)
199                       (let ((v (find (lambda (x) (eq? (caar x) (car order))) (cdr t))))
200                         (po:encode v p))
201                       (recur-set (rest-string bit) (cdr order)))
202                      (else
203                       (recur-set (rest-string bit) (cdr order)))))))
204       
205       ;; obtain the ordering list
206       (let* ((order-by (cdr (caddr (car t))))
207              (bitmap  (cadddr (car t))))
208         (encode-set-bitmap p bitmap (string-length bitmap))
209         (recur-set bitmap order-by)))      
210     
211     (define (encode-choice)
212       ;; range of choices in spec (range 1 n)
213       (encode-choice-index p (car (cdddar t)) (caddr (caddar t)))
214       (po:encode (cadr t) p))
215
216     ;; end of definitions
217
218     (let ((type (encode:datatype t)))
219       (case type
220         ((sequence)
221           (encode-sequence))
222         ((sequence-of)
223          (encode-sequence-of))
224         ((set)
225          (encode-set))
226         ((choice)
227          (encode-choice)))))
228   
229   (if (memq (encode:datatype t) '(sequence choice sequence-of set))
230       (encode-complex-type)
231       (encode-simple-type)))
232
233
234 (define decode:datatype cadr)
235 (define decode:name car)
236 (define decode:constraint caddr)
237
238
239 (define (po:decode t p)
240   
241   (define (decode-simple-type)
242     
243     (define (decode-integer)
244       (let* ( (range (decode:constraint t)) (type (po:check-integer range)) )
245         (case type
246           ((unconstrained)
247            (list (decode:name t) (decode-unconstrained-integer p)))
248           ((unsigned-semi-constrained)
249            (list (decode:name t) (decode-unsigned-semi-constrained-integer p (constraints:lb range))))
250           ((unsigned-constrained)
251            (list (decode:name t) (decode-unsigned-constrained-integer p (constraints:lb range) (constraints:ub range))))
252           ((signed-semi-constrained)
253            (list (decode:name t) (decode-signed-semi-constrained-integer p (constraints:lb range))))
254           ((signed-constrained)
255            (list (decode:name t) (decode-signed-constrained-integer p (constraints:lb range) (constraints:ub range)))))))
256     
257     (define (decode-string)
258       (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
259         (case type
260           ((semi-constrained)
261            (list (decode:name t) (decode-semi-constrained-string p)))
262           ((fixed-length)
263            (list (decode:name t) (decode-fixed-length-string p (constraints:lb size))))
264           ((constrained)
265            (let ((lbv (constraints:lb size)))
266              (list (decode:name t) (decode-constrained-string p (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
267     
268     (define (decode-octet-string)
269       (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
270         (case type
271           ((semi-constrained)
272            (list (decode:name t) (decode-semi-constrained-octet-string p)))
273           ((fixed-length)
274            (list (decode:name t) (decode-fixed-length-octet-string p (constraints:lb size))))
275           ((constrained)
276            (let ((lbv (constraints:lb size)))
277              (list (decode:name t) (decode-constrained-octet-string p (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
278     
279     (define (decode-hex-string)
280       (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
281         (case type
282           ((semi-constrained)
283            (list (decode:name t) (decode-semi-constrained-hex-string p)))
284           ((fixed-length)
285            (list (decode:name t) (decode-fixed-length-hex-string p (constraints:lb size))))
286           ((constrained)
287            (let ((lbv (constraints:lb size)))
288              (list (decode:name t) (decode-constrained-hex-string p (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
289     
290     (define (decode-numeric-string)
291       (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
292         (case type
293           ((semi-constrained)
294            (list (decode:name t) (decode-semi-constrained-numeric-string p)))
295           ((fixed-length)
296            (list (decode:name t) (decode-fixed-length-numeric-string p (constraints:lb size))))
297           ((constrained)
298            (let ((lbv (constraints:lb size)))
299              (list (decode:name t) (decode-constrained-numeric-string p (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
300     
301     (define (decode-bit-string)
302       (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
303         (case type
304           ((semi-constrained)
305            (list (decode:name t) (decode-semi-constrained-bit-string p)))
306           ((fixed-length)
307            (list (decode:name t) (decode-fixed-length-bit-string p (constraints:lb size))))
308           ((constrained)
309            (let ((lbv (constraints:lb size)))
310              (list (decode:name t) (decode-constrained-bit-string p (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
311     
312     (define (decode-boolean-type)
313       (list (decode:name t) (decode-boolean p)))
314     
315     (define (decode-enumerated-type)
316       (list (decode:name t) (list-ref (caddr t) (decode-enumerated p (length (caddr t))))))
317     
318     (define (decode-null)
319       (list (decode:name t)))
320     
321     (let ((type (decode:datatype t)))
322       (case type
323         ((integer)
324          (decode-integer))
325         ((boolean)
326          (decode-boolean-type))
327         ((octet-string)
328          (decode-octet-string))
329         ((hex-string)
330          (decode-hex-string))
331         ((numeric-string)
332          (decode-numeric-string))
333         ((bit-string)
334          (decode-bit-string))
335         ((enumerated)
336          (decode-enumerated-type))
337         ((null)
338          (decode-null))
339         ((string)
340          (decode-string)))))
341   
342   (define (decode-complex-type)
343     
344     (define (decode-choice)
345       (let ((index (decode-choice-index p (length (cddr t)))))
346         (cons
347          (car t)
348          (list (po:decode (list-ref (cddr t) (- index 1)) p)))))
349     
350     (define (recur-sequence seq)
351       (cond ((null? seq) '())
352             (else
353              (cons
354               (po:decode (car seq) p)
355               (recur-sequence (cdr seq)))))) 
356     
357     (define (decode-sequence-of)      
358       (define (recur-sequence-of n)
359         (cond ((< n 1) '())
360               (else
361                (cons
362                 (recur-sequence (cddr t))
363                 (recur-sequence-of (- n 1))))))
364       (let ((length (decode-sequence-of-length p)))
365         (cons (car t) (recur-sequence-of length))))
366     
367     
368     (define (decode-sequence)
369       (cons (car t) (recur-sequence (cddr t))))
370     
371     (define (decode-set)
372       (define (recur-set seq bitmap)
373         (cond ((null? seq) '())
374               (else
375                (cond ((eq? (first-string bitmap) #\0)
376                       (recur-set (cdr seq) (rest-string bitmap)))
377                      (else 
378                       (cons
379                        (po:decode (car seq) p) 
380                        (recur-set (cdr seq) (rest-string bitmap))))))))
381       (let* ((bitmap-len (length (cddr t)))
382              (bitmap (decode-set-bitmap p bitmap-len)))
383         (cons (car t) (recur-set (cddr t) bitmap))))   
384     
385     (let ((type (decode:datatype t)))
386       (case type
387         ((choice)
388          (decode-choice))
389         ((sequence)
390          (decode-sequence))
391         ((set)
392          (decode-set))
393         ((sequence-of)
394          (decode-sequence-of)))))
395   
396   (if (memq (decode:datatype t) '(sequence choice sequence-of set))
397       (decode-complex-type)
398       (decode-simple-type)))
399
400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
401
402
403 ;; returns part of tree according to search path or #f path not found
404 (define (po:subtree tree path)
405   (let loop ((t tree) (p (cdr path)))
406     (if (null? p)
407         t
408         (loop (assq (car p) (cddr t)) (cdr p)))))
409
410
411 ;; convenience macro
412 (define-macro (list-position alis atom)
413   `(list-index (lambda (_x) (eq? _x ,atom)) ,alis))
414
415 (define (add1 x) (+ x 1))
416
417 (define simple-types 
418   '(integer string boolean enumerated null octet-string bit-string hex-string numeric-string))
419
420 ;; extra information the encode procedure requires about some types
421 (define (make-metadata protocol path the-values)
422   (let ((t (po:subtree protocol path)))
423     (if t 
424         (let ((dt (cadr t)))
425           (cond ((memq dt simple-types) 
426                  t) 
427                 ((eq? dt 'sequence)
428                  (list (car t) dt))
429                 ((eq? dt 'sequence-of)
430                  (list (car t) dt (length (cdr the-values))))
431                 ((eq? dt 'choice)
432                  (let* ((l (map (lambda (x) (car x)) (cddr t)))
433                         (v (caadr the-values))
434                         (index (list-position l v)))
435                    (if index
436                        (list (car t) dt (append '(range 1) (list (length l))) (add1 index))
437                        (error "choice failed" v))))
438                 ((eq? dt 'set)
439                  (let* ((items (cddr t))
440                         (s (make-string (length items) #\1))
441                         (l1 (map (lambda (x) (car x)) items))
442                         (l2 (map (lambda (x) (car x)) (cdr the-values)))
443                         (d1 (lset-difference eq? l1 l2))
444                         ;; difference in terms of position
445                         (d2 (map (lambda (x) (list-position l1 x)) d1)))
446                    (for-each (lambda (x) (string-set! s x #\0)) d2)
447                    (list (car t) dt (append '(order-by) l1) s)))
448                 (else
449                  (error "invalid datatype" dt))))                    
450         (error "lookup failed" path))))
451
452 (define (add-metadata protocol the-values)
453   (let loop ((tree the-values) (parent '()))
454     (cond ((null? tree) '())
455           ((not (pair? tree)) tree)
456           ((symbol? (car tree))
457            (let* ((path (append parent (list (car tree))))
458                   (metadata (make-metadata protocol path tree))
459                   (type (cadr metadata)))
460              (if (memq type '(sequence choice null sequence-of set))
461                  (cons metadata (loop (cdr tree) path))
462                  ;; used for types that have a value
463                  (cons metadata
464                        (cons (cadr tree) ;; the value
465                              (loop (cddr tree) path))))))
466           (else
467            (cons (loop (car tree) parent) (loop (cdr tree) parent))))))
468
469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
470
471
472
473 (define (make-encoder buffer protocol)
474   (define kernel (initialize-encode buffer))
475   
476   (define (pack-pdu data)
477     (po:encode (add-metadata protocol data) kernel)
478     (finalize-encode kernel))
479   
480   (define (get-pdu bytes)
481     (pdu-from-buffer buffer bytes))
482   
483   (define (self msg . args)
484     (case msg
485       ((pack) (pack-pdu (car args)))
486       ((pdu) (get-pdu (car args)))
487       ((meta) (add-metadata protocol (car args)))
488       (else (error "invalid msg"))))
489
490   ;; return self
491   self)
492
493 (define (make-decoder buffer protocol)
494   (define kernel (initialize-decode buffer))
495   
496   (define (unpack-pdu)
497     (po:decode protocol kernel))
498   
499   (define (self msg . args)
500     (case msg
501       ((unpack) (unpack-pdu))
502       (else (error "invalid msg"))))
503
504   ;; return self
505   self)  
506   
507