server (basic impl): handle action using response object

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 
-            "<message (~a ~a ~a ~a) <data ~s>>" 
+            "<message (~a ~a ~a ~a) ~s <data ~s>>" 
-            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)

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"

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!")))

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

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 "<response ~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)))