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

web/server fileserver improvements; work in progress: message handling

Browse source
This commit is contained in:
Helmut Merz 2024-06-23 14:10:23 +02:00
parent 504aaf0f92
commit 833c6d7578
4 changed files with 36 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
test/test-web.lisp
View file

@ -9,7 +9,7 @@
(:server :scopes/web/server)
(:t :scopes/testing))
(:export #:run)
(:import-from :scopes/testing #:deftest #:==))
(:import-from :scopes/testing #:deftest #:== #:has-prefix))
(in-package :scopes/test-web)
@ -20,19 +20,24 @@
(*config* nil))
(load (t:test-path "config-web" "etc"))
(core:setup-services *config*)
(test-server-config)
(sleep 0.1)
(test-client)
(sleep 0.1)
(server:stop (core:find-service :server))
(t:show-result)))
(let ((server (core:find-service :server))
(client (core:find-service :client)))
(test-server-config server)
(sleep 0.1)
(test-fileserver client)
;(test-message client)
(sleep 0.1)
(server:stop (core:find-service :server))
(t:show-result))))
(t:deftest test-server-config ()
(let ((cfg (core:config (core:find-service :server))))
(== (parse-integer (server:port cfg)) 8899)))
(t:deftest test-server-config (server)
(== (parse-integer (server:port (core:config server))) 8899))
(t:deftest test-client ()
(let ((ctx (core:find-service :client))
(msg (message:simple-message '(:test :get-page) '(:path "demo.html"))))
(== (client:base-url (core:config ctx)) "http://localhost:8899")
(== (client:get-page ctx msg) "Hello World!")))
(t:deftest test-fileserver (client)
(let ((msg (message:simple-message '(:test :get-page) '(:path "demo.html"))))
(== (client:base-url (core:config client)) "http://localhost:8899")
(has-prefix (client:get-page client msg) "Hello Fileserver!")))
(t:deftest test-message (client)
(let ((msg (message:simple-message '(:test :data))))
(== (client:send-message client msg) "Hello World!")))

9
testing.lisp
View file

@ -6,7 +6,7 @@
(:use :common-lisp)
(:export #:*test-suite*
#:test-suite #:deftest #:show-result
#:failure #:test #:==
#:failure #:test #:== #:has-prefix
#:test-path #:*current-system*))
(in-package :scopes/testing)
@ -42,6 +42,13 @@
(unless is-ok
(failure "~s!=~s" have wanted))))
(defun has-prefix (have wanted)
(let ((suite *test-suite*)
(is-ok (string= (str:prefix (list have wanted)) wanted)))
(push is-ok (car (result suite)))
(unless is-ok
(failure "~s has not prefix ~s" have wanted))))
(defmacro deftest (name args &body body)
`(defun ,name ,args
(push '(,name) (result *test-suite*))

7
web/client.lisp
View file

@ -6,7 +6,7 @@
(:core :scopes/core)
(:message :scopes/core/message))
(:export #:config #:base-url #:api-path #:doc-path
#:get-page))
#:get-page #:send-message))
(in-package :scopes/web/client)
@ -23,3 +23,8 @@
(path (getf (message:data msg) :path))
(url (str:concat (base-url cfg) (doc-path cfg) path)))
(dex:get url)))
(defun send-message (ctx msg)
(let* ((cfg (core:config ctx))
(url (str:concat (base-url cfg) (api-path cfg) (message:head-as-list msg))))
(dex:get url)))

7
web/server.lisp
View file

@ -34,14 +34,11 @@
(clack:stop (listener ctx)))
(defun fileserver (ctx env &key doc-root)
(print env)
(let* ((message-head (getf env :message-head))
(rel-path (str:join "/" (cdr message-head)))
(file-app (make-instance 'lack/app/file:lack-app-file
:file rel-path :root doc-root)))
(format t "~&fileserver: doc-root ~s, rel-path ~s, message-head ~s~%"
doc-root rel-path message-head)
(format t "~&file path: ~s~%" (merge-pathnames rel-path doc-root))
;(format t "~&file path: ~s~%" (merge-pathnames rel-path doc-root))
(lack/component:call file-app env)))
(defun message-handler (ctx env)
@ -53,7 +50,7 @@
(if (match (car r) nil)
(progn
(setf (getf env :message-head) (str:split "/" (getf env :path-info)))
(format t "~&route: ~s~%" r)
;(format t "~&route: ~s~%" r)
(return-from select-app
#'(lambda ()
(apply (cadr r) ctx env (cddr r)))))))