remove sxml dependency

1 files changed, 74 insertions, 68 deletions

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))