diff --git a/core/core.lisp b/core/core.lisp index 1352bce..ac9b8e6 100644 --- a/core/core.lisp +++ b/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)) - (if (not (do-actions ctx msg #'default-actions)) - (log:warn "no action selected for ~s" msg))))) + (cond + ((do-actions ctx msg) t) + ((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)))) diff --git a/test/etc/config-web.lisp b/test/etc/config-web.lisp index 71695f2..f8aaf07 100644 --- a/test/etc/config-web.lisp +++ b/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" diff --git a/web/server.lisp b/web/server.lisp index 7638e86..b69e8eb 100644 --- a/web/server.lisp +++ b/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" (getf env :request-method) (getf env :request-uri)) - (log:info "headers: ~s" (alx:hash-table-plist (getf env :headers))) + (log:info "request: ~a ~a, accept: ~a" + (getf env :request-method) + (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) - ;(print (read-line (getf env :raw-body))) - (let ((head (head env)) - (data (plist (post-data env)))) - (format t "~&message head ~s, data ~s~%" head data) - '(200 (:content-type "text/plain") ("Hello World!")))) + (let* ((resp (make-response ctx)) + (msg (message:make-message (head env) :data (plist (post-data env))))) + (log:debug "msg ~s" msg) + (if (core:handle-message ctx msg) + '(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) - ctx)) + (start ctx))) ;;;; helper functions