Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
(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*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.