racket: aufgraeumt, data2c gefixt

3 files changed, 358 insertions, 0 deletions

diff --git a/ebus-racket/ebus/db.rkt b/ebus-racket/ebus/db.rkt
new file mode 100644
index 0000000..2c6be6c
--- /dev/null
+++ b/ebus-racket/ebus/db.rkt
@@ -0,0 +1,88 @@
+#lang racket/base
+(require racket/path)
+(require (prefix-in db: db))
+
+(define db-logger (make-logger 'ebus-db (current-logger)))
+
+(define db-file? (make-parameter 
+                   (build-path (path-only (find-system-path 'run-file)) "database.sqlite3")))
+
+(define pool
+  (db:virtual-connection
+    (db:connection-pool
+      (lambda () 
+        (log-message db-logger 'info (format "Open database file ~a" (db-file?)) #t)
+        (with-handlers ([exn:fail? (lambda (exn)
+                                     (log-message db-logger 'error (format "Error opening database ~a" (db-file?)) #t) (raise exn))])
+                       (db:postgresql-connect #:user "ebus"
+			    #:database "ebus"
+			    #:password "ebus"
+			    #:server "localhost")))
+ ;;                      (db:sqlite3-connect #:database (db-file?))))
+ ;;
+      #:max-connections 5
+      #:max-idle-connections 2
+      )))
+
+
+;; Test Database Connection
+;; Returns #t on success, #f otherwise
+(define (db-test)
+  (with-handlers ([exn:fail? (lambda (exn) (log-message db-logger 'error (format "Error: ~a" exn) #t) #f)])
+    (= (db:query-value pool "SELECT 1") 1)))
+
+;; Query ID of sensor given by sensor-name
+;; Returns null if sensor is undefined
+(define (get-sensor-id sensor-name)
+  (define sql-stmt "SELECT id FROM sensor WHERE name = $1")
+  (with-handlers ([exn:fail?  (lambda (exn) (void))])
+    (db:query-value pool sql-stmt sensor-name)))
+
+;; Create Sensor-ID with given name
+;; returns id
+(define (create-sensor-id sensor-name)
+  (log-message db-logger 'info (format "create sensor id for ~a" sensor-name) #t)
+  (db:query-exec pool "INSERT INTO sensor(name) VALUES ($1)" sensor-name)
+  (get-sensor-id sensor-name))
+
+;; Get ID of sensor given by sensor-name
+;; define sensor if needed
+(define (get-or-create-sensor-id sensor-name)
+  (define id (get-sensor-id sensor-name))
+  (cond ((void? id) (create-sensor-id sensor-name))
+	(else id)))
+
+;; Insert Field in Database
+;; Decide Database-Datatype from Ebus-Datatype
+;; then calls 'insert`
+(define (db-insert-field sensor-name datatype offset value)
+  (cond ((member datatype (list "data1c" "data2b" "data2c"))
+  	 ;; float
+  	 (insert sensor-name value db:sql-null db:sql-null))
+  	((member datatype (list "bit" "byte" "data1b" "word" "bcd"))
+  	 ;; int
+  	 (insert sensor-name db:sql-null value db:sql-null))
+  	((member datatype (list "byteEnum"))
+  	 ;; string
+  	 (insert sensor-name db:sql-null db:sql-null value))
+  	(else (log-message db-logger 'error (format "Datatype ~a is not support by DB" datatype) #t))))
+
+(define (insert sensor-name value-float value-int value-string)
+  (define sensor-id (get-or-create-sensor-id sensor-name))
+  (define type (cond ((not (db:sql-null? value-string)) "string")
+		     ((not (db:sql-null? value-float)) "float")
+		     ((not (db:sql-null? value-int)) "int")))
+  (define sql-stmt 
+    (string-append "INSERT INTO value(timestamp, sensor_id, type, value_float, value_int, value_string) "
+		   "VALUES (CURRENT_TIMESTAMP, $1, $2, $3, $4, $5)"))
+  (log-message db-logger 'info (string-append sql-stmt "\n\t\t"
+					   (format
+					    "sensor-id=~a type=~a value-float=~a value-int=~a value-string=~a"
+					    sensor-id type value-float value-int value-string)) #t)
+  (db:query-exec pool sql-stmt sensor-id type value-float value-int value-string))
+
+(provide
+ db-file?
+ db-logger
+ db-test
+ db-insert-field)
diff --git a/ebus-racket/ebus/layer2.rkt b/ebus-racket/ebus/layer2.rkt
new file mode 100644
index 0000000..3dd881c
--- /dev/null
+++ b/ebus-racket/ebus/layer2.rkt
@@ -0,0 +1,104 @@
+#lang racket/base
+(require racket/bool
+         (planet bzlib/parseq:1:3))
+
+(define logger (make-logger 'ebus-layer2 (current-logger)))
+;; Ebus SYN
+(define ebus-const-syn #xaa)
+;; Ebus Escape-Sequence Start
+(define ebus-const-escape #xa9)
+;; Ebus ACK
+(define ebus-const-ackok #x00)
+;; Ebus Broadcast Address
+(define ebus-const-broadcastaddr 254)
+
+(struct ebus-body-broadcast (crc) #:transparent)
+
+(struct ebus-body-mastermaster (crc) #:transparent)
+
+(struct ebus-body-masterslave
+	(crc payloadSlaveLength payloadSlave crcSlave)
+	#:transparent)
+
+(struct ebus-paket
+	(source destination primaryCommand secondaryCommand payloadLength payload body)
+	#:transparent)
+
+;; single, maybe escaped, payload data byte 
+(define ebus-payload
+  (choice (seq escape-seq <- ebus-const-escape
+	       escape-code <- (byte-in (list 0 1))
+	       (return (cond
+			((= escape-code 0) ebus-const-escape)
+			((= escape-code 1) bytes ebus-const-syn))))
+	  any-byte
+	  ))
+
+(define parse-ebus-broadcast
+  (token (seq crc <- any-byte
+	      syn <- ebus-const-syn
+	      (return (ebus-body-broadcast crc)))))
+
+(define parse-ebus-mastermaster
+  (token (seq  crc <- any-byte
+	       ack <- ebus-const-ackok ;; ACK des Empfängers
+	       syn <- ebus-const-syn   ;; SYN des Senders
+	       (return (ebus-body-mastermaster crc)))))
+
+(define parse-ebus-masterslave 
+  (token (seq crc <- any-byte
+	      ack <- ebus-const-ackok ;; ACK des Empfängers
+	      payloadSlaveLength <- any-byte
+	      payloadSlave <- (repeat ebus-payload payloadSlaveLength payloadSlaveLength)
+	      crcSlave <- any-byte
+	      ackSlave <- ebus-const-ackok ;; ACK des Senders
+	      synSlave <- ebus-const-syn   ;; SYN des Senders
+	      (return (ebus-body-masterslave crc payloadSlaveLength payloadSlave crcSlave)))))
+
+(define parse-ebus-paket
+  (token (seq source <- any-byte
+	      destination <- any-byte
+	      primaryCommand <- any-byte
+	      secondaryCommand <- any-byte
+	      payloadLength <- any-byte
+	      payload <- (repeat ebus-payload payloadLength payloadLength)
+	      body <- (cond ((= destination ebus-const-broadcastaddr) parse-ebus-broadcast)
+			    (else (choice parse-ebus-mastermaster 
+					  parse-ebus-masterslave)))
+	      (return (ebus-paket source 
+				  destination
+				  primaryCommand
+				  secondaryCommand
+				  payloadLength
+				  payload 
+				  body)))))
+
+(define ebus-sync (tokens syncs <- (seq (repeat (string->bytes/latin-1 "\xaa")))
+                          (return (length syncs))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (read-ebus input-port)
+  (define syn   ((make-reader ebus-sync #:sof? #f #:eof? #f)  input-port))
+  (define paket   ((make-reader parse-ebus-paket #:sof? #f #:eof? #f) input-port))
+  (cond ((not (false? syn))
+	 (log-message logger 'debug (format "drop ~s x SYN (~s)" syn ebus-const-syn) #t)))
+  (cond ((not (false? paket))
+	 paket)
+	((eof-object? (peek-byte input-port))
+	 eof)
+	(else
+	 ;; skip one byte
+	 (let ([byte (read-byte input-port)])
+	   (log-message logger 'debug (format "drop ~s 0x~x ~n" byte byte) #t))
+	 (read-ebus input-port))))
+
+(provide 
+ ;; Read Layer Ebus-Paket `ebus-paket`
+ (prefix-out layer2- read-ebus)
+ (prefix-out layer2- (struct-out ebus-paket))
+ (prefix-out layer2- (struct-out ebus-body-broadcast))
+ (prefix-out layer2- (struct-out ebus-body-mastermaster))
+ (prefix-out layer2- (struct-out ebus-body-masterslave))
+ (prefix-out layer2- logger))
\ No newline at end of file
diff --git a/ebus-racket/ebus/layer7.rkt b/ebus-racket/ebus/layer7.rkt
new file mode 100644
index 0000000..3bcad01
--- /dev/null
+++ b/ebus-racket/ebus/layer7.rkt
@@ -0,0 +1,166 @@
+#lang racket/base
+(require racket/list
+         (planet lizorkin/sxml:2:1/sxml)
+         (planet lizorkin/ssax:2:0/ssax)
+         "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")]))
+
+(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))
+
+;; returns the full device-definition
+(define (device address)
+  ((sxpath (string-append "//devices/device[@address=" (number->string address) "]"))
+   definition))
+
+;; returns device-name in a list or empty-list
+(define (device-name address)
+  (first ((sxpath "@name/text()") (device address))))
+
+
+(define (paket-fields 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))
+			   "." 
+			   (first ((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 "." (first ((sxpath "@name/text()") field))))
+  (define offset (string->number (first ((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)))))
+
+;; type bit
+(define (field-decoder-bit value)
+  (cond ((= value 1) 1)
+        (else 0)))
+
+;; type data1b
+(define (field-decoder-data1b value)
+  value)
+
+;; type data1c
+(define (field-decoder-data1c value)
+  (/ value 2.0))
+
+;; type data2b
+(define (field-decoder-data2b lowByte highByte)
+  (if (= (bitwise-and highByte 128) 128)
+      (* -1 
+	 (+ (+ 256 (bitwise-not highByte))
+	    (/ (+ 256 (bitwise-not (+ lowByte 1))) 256.0)))
+      (+ highByte (/ lowByte 256.0))))
+
+ ;; type data2c
+ ;;    Beispiel für die Berechnung:
+ ;;    if ((x & 8000h) == 8000h) // y negativ
+ ;;    y = - [dez(High_Byte(!x)) 16 + dez(High_Nibble (Low_Byte (!x)))
+ ;;    + (dez(Low_Nibble (Low_Byte (!x))) +1 ) / 16]
+ ;;    else                       // y positiv
+ ;;    y = dez(High_Byte(x)) 16 + dez(High_ Nibble (Low Byte (x)))
+ ;;    + dez(Low_ Nibble (Low Byte (x))) / 16
+(define (field-decoder-data2c lowByte highByte)
+  (define (lowNibble v)
+    (bitwise-and v #x0f))
+  (define (highNibble v)
+    (arithmetic-shift v -4))
+  (define (u-not v)
+    (+ 256 (bitwise-not v)))
+  (if (= (bitwise-and highByte 128) 128)
+      (* -1
+	  (+ (arithmetic-shift (u-not highByte) 4)
+	     (highNibble (u-not lowByte))
+             (/ (+ (lowNibble (u-not lowByte)) 1)
+                16.0)))
+      (+ (arithmetic-shift highByte 4)
+         (highNibble lowByte)
+         (/
+           (lowNibble lowByte)
+           16))))
+
+;; type byteEnum
+(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 (first ((sxpath "@value/text()") option))) ;; value, name
+				      (first ((sxpath "@name/text()") option)))))
+  (define options (filter pred all-options))
+  (cond ((= (length options) 1)
+	 (list-ref (first options) 1))
+	(else "<undefined>")))
+
+;; type word
+(define (field-decoder-word lowByte highByte)
+  (+ lowByte
+     (arithmetic-shift highByte 8)))
+
+;; type bcd
+(define (field-decoder-bcd value)
+  (+ (bitwise-and value #x0f)
+     (arithmetic-shift value -4)))
+  
+;; read one ebus-paket or eof from input-port
+;; or return #<eof>
+(define (read-ebus input-port)
+  (define paket (layer2-read-ebus input-port))
+  (cond ((layer2-ebus-paket? paket)
+	 (paket-fields paket))
+	(else paket)))
+
+(provide (prefix-out layer7- paket)
+         (prefix-out layer7- paket-fields)
+         (prefix-out layer7- device)
+         (prefix-out layer7- device-name)
+	 ;; read ebus from port an return fields from next paket
+	 (prefix-out layer7- read-ebus)
+	 (prefix-out layer7- logger))