diff options
| -rw-r--r-- | ebus-racket/README | 3 | ||||
| -rw-r--r-- | ebus-racket/doc/sample_dump_2.bin | bin | 0 -> 196608 bytes | |||
| -rwxr-xr-x | ebus-racket/dumper.rkt | 6 | ||||
| -rw-r--r-- | ebus-racket/ebus/layer7.rkt | 142 |
4 files changed, 80 insertions, 71 deletions
diff --git a/ebus-racket/README b/ebus-racket/README new file mode 100644 index 0000000..c64cdc1 --- /dev/null +++ b/ebus-racket/README @@ -0,0 +1,3 @@ + +git clone https://github.com/mordae/racket-xexpr-path.git +raco pkg install racket-xexpr-path/ diff --git a/ebus-racket/doc/sample_dump_2.bin b/ebus-racket/doc/sample_dump_2.bin Binary files differnew file mode 100644 index 0000000..f88a9c6 --- /dev/null +++ b/ebus-racket/doc/sample_dump_2.bin diff --git a/ebus-racket/dumper.rkt b/ebus-racket/dumper.rkt index bc60590..62ca64e 100755 --- a/ebus-racket/dumper.rkt +++ b/ebus-racket/dumper.rkt @@ -38,9 +38,9 @@ (define (read-ebus-loop7 input-port) (let ([fields (layer7-read-ebus (current-input-port))]) - (if (not (void? fields)) - (pretty-print fields) - (display "")) + ;(if (not (void? fields)) + ;(pretty-print fields) + ;(display "")) (cond ((not (eof-object? fields)) (read-ebus-loop7 input-port))))) (if (layer7?) diff --git a/ebus-racket/ebus/layer7.rkt b/ebus-racket/ebus/layer7.rkt index cb9da0b..9393ec8 100644 --- a/ebus-racket/ebus/layer7.rkt +++ b/ebus-racket/ebus/layer7.rkt @@ -1,80 +1,85 @@ #lang racket/base -(require (planet clements/sxml2:1:=3) - "layer2.rkt") +(require + racket/bool + racket/function + xml + xexpr-path + "layer2.rkt") (define logger (make-logger 'ebus-layer7 (current-logger))) (define definition - (ssax:xml->sxml (open-input-file "../ebus-xml/ebus.xml") - '[(#f . "http://xapek.org/ebus/0.1")])) + (parameterize ([collapse-whitespace #t] + [xexpr-drop-empty-attributes #t]) + (xml->xexpr (document-element (read-xml (open-input-file "../ebus-xml/ebus.xml")))))) (define (paket ebus-paket) - (define primaryCommand (layer2-ebus-paket-primaryCommand ebus-paket)) - (define secondaryCommand (layer2-ebus-paket-secondaryCommand ebus-paket)) - ((sxpath (string-append "//packet[@primary=" (number->string primaryCommand) - " and @secondary=" (number->string secondaryCommand) "]")) - definition)) + (define primaryCommand (number->string (layer2-ebus-paket-primaryCommand ebus-paket))) + (define secondaryCommand (number->string (layer2-ebus-paket-secondaryCommand ebus-paket))) + (xexpr-path-first (list 'packets 'packet (list 'primary primaryCommand) + (list 'secondary secondaryCommand)) definition)) + +(define (paket-name xexpr) + (xexpr-path-first '((name)) xexpr)) + +(define (paket-fields paket-definition) + (filter + (lambda (i) (and (pair? i) (member (car i) '(bit bcd data1b data1c byte data2b data2c word byteEnum)))) + (xexpr-path-list '(fields *) paket-definition))) ;; returns the full device-definition (define (device address) - ((sxpath (string-append "//devices/device[@address=" (number->string address) "]")) - definition)) + (xexpr-path-first (list 'devices 'device (list 'address (number->string address))) definition)) ;; returns device-name in a list or empty-list (define (device-name address) - (car ((sxpath "@name/text()") (device address)))) + (xexpr-path-first (list 'devices 'device (list 'address (number->string address)) '(name)) definition)) -(define (paket-fields ebus-paket) +(define (paket-parse ebus-paket) (define paket-definition (paket ebus-paket)) - (cond ((> (length paket-definition) 0) - (let* - ([paket-name (string-append - (device-name (layer2-ebus-paket-source ebus-paket)) - "." - (car ((sxpath "@name/text()") paket-definition)))] - [fields ((sxpath "fields/*") paket-definition)] - [values - (for/list ([field fields]) (paket-fields-dispatch-decoder ebus-paket field paket-name))]) - ;; filter invalid values - (for/list ([value values] #:when (not (void? value))) - value))) - (else (void (log-message logger 'warning (format "Unknown Paket: ~s" ebus-paket) #t))))) - -(define (paket-fields-dispatch-decoder ebus-paket field paket-name) - (define datatype ((sxpath "name()") field)) - (define name (string-append paket-name "." (car ((sxpath "@name/text()") field)))) - (define offset (string->number (car ((sxpath "@offset/text()") field)))) - (define payload (layer2-ebus-paket-payload ebus-paket)) - (cond ((string=? "bit" datatype) - (list name datatype offset - (field-decoder-bit (list-ref payload offset)))) - ((string=? "bcd" datatype) - (list name datatype offset - (field-decoder-bcd (list-ref payload offset)))) - ((string=? "data1b" datatype) - (list name datatype offset - (field-decoder-data1b (list-ref payload offset)))) - ((string=? "data1c" datatype) - (list name datatype offset - (field-decoder-data1c (list-ref (layer2-ebus-paket-payload ebus-paket) offset)))) - ((string=? "byte" datatype) - (list name datatype offset (list-ref payload offset))) - ((string=? "data2b" datatype) - (list name datatype offset - (field-decoder-data2b (list-ref payload offset) - (list-ref payload (+ offset 1))))) - ((string=? "data2c" datatype) - (list name datatype offset - (field-decoder-data2c (list-ref payload offset) - (list-ref payload (+ offset 1))))) - ((string=? "word" datatype) - (list name datatype offset - (field-decoder-word (list-ref payload offset) - (list-ref payload (+ offset 1))))) - ((string=? "byteEnum" datatype) - (list name datatype offset - (field-decoder-byteEnum (list-ref payload offset) field))) - (else (void (log-message logger 'error (format "unknown datatype: ~a" datatype) #t))))) + (define source-device-name (device-name (layer2-ebus-paket-source ebus-paket))) + (cond ((and (not (false? paket-definition)) (not (false? source-device-name))) + (define paket-id (string-append source-device-name "." (paket-name paket-definition))) + (define decoders (map (lambda (field) (create-decoder paket-id field)) (paket-fields paket-definition))) + (define payload (layer2-ebus-paket-payload ebus-paket)) + (for/list ([decoder decoders]) + (decoder payload))) + (else (void (log-message logger 'warning + (format "Unknown Paket from source ~s: ~s" (layer2-ebus-paket-source ebus-paket) ebus-paket) #t))))) + + +(define (create-decoder paket-id field) + (define type (car field)) + (define name (string-append paket-id "." (xexpr-path-first '((name)) field))) + (define offset (string->number (xexpr-path-first '((offset)) field))) + (define decoder (hash-ref decoder-table type #f)) + (cond ((false? decoder) (void (log-message logger 'warning (format "No decoder for type ~s" type)))) + (else (curry (car decoder) name field offset)))) + +(define decoder-table + (make-hash (list + (list 'bit (lambda (name field offset payload) + (list name 'bit (field-decoder-bit (list-ref payload offset))))) + (list 'bcd (lambda (name field offset payload) + (list name 'bcd (field-decoder-bcd (list-ref payload offset))))) + (list 'data1b (lambda (name field offset payload) + (list name 'data1b (field-decoder-data1b (list-ref payload offset))))) + (list 'data1c (lambda (name field offset payload) + (list name 'data1b (field-decoder-data1c (list-ref payload offset))))) + (list 'byte (lambda (name field offset payload) + (list name 'byte offset (list-ref payload offset)))) + (list 'data2b (lambda (name field offset payload) + (list name 'data2b (field-decoder-data2b + (list-ref payload offset) + (list-ref payload (+ offset 1)))))) + (list 'data2c (lambda (name field offset payload) + (list name 'data2c offset + (field-decoder-data2c (list-ref payload offset) (list-ref payload (+ offset 1)))))) + (list 'word (lambda (name field offset payload) + (list name 'word (field-decoder-word (list-ref payload offset) (list-ref payload (+ offset 1)))))) + (list 'byteEnum (lambda (name field offset payload) + (list name 'byteEnum (field-decoder-byteEnum (list-ref payload offset) field)))) + ))) ;; type bit (define (field-decoder-bit value) @@ -128,13 +133,13 @@ (define (field-decoder-byteEnum value field-definition) (define (pred l) (= value (list-ref l 0))) - (define all-options (for/list ([option ((sxpath "option") field-definition)]) - (list (string->number (car ((sxpath "@value/text()") option))) ;; value, name - (car ((sxpath "@name/text()") option))))) + (define all-options (for/list ([option (xexpr-path-list '(option) field-definition)]) + (list (string->number (xexpr-path-first '((value)) option)) ;; '(value name) + (xexpr-path-first '((name)) option)))) (define options (filter pred all-options)) (cond ((= (length options) 1) (list-ref (car options) 1)) - (else "<undefined>"))) + (else (format "<undefined:~a>" value)))) ;; type word (define (field-decoder-word lowByte highByte) @@ -151,13 +156,14 @@ (define (read-ebus input-port) (define paket (layer2-read-ebus input-port)) (cond ((layer2-ebus-paket? paket) - (paket-fields paket)) + (paket-parse paket)) (else paket))) (provide (prefix-out layer7- paket) - (prefix-out layer7- paket-fields) + (prefix-out layer7- paket-parse) (prefix-out layer7- device) (prefix-out layer7- device-name) + (prefix-out layer7- definition) ;; read ebus from port an return fields from next paket (prefix-out layer7- read-ebus) (prefix-out layer7- logger)) |