cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

storage, web: extensions and fixes for message replay

Browse source
This commit is contained in:
Helmut Merz 2025-09-28 15:08:34 +02:00
parent a3d0619bc2
commit f472d4ad62
4 changed files with 44 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
storage/msgstore.lisp
View file

@ -7,7 +7,8 @@
(:message :scopes/core/message)
(:shape :scopes/shape)
(:storage :scopes/storage)
(:tracking :scopes/storage/tracking))
(:tracking :scopes/storage/tracking)
(:util :scopes/util))
(:export #:make-container #:save
#:replay-id
))
@ -35,8 +36,15 @@
:container cont)))
(tracking:save pm)))
(defun replay-id (ctx msgid rcvr)
(defun replay-id (ctx msgid rcvr &key attrs)
(let* ((st (storage:storage ctx))
(cont (make-container st))
(msg (tracking:get-track cont msgid)))
(actor:send (core:find-service rcvr) msg)))
(msg (tracking:get-track cont msgid))
(ts (local-time:universal-to-timestamp (tracking:timestamp msg))))
(when attrs
(setf (shape:data msg)
(util:filter-plist (shape:data msg) attrs)))
(util:plist-add (shape:data msg) :|_timestamp| (local-time:format-timestring nil ts))
(format t "~&~s~%" msg)
(actor:send (core:mailbox (core:find-service rcvr)) msg)
))

5
storage/tracking.lisp
View file

@ -180,7 +180,10 @@
(setf (timestamp tr) (getf row :timestamp))
(setf (shape:data tr)
(funcall *build-track-data*
(jzon:parse (getf row :data) :key-fn #'util:to-keyword)))
;(jzon:parse (getf row :data) :key-fn #'util:to-keyword)
(jzon:parse (getf row :data)
:key-fn (lambda (k) (intern k :keyword)))
))
tr)))
(defun ensure-timestamp (track)

6
test/test-storage.lisp
View file

@ -58,7 +58,7 @@
(== (tracking:trackid tr) 1)
(setf tr2 (tracking:get-track cont 1))
(== (shape:head tr2) '(:t01 :john))
(== (getf (shape:data tr2) :desc) "scopes/storage: queries")
(== (getf (shape:data tr2) :|desc|) "scopes/storage: queries")
))
(deftest test-msgstore (ctx)
@ -67,12 +67,12 @@
(setf cont (msgstore:make-container st))
(storage:drop-table st :messages)
(tracking:create-table cont)
(setf msg (message:create '(:test :data :field) :data '(:info "test data")))
(setf msg (message:create '(:test :data :field) :data '(:|Info| "test data")))
(setf pm (msgstore:save msg cont))
(== (tracking:trackid pm) 1)
(setf pm2 (tracking:get-track cont 1))
(== (shape:head pm2) '(:test :data :field nil))
(== (getf (shape:data pm2) :info) "test data")
(== (getf (shape:data pm2) :|Info|) "test data") ; check: keyword case
(setf pm3 (tracking:query-last cont '(:domain :test)))
;(util:lgi pm3)
(msgstore:save pm3 cont)

33
web/client.lisp
View file

@ -6,7 +6,9 @@
(:core :scopes/core)
(:message :scopes/core/message)
(:shape :scopes/shape)
(:alx :alexandria))
(:util :scopes/util)
(:alx :alexandria)
(:jzon :com.inuoe.jzon))
(:export #:config #:base-url #:api-path #:doc-path
#:get-page #:send-message))
@ -18,6 +20,7 @@
((config:setup :initform (core:make-setup :class 'core:context))
(base-url :reader base-url :initarg :base-url :initform "http://localhost:8135")
(doc-path :reader doc-path :initarg :doc-path :initform "/")
(credentials :reader credentials :initarg :credentials :initform nil)
(api-path :reader api-path :initarg :api-path :initform "/api/")
(accept :reader accept :initarg :accept :initform "text/html")))
@ -31,18 +34,32 @@
(defun send-message (ctx msg)
(let* ((cfg (core:config ctx))
(url (str:concat (base-url cfg) (api-path cfg) (msgpath msg))))
(dex:post url
:content (data-as-alist (shape:data msg))
:headers `(("Accept" . ,(accept cfg)))
:cookie-jar *cookie-jar*)))
(url (str:concat (base-url cfg) (api-path cfg) (msgpath msg)))
(data (shape:data msg))
(cred (credentials cfg))
(params `(
;:content ,(data-as-json data)
:content ,(data-as-alist data)
:headers (("Accept" . ,(accept cfg)))
:cookie-jar ,*cookie-jar*
)))
(when cred
(util:plist-add params :basic-auth (cons (car cred) (cadr cred))))
(apply #'dex:post url params)
))
(defun msgpath (msg)
(str:join "/" (loop for p in (shape:head msg)
when p collect (string-downcase p))))
(defun data-as-json (data)
(if (symbolp (car data)) ; seems to be a property list
(let ((ht (alx:plist-hash-table data)))
(jzon:stringify ht))
data))
(defun data-as-alist (data)
(if (symbolp (car data)) ; seems to be a property list
(mapcar #'(lambda (p) (cons (string-downcase (car p)) (cdr p)))
(alx:plist-alist data))
(let ((al (alx:plist-alist data)))
(mapcar #'(lambda (p) (cons (string (car p)) (cdr p))) al))
data))