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

web/server: log request cookies; fix old log and print-object stuff

Browse source
This commit is contained in:
Helmut Merz 2024-08-28 14:57:47 +02:00
parent dd69b1b56f
commit cf7d85af4d
4 changed files with 14 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
core/message.lisp
View file

@ -18,6 +18,4 @@
(make-instance 'message :head head :data data :sender sender)) (make-instance 'message :head head :data data :sender sender))
(defmethod print-object ((msg message) stream) (defmethod print-object ((msg message) stream)
(print-unreadable-object (msg stream :type t :identity t) (shape:print-fields msg stream 'shape:head 'sender 'shape:data))
(format stream "~s ~s <data ~s>"
(shape:head msg) (sender msg) (shape:data msg))))

2
shape/shape.lisp
View file

@ -3,7 +3,7 @@
(defpackage :scopes/shape (defpackage :scopes/shape
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:util :scopes/util)) (:local-nicknames (:util :scopes/util))
(:export #:record (:export #:record #:print-fields
#:head-fields #:head #:head-value #:head-plist #:head-fields #:head #:head-value #:head-plist
#:data-fields #:data #:data-value)) #:data-fields #:data #:data-value))

5
web/response.lisp
View file

@ -5,7 +5,8 @@
(:local-nicknames (:core :scopes/core) (:local-nicknames (:core :scopes/core)
(:dom :scopes/web/dom) (:dom :scopes/web/dom)
(:message :scopes/core/message) (:message :scopes/core/message)
(:shape :scopes/shape)) (:shape :scopes/shape)
(:util :scopes/util))
(:export #:interaction #:setup #:html-response (:export #:interaction #:setup #:html-response
#:render #:render-content #:render-not-found)) #:render #:render-content #:render-not-found))
@ -20,7 +21,7 @@
(format s "<interaction ~s>" (messages ia))) (format s "<interaction ~s>" (messages ia)))
(defmethod core:send ((ia interaction) msg) (defmethod core:send ((ia interaction) msg)
(log:debug "receiving ~s" msg) (util:lgd msg)
(push msg (messages ia))) (push msg (messages ia)))
;;;; response definitions ;;;; response definitions

16
web/server.lisp
View file

@ -36,11 +36,13 @@
(defun app (ctx env) (defun app (ctx env)
;(handler-case ... ;(handler-case ...
(log:info "request: ~a ~a, accept: ~a" (let* ((method (getf env :request-method))
(getf env :request-method) (uri (getf env :request-uri))
(getf env :request-uri) (headers (getf env :headers))
(gethash "accept" (getf env :headers))) (accept (gethash "accept" headers))
;(log:debug "request: ~s" env) (cookies (gethash "cookie" headers)))
(util:lgi method uri accept cookies))
;(util:lgd env)
(funcall (select-app ctx env))) (funcall (select-app ctx env)))
(defun start (ctx) (defun start (ctx)
@ -52,7 +54,7 @@
;:server :woo ;:server :woo
:debug nil :debug nil
:silent t)) :silent t))
(log:info "port: ~a." (port cfg)) (util:lgi (port cfg))
ctx)) ctx))
(defun stop (ctx) (defun stop (ctx)
@ -88,7 +90,7 @@
(msg (message:create (msg (message:create
(head env) :data (plist (post-data env)) :sender iact)) (head env) :data (plist (post-data env)) :sender iact))
(resp (response:setup ctx env :html-responder html-responder))) (resp (response:setup ctx env :html-responder html-responder)))
(log:debug "msg ~s" msg) (util:lgd msg)
; (check-auth ctx msg env) => (response:render-unauthorized resp) ; (check-auth ctx msg env) => (response:render-unauthorized resp)
(if (core:handle-message ctx msg) (if (core:handle-message ctx msg)
(response:render resp iact) (response:render resp iact)