diff --git a/core/message.lisp b/core/message.lisp index b59972a..959c0de 100644 --- a/core/message.lisp +++ b/core/message.lisp @@ -3,7 +3,7 @@ (defpackage :scopes/core/message (:use :common-lisp) (:export #:message #:make-message #:simple-message - #:head #:data #:head-as-list)) + #:head #:data #:sender #:head-as-list)) (in-package :scopes/core/message) @@ -19,15 +19,15 @@ (defclass message () ((head :reader head :initarg :head) - (sender) + (sender :reader sender :initarg :sender :initform nil) (timestamp) (data :accessor data :initarg :data :initform nil))) -(defun make-message (head-vals &key data) +(defun make-message (head-vals &key data sender) (let ((h (make-instance 'message-head))) (dolist (sl '(domain action class item)) (setf (slot-value h sl) (pop head-vals))) - (make-instance 'message :head h :data data))) + (make-instance 'message :head h :data data :sender sender))) (defun simple-message (&rest head-vals) (make-message head-vals)) @@ -35,8 +35,8 @@ (defmethod print-object ((msg message) stream) (with-slots (domain action class item) (head msg) (format stream - ">" - domain action class item (data msg)))) + ">" + domain action class item (sender msg) (data msg)))) (defun head-as-list (msg) (with-slots (domain action class item) (head msg) diff --git a/test/etc/config-web.lisp b/test/etc/config-web.lisp index f8aaf07..20faccc 100644 --- a/test/etc/config-web.lisp +++ b/test/etc/config-web.lisp @@ -15,7 +15,8 @@ `((("api") server:message-handler) (() server:fileserver :doc-root ,(t:test-path "" "docs")))) -(config:add-action '(:test :data) #'(lambda (ctx msg))) +(config:add-action '(:test :data) #'server:demo) +;(config:add-action '(:test :data) #'(lambda (ctx msg))) (config:add :client :class 'client:config :base-url "http://localhost:8899" diff --git a/test/test-web.lisp b/test/test-web.lisp index 9dae2ec..be266e3 100644 --- a/test/test-web.lisp +++ b/test/test-web.lisp @@ -40,4 +40,4 @@ (deftest test-message (client) (let ((msg (message:make-message '(:test :data) :data '(:info "test data")))) - (== (client:send-message client msg) "Hello World!"))) + (== (client:send-message client msg) "Hello Demo-World!"))) diff --git a/util.lisp b/util.lisp index 3a3536d..1962650 100644 --- a/util.lisp +++ b/util.lisp @@ -2,15 +2,21 @@ (defpackage :scopes/util (:use :common-lisp) - (:export #:to-keyword + (:export #:to-keyword #:trunc #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string #:relative-path #:runtime-path #:system-path)) (in-package :scopes/util) -;;;; symbols, keywords, ... +;;;; strings, symbols, keywords, ... -(defun to-keyword(s) +(defun trunc (s n) + (let ((s1 (str:substring 0 n s))) + (if (> (length s) n) + (str:concat s1 "...") + s1))) + +(defun to-keyword (s) (intern (string-upcase s) :keyword)) ;;;; directory and pathname utilities diff --git a/web/server.lisp b/web/server.lisp index b69e8eb..7749fae 100644 --- a/web/server.lisp +++ b/web/server.lisp @@ -5,9 +5,11 @@ (:local-nicknames (:config :scopes/config) (:core :scopes/core) (:message :scopes/core/message) + (:util :scopes/util) (:alx :alexandria)) (:export #:config #:address #:port #:routes #:*listener* #:setup #:start #:stop + #:demo #:fileserver #:message-handler)) (in-package :scopes/web/server) @@ -55,10 +57,12 @@ (defun message-handler (ctx env) (let* ((resp (make-response ctx)) - (msg (message:make-message (head env) :data (plist (post-data env))))) + (msg (message:make-message + (head env) :data (plist (post-data env)) :sender resp))) (log:debug "msg ~s" msg) (if (core:handle-message ctx msg) - '(200 (:content-type "text/plain") ("Hello World!")) + (list 200 (headers resp) (list (body resp))) + ;'(200 (:content-type "text/plain") ("Hello World!")) '(404 (:content-type "text/plain") ("Not found"))))) (defun select-app (ctx env) @@ -78,9 +82,22 @@ ;;;; server response - provice response body and headers -(defun make-response (ctx)) +(defclass response () + ((ctx :reader ctx :initarg :ctx) + (content :accessor content :initform "") + (headers :accessor headers :initform nil))) -;;;; server context (= service) +(defun make-response (ctx) + (make-instance 'response :ctx ctx)) + +(defgeneric body (r) + (:method ((r response)) + (content r))) + +(defmethod print-object ((r response) s) + (format s "" (util:trunc(content r) 12))) + +;;;; server context (= service), action handlers (defclass context (core:context) ((listener :accessor listener))) @@ -89,13 +106,16 @@ (let ((ctx (make-instance 'context :config cfg :name (config:name cfg)))) (start ctx))) +(defun demo (ctx msg) + (let ((resp (message:sender msg))) + (if (null resp) + (log:warn "sender missing: ~s" msg) + (setf (content resp) "Hello Demo-World!")))) + ;;;; helper functions -(defun as-keyword (s) - (intern (string-upcase s) :keyword)) - (defun head (env) - (mapcar #'(lambda (e) (as-keyword e)) (getf env :message-head))) + (mapcar #'(lambda (e) (util:to-keyword e)) (getf env :message-head))) (defun post-data (env) (if (getf env :content-length) @@ -104,5 +124,5 @@ (quri.decode:url-decode-params str)))) (defun plist (alst) - (let ((a2 (mapcar #'(lambda (p) (cons (as-keyword (car p)) (cdr p))) alst))) + (let ((a2 (mapcar #'(lambda (p) (cons (util:to-keyword (car p)) (cdr p))) alst))) (alx:alist-plist a2)))