Proof-of-concept of a simple DSL for specifying servlets.

backend/api-servlets.scm

@@ -33,7 +33,10 @@
 
   (import scheme
 	  spiffy
-	  (chicken format))
+	  (chicken format)
+	  bar-db
+	  json
+	  (chicken port))
 
   (define-syntax try-match-lambda1
     (syntax-rules ()
@@ -73,8 +76,16 @@
       ((_ (name . args) . body)
        (define name (try-match-lambda args . body)))))
 
+  (define (alist->json-string alst)
+    (with-output-to-string
+      (lambda ()
+	(json-write
+	 (list->vector alst)))))
+
   (define-try-match (account-barcode-info "barcode" (barcode string->number))
-    (send-response #:body (format "API call [barcode] ~A" barcode)))
+    (send-response
+     #:body (alist->json-string
+	     `((amount . ,(bd-barcode-lookup barcode))))))
 
   (define api-servlets
     (list account-barcode-info))

backend/bar-db.scm

@@ -29,20 +29,36 @@
     bar-db
     (
      bar-db-init!
+     bd-barcode-lookup
      )
 
   (import scheme
 	  (chicken base)
-	  postgresql)
+	  postgresql
+	  sql-null)
 
-  (define bar-db-conn (make-parameter #f))
+  (define bd-conn (make-parameter #f))
 
   (define (bar-db-init! name host user pass)
-    (bar-db-conn
+    (bd-conn
      (connect
       `((dbname . ,name)
 	(host . ,host)
 	(user . ,user)
 	(password . ,pass)))))
 
+  (define (sql-null->symbol v)
+    (if (sql-null? v)
+	'null
+	v))
+
+  (define (bd-barcode-lookup bc)
+    (sql-null->symbol
+     (car
+      (row-values
+       (query
+	(bd-conn)
+	"select sum(amount*case side when 'credit' then -1 else 1 end) amt from transaction_splits where account=$1"
+	bc)))))
+
   )

install-eggs.sh

@@ -56,6 +56,7 @@ trap chicken_cleanup INT QUIT
 chicken_install openssl
 chicken_install spiffy
 chicken_install postgresql
+chicken_install json
 
 # Normal termination cleanup
 chicken_cleanup