From 306b9cb20e20f14dca56be1e0ae8338ae1a19a02 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Fri, 3 Jan 2025 11:00:44 +0100
Subject: [PATCH] Initial import of QR payment implementation.

---
 src/Makefile       | 10 ++++--
 src/qr-payment.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 84 insertions(+), 2 deletions(-)
 create mode 100644 src/qr-payment.scm

diff --git a/src/Makefile b/src/Makefile
index 827b386..5d5cae0 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -43,7 +43,8 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm			\
 	progress.import.scm cal-period.import.scm			\
 	util-stdout.import.scm export-web-static.import.scm		\
 	dokuwiki.import.scm mailinglist.import.scm			\
-	export-sheet.import.scm mbase-query.import.scm
+	export-sheet.import.scm mbase-query.import.scm			\
+	qr-payment.import.scm
 
 HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o	\
@@ -61,7 +62,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o	\
 	 util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o	\
 	 mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o	\
-	 mailinglist.o export-sheet.o mbase-query.o
+	 mailinglist.o export-sheet.o mbase-query.o qr-payment.o
 
 GENDOC-SOURCES=gendoc.scm duck-extract.import.scm			\
 	util-time.import.scm util-csv.import.scm util-git.import.scm	\
@@ -577,3 +578,8 @@ MBASE-QUERY-SOURCES=mbase-query.scm mbase.import.scm			\
 
 mbase-query.o: mbase-query.import.scm
 mbase-query.import.scm: $(MBASE-QUERY-SOURCES)
+
+QR-PAYMENT-SOURCES=qr-payment.scm
+
+qr-payment.o: qr-payment.import.scm
+qr-payment.import.scm: $(QR-PAYMENT-SOURCES)
diff --git a/src/qr-payment.scm b/src/qr-payment.scm
new file mode 100644
index 0000000..ed59c4f
--- /dev/null
+++ b/src/qr-payment.scm
@@ -0,0 +1,76 @@
+;;
+;; qr-payment.scm
+;;
+;; QR payment generator.
+;;
+;; ISC License
+;;
+;; Copyright 2023-2025 Brmlab, z.s.
+;; Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit qr-payment))
+
+(module
+    qr-payment
+    (
+     make-qrp
+     make-brmlab-qrp
+     )
+
+  (import scheme
+	  (chicken format)
+	  (chicken string)
+	  (chicken base))
+
+  (define (make-empty-qrp . vs)
+    (let ((v (if (null? vs) "1.0" (car vs))))
+      (list v "SPD")))
+
+  (define (add-field-to-qrp qrp key value)
+    (cons (format "~A:~A" key value)
+	  qrp))
+
+  (define (serialize-qrp qrp)
+    (string-intersperse (reverse qrp) "*"))
+
+  (define (ensure-amount-format amt)
+    (if (string? amt)
+	amt
+	amt))
+
+  (define (make-qrp iban amt cc vs msg)
+    (let loop ((keys '(ACC AM CC MSG X-CS))
+	       (vals (list iban (ensure-amount-format amt) cc msg vs))
+	       (qrp (make-empty-qrp)))
+      (if (null? keys)
+	  (serialize-qrp qrp)
+	  (loop (cdr keys)
+		(cdr vals)
+		(add-field-to-qrp qrp (car keys) (car vals))))))
+
+  (define (make-brmlab-qrp amt cc vs)
+    (let ((iban (if (equal? cc "CZK")
+		    "CZ0520100000002500079551"
+		    (if (equal? cc "EUR")
+			"CZ9320100000002100079552"
+			(error "Invalid currency!")))))
+      (make-qrp iban amt cc vs "Brmlab")))
+
+  (print (make-brmlab-qrp 1000 "CZK" 1234))
+
+  )