gistfile1.scm

(use spiffy matchable test channel)
(include "server.scm")
(include "alist-util.scm")

;; events: `(event ...)
;; event: `(ekey event)
;; ekey: `(atype aid)

;; ==================== event-store ====================
(define (make-event-store) `(event-store . () ))

;; TODO: support #f events
(define (event-store-fold es ekey kons knil)
  (match es (('event-store . l)))
  (define match? (cond ((procedure? ekey) ekey)
                       (else (cut equal? ekey <>))))
  (fold kons knil
        (filter-map
         (lambda (e) (match e ( (ekey0 event) (and (match? ekey0) event))))
         (cdr es))))

;; TODO: make thread-safe!
(define (event-store-save! es ekey e)
  (define event-item (list ekey e))
  (set-cdr! es (append (cdr es)
                       (list event-item))))



(test-group
 "event-store-save!"
 (define es (make-event-store))
 (event-store-save! es 'id 1)
 (event-store-save! es 'ignored 'anything)
 (event-store-save! es 'id 2)
 (event-store-save! es 'id 3)
 ;; note that cons reverses order here
 (test '(1 2 3) (reverse (event-store-fold es 'id cons '()))))


;; ==================== aggregates ====================


(define *es* (make-event-store))

(define (sub1>0 x #!optional (<=0 error))
  (if (> x 0) (sub1 x) (<=0 x)))

(define (basket-fold event state)
  (match event
    (('add mid) (alist-swap mid add1   state 1))
    (('del mid) (alist-swap mid sub1>0 state error))))

(test
 "basket-fold"
 '((c . 1)
   (b . 0)
   (a . 2))
 (event-store-fold `(event-store
                     ((basket 1) (add a))
                     ((basket 1) (add b))
                     ((basket 1) (add c))
                     ((basket 2) (add X))
                     ((basket 1) (add a))
                     ((basket 1) (del b)) )
                   '(basket 1)
                   basket-fold
                   '()))

(define *monsters*
  '( (bar (price . 10))
     (foo (price . 3))))

(define (monster-types.json)
  (list->vector (map (lambda (m) `((name . ,(conc (car m)))
                              ,@(cdr m)))
                     *monsters*)))

(define (monster-price monster)
  (assert (symbol? monster))
  (cond ((alist-ref monster *monsters*) =>
         (lambda (mo) (alist-ref 'price mo)))))

;; mapping monster => count
;; TODO: don't reload from the beginning _every_ time! subscribe instead
(define (projection/basket*) (event-store-fold *es* '(basket 1) basket-fold '()))

;; `( ( monster . ((monster-field . x) ...)) )
(define (projection/basket)
  (map (match-lambda ((monster . number)
                 `(,monster
                   (name . ,(conc monster))
                   (price . ,(monster-price monster))
                   (number . ,number))))
       (projection/basket*)))

(define (basket.json) (projection/basket))


(define (basket/sum)
  (fold (lambda (x s) (+ s (* (alist-ref 'price (cdr x))
                         (alist-ref 'number (cdr x)))))
        0
        (projection/basket)))

(define (basket/sum.json)
  `((sum . ,(basket/sum))))

(define (basket/add monster)
  ;; TODO: check that monster exists
  ;; TODO: don't allow deleting monsters not in basket
  (event-store-save! *es* '(basket 1) `(add ,monster)))

(define (basket/del monster)
  ;; TODO: check that basket contains 1 or more monster
  (event-store-save! *es* '(basket 1) `(del ,monster)))

(define (basket/item.json item)
  (define monster item)
  (case (request-method (current-request))
    ((DELETE) (basket/del (string->symbol monster)) '())
    ((POST)   (basket/add (string->symbol monster)) '())))

(define (orders/add order)
  (event-store-save! *es* '(order 1) `(place ,order)))

(define (projection/orders)
  (event-store-fold *es* (match-lambda (('order oid)) (else #f))
                    (match-lambda* ( (('place order) state)
                                (pp `(PP order))
                                order))
                    '()))

(define (orders) (projection/orders))

(define orders.json
  (wrap-json/request
   (lambda ()
     (case (request-method (current-request))
       ((POST) (orders/add (projection/basket)) #t)
       ((GET)  (orders))))))

(define (command/login un)
  ;; TODO: assign session id
  "ok")

(define api-handler.json
  (lambda ()
    (match (uri-path (request-uri (current-request)))
      ((/ "service" "auth"   "logIn" un)    (command/login un))
      ((/ "service" "basket" "sum")         (basket/sum.json))
      ((/ "service" "basket" "")            (basket.json))
      ((/ "service" "basket" monster)       (basket/item.json monster))
      ((/ "service" "monsterTypes")         (monster-types.json))
      ((/ "service" "orders")               (orders.json))
      (else #f))))

(define (handler )
  (let ((path (uri-path (request-uri (current-request)))))
    (set! last-request (current-request))
    (print "incoming " path)
    (cond
     ((api-handler.json) => send-json)
     (else (send-static-file
            (uri->string (update-uri (request-uri (current-request)) host: #f scheme: #f port: #f)))))))

(root-path "/home/klm/projects/tmp/monsterbutikken/src/main/webapp/")
(thread-start! (lambda () (start-server/handler (lambda () (handler)))))

(pp *es*)