server: work in progress: handle message, prepare response

core/core.lisp

@@ -5,8 +5,10 @@
   (:local-nicknames (:config :scopes/config)
                     (:message :scopes/core/message)
                     (:alx :alexandria))
-  (:export #:*root* #:default-setup #:find-service #:setup-services
+  (:export #:*root* #:default-setup #:default-actions 
+           #:find-service #:setup-services
            #:context #:add-action #:config #:name #:send #:shutdown
+           #:handle-message
            #:printer))
 
 (in-package :scopes/core)
@@ -75,7 +77,6 @@
             (actions ctx)))))
 
 (defun add-service (ctx cfg)
-  ;(format t "~&add-service: ~s~%" (config:name cfg))
   (with-slots (services) ctx
     (let ((child (funcall (config:setup cfg) cfg)))
       (when child
@@ -89,9 +90,10 @@
 
 (defgeneric handle-message (ctx msg)
   (:method ((ctx context) msg)
-    (if (not (do-actions ctx msg))
+    (cond 
-      (if (not (do-actions ctx msg #'default-actions))
+      ((do-actions ctx msg) t)
-        (log:warn "no action selected for ~s" msg)))))
+      ((do-actions ctx msg #'default-actions) t)
+      (t (log:warn "no action selected for ~s" msg)))))
 
 (defun do-actions (ctx msg &optional (acts #'actions))
   (let ((hdlrs (select msg (funcall acts ctx))))

test/etc/config-web.lisp

@@ -5,7 +5,7 @@
 (config:root :env-keys '(:address :port))
 
 (config:add :logger  :class 'logging:config
-            :loglevel :info
+            :loglevel :debug
             :logfile (t:test-path "scopes-test.log" "log")
             :console nil)
 
@@ -15,6 +15,7 @@
               `((("api") server:message-handler)
                 (() server:fileserver 
                     :doc-root ,(t:test-path "" "docs"))))
+(config:add-action '(:test :data) #'(lambda (ctx msg)))
 
 (config:add :client :class 'client:config
             :base-url "http://localhost:8899"

web/server.lisp

@@ -4,6 +4,7 @@
   (:use :common-lisp)
   (:local-nicknames (:config :scopes/config)
                     (:core :scopes/core)
+                    (:message :scopes/core/message)
                     (:alx :alexandria))
   (:export #:config #:address #:port #:routes
            #:*listener* #:setup #:start #:stop
@@ -22,9 +23,10 @@
 ;;;; listener = server process
 
 (defun app (ctx env)
-  ;(print env)
+  (log:info "request: ~a ~a, accept: ~a" 
-  (log:info "request: ~a ~a" (getf env :request-method) (getf env :request-uri))
+            (getf env :request-method) 
-  (log:info "headers: ~s" (alx:hash-table-plist (getf env :headers)))
+            (getf env :request-uri)
+            (gethash "accept" (getf env :headers)))
   (funcall (select-app ctx env)))
 
 (defun start (ctx)
@@ -35,7 +37,8 @@
                      :address (address cfg)
                      ;:server :woo
                      :silent t))
-    (log:info "port: ~a." (port cfg))))
+    (log:info "port: ~a." (port cfg))
+    ctx))
 
 (defun stop (ctx)
   (clack:stop (listener ctx)))
@@ -48,17 +51,15 @@
     (let* ((rel-path (str:join "/" message-head))
            (file-app (make-instance 'lack/app/file:lack-app-file 
                                     :file rel-path :root doc-root)))
-      ;(format t "~&file path: ~s~%" (merge-pathnames rel-path doc-root))
-      ;(format t "~&file head: ~s, rel-path ~s~%" message-head rel-path)
       (lack/component:call file-app env))))
 
 (defun message-handler (ctx env)
-  ;(print env)
+  (let* ((resp (make-response ctx))
-  ;(print (read-line (getf env :raw-body)))
+         (msg (message:make-message (head env) :data (plist (post-data env)))))
-  (let ((head (head env))
+    (log:debug "msg ~s" msg)
-        (data (plist (post-data env))))
+    (if (core:handle-message ctx msg)
-    (format t "~&message head ~s, data ~s~%" head data)
+      '(200 (:content-type "text/plain") ("Hello World!"))
-    '(200 (:content-type "text/plain") ("Hello World!"))))
+      '(404 (:content-type "text/plain") ("Not found")))))
 
 (defun select-app (ctx env)
   (let ((path (cdr (str:split "/" (getf env :path-info)))))
@@ -70,12 +71,15 @@
   (message-handler ctx env))
 
 (defun match (pattern path)
-    ;(format t "~&match: pattern ~s, path ~s" pattern path)
     (dolist (e pattern)
       (unless (string= e (pop path))
         (return-from match nil)))
   t)
 
+;;;; server response - provice response body and headers
+
+(defun make-response (ctx))
+
 ;;;; server context (= service)
 
 (defclass context (core:context) 
@@ -83,8 +87,7 @@
 
 (defun setup (cfg)
   (let ((ctx (make-instance 'context :config cfg :name (config:name cfg))))
-    (start ctx)
+    (start ctx)))
-    ctx))
 
 ;;;; helper functions