;;
;; api-servlets.scm
;;
;; All servlets in one place.
;;
;; 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 api-servlets))

(module
    api-servlets
    (
     api-dispatch
     )

  (import scheme
	  spiffy
	  (chicken format)
	  bar-db
	  json
	  (chicken port))

  (define-syntax try-match-lambda1
    (syntax-rules ()
      ((_ pp plst ((arg ->conv) . args) body)
       (let ((as (->conv pp)))
	 (cond (as
		(let ((arg as))
		  (try-match-lambda0 plst args body)))
	       (else
		#f))))
      ((_ pp plst (lit . args) body)
       (if (equal? pp lit)
	   (try-match-lambda0 plst args body)
	   #f))))

  (define-syntax try-match-lambda0
    (syntax-rules ()
      ((_ plst () (expr ...))
       (let ()
	 expr ...
	 #t))
      ((_ plst (arg . args) body)
       (cond ((null? plst)
	      #f)
	     (else
	      (let ((pp (car plst)))
		(try-match-lambda1 pp (cdr plst) (arg . args) body)))))))

  (define-syntax try-match-lambda
    (syntax-rules ()
      ((_ args . body)
       (lambda (plst)
	 (try-match-lambda0 plst args body)))))

  (define-syntax define-try-match
    (syntax-rules ()
      ((_ (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 (alist->json-string
	     `((amount . ,(bd-barcode-lookup barcode))))))

  (define api-servlets
    (list account-barcode-info))

  (define (api-dispatch plst)
    (let loop ((as api-servlets))
      (if (null? as)
	  #f
	  (if ((car as) plst)
	      #t
	      (loop (cdr as))))))

  )