Work on setuid/setgid, add raw-data-parser for the brmbar disaster.

backend/api-servlets.scm

@@ -36,7 +36,8 @@
 	  (chicken format)
 	  bar-db
 	  json
-	  (chicken port))
+	  (chicken port)
+	  (chicken base))
 
   (define-syntax try-match-lambda1
     (syntax-rules ()
@@ -82,7 +83,7 @@
 	(json-write
 	 (list->vector alst)))))
 
-  (define-try-match (account-barcode-info "barcode" (barcode string->number))
+  (define-try-match (account-barcode-info "barcode" (barcode identity))
     (send-response
      #:body (alist->json-string
 	     `((amount . ,(bd-barcode-lookup barcode))))))

backend/bar-db.scm

@@ -58,7 +58,7 @@
       (row-values
        (query
 	(bd-conn)
-	"select sum(amount*case side when 'credit' then -1 else 1 end) amt from transaction_splits where account=$1"
+	"select sum(amount*case side when 'credit' then -1 else 1 end) amt from transaction_splits where account=(select account from barcodes where barcode=$1)"
 	bc)))))
 
   )

backend/brminv.scm

@@ -33,7 +33,8 @@
 	uri-common
 	(chicken string)
 	api-servlets
-	bar-db)
+	bar-db
+	(chicken process-context posix))
 
 (define -port- (make-parameter #f))
 (define -certificate- (make-parameter #f))
@@ -98,8 +99,12 @@
 		   private-key: (-key-))
       (tcp-listen port)))
 
-(when (and (-user-) (-group-))
-  (switch-user/group (-user-) (-group-)))
+(when (or (-user-) (-group-))
+  (print "current user id: " (current-user-id))
+  (print "current effective user id: " (current-effective-user-id))
+  (switch-user/group (-user-) (-group-))
+  (print "current user id: " (current-user-id))
+  (print "current effective user id: " (current-effective-user-id)))
 
 (bar-db-init! (-db-name-) (-db-host-) (-db-user-) (-db-pass-))
 

raw-data-parse.rkt

@@ -0,0 +1,81 @@
+#lang racket
+
+(require racket/cmdline)
+
+(define dirname
+  (command-line
+   #:args
+   (dn) dn))
+
+;;(displayln dirname)
+
+(define files
+  (sort
+   (for/list ((fn (in-directory dirname)))
+     fn)
+   (lambda (a b)
+     (string<? (path->string a)
+               (path->string b)))))
+
+(define (load-balances fn)
+  (define slst
+    (with-input-from-file fn
+      (thunk
+       (for/list ((l (in-lines))
+                  #:when (not (string-prefix? l "---")))
+         (map string-trim (string-split l "|"))))))
+  (define header (car slst))
+  ;(writeln header)
+  (define data0 (filter (lambda (l) (> (length l) 1)) (cdr slst)))
+  (define data
+    (for/list ((row (in-list data0)))
+      (match-define (list id name acctype crbalance) row)
+      (cons (string->number id)
+            (string->number crbalance))))
+  (define name (car (reverse (explode-path fn))))
+  (cons name
+        (make-immutable-hash
+         (sort data (lambda (a b) (< (car a) (car b)))))))
+
+;;(displayln (length files))
+
+(define balances
+  (time
+   (for/list ((fn (in-list files)))
+     (load-balances fn))))
+
+;;(displayln (length balances))
+
+;;(displayln "================")
+
+(define (calc-difference prev0 next0)
+  (define prev (cdr prev0))
+  (define next (cdr next0))
+  (define pname (car prev0))
+  (define nname (car next0))
+  (define keys
+    (set-union
+     (list->set (hash-keys prev))
+     (list->set (hash-keys next))))
+  (define all
+    (for/hash ((key (in-set keys)))
+      (values key
+              (- (hash-ref next key 0)
+                 (hash-ref prev key 0)))))
+  (cons (cons pname nname)
+        (for/hash (((k v) (in-hash all))
+                   #:when (not (zero? v)))
+          (values k v))))
+
+(define (print-difference prev next)
+  (define diff0 (calc-difference prev next))
+  (define diff (cdr diff0))
+  (define dname (car diff0))
+  (when (> (hash-count diff) 0)
+    (displayln (format ":: ~a -> ~a" (car dname) (cdr dname)))
+    (for (((k v) (in-hash diff)))
+      (displayln (format "~a ~a" k (real->decimal-string v))))))
+
+(for ((prev (in-list balances))
+      (next (in-list (cdr balances))))
+  (print-difference prev next))