132 lines
4.3 KiB
Common Lisp
132 lines
4.3 KiB
Common Lisp
;;;; cl-scopes/web/server - web server functionality
|
|
|
|
(defpackage :scopes/web/server
|
|
(:use :common-lisp)
|
|
(: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
|
|
#:content
|
|
#:fileserver #:message-handler))
|
|
|
|
(in-package :scopes/web/server)
|
|
|
|
(defclass config (config:base)
|
|
((config:env-slots :initform '(address port))
|
|
(config:setup :initform #'setup)
|
|
(config:shutdown :initform #'stop)
|
|
(address :reader address :initarg :address :initform "localhost")
|
|
(port :reader port :initarg :port :initform "8888")
|
|
(routes :reader routes :initarg :routes :initform nil)))
|
|
|
|
;;;; server context (= service), action handlers
|
|
|
|
(defclass context (core:context)
|
|
((listener :accessor listener)))
|
|
|
|
(defun setup (cfg)
|
|
(let ((ctx (make-instance 'context :config cfg :name (config:name cfg))))
|
|
(start ctx)))
|
|
|
|
;;;; listener = server process
|
|
|
|
(defun app (ctx env)
|
|
;(handler-case ...
|
|
(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)
|
|
(let ((cfg (core:config ctx)))
|
|
(setf (listener ctx)
|
|
(clack:clackup #'(lambda (env) (app ctx env))
|
|
:port (parse-integer (port cfg))
|
|
:address (address cfg)
|
|
;:server :woo
|
|
:silent t))
|
|
(log:info "port: ~a." (port cfg))
|
|
ctx))
|
|
|
|
(defun stop (ctx)
|
|
(clack:stop (listener ctx)))
|
|
|
|
(defun select-app (ctx env)
|
|
(let ((path (cdr (str:split "/" (getf env :path-info)))))
|
|
(dolist (r (routes (core:config ctx)))
|
|
(when (match (car r) path)
|
|
(setf (getf env :message-head) (nthcdr (length (car r)) path))
|
|
(return-from select-app
|
|
#'(lambda () (apply (cadr r) ctx env (cddr r)))))))
|
|
(message-handler ctx env))
|
|
|
|
(defun match (pattern path)
|
|
(dolist (e pattern)
|
|
(unless (string= e (pop path))
|
|
(return-from match nil)))
|
|
t)
|
|
|
|
(defun fileserver (ctx env &key doc-root)
|
|
(let* ((message-head (getf env :message-head))
|
|
(tail (last message-head)))
|
|
(if (string= (car tail) "")
|
|
(setf (car tail) "index.html"))
|
|
(let* ((rel-path (str:join "/" message-head))
|
|
(file-app (make-instance 'lack/app/file:lack-app-file
|
|
:file rel-path :root doc-root)))
|
|
(lack/component:call file-app env))))
|
|
|
|
(defun message-handler (ctx env)
|
|
(let* ((resp (make-instance 'response))
|
|
(msg (message:create
|
|
(head env) :data (plist (post-data env)) :sender resp)))
|
|
(log:debug "msg ~s" msg)
|
|
; (check-auth ctx msg env) => (render-unauthorized ctx msg env)
|
|
(if (core:handle-message ctx msg)
|
|
;(render ctx (message resp) env)
|
|
(list 200 (headers resp) (list (body resp)))
|
|
(list 404 '(:content-type "text/plain") '("Not found")))))
|
|
;(render-not-found ctx env)
|
|
|
|
;;;; server response - provide response data for rendering body and headers
|
|
|
|
(defclass response ()
|
|
((message :accessor message :initform nil)
|
|
(headers :accessor headers :initform '(:content-type "text/plain"))))
|
|
|
|
(defmethod print-object ((r response) s)
|
|
(format s "<response ~s>" (message r)))
|
|
|
|
(defmethod core:send ((r response) msg)
|
|
(log:debug "receiving ~s" msg)
|
|
(setf (message r) msg))
|
|
|
|
(defgeneric body (r)
|
|
(:method ((r response))
|
|
(getf (message:data (message r)) :info)))
|
|
|
|
(defun render (ctx msg env)
|
|
; process special message headers, e.g. (:system :error ...)
|
|
; => set status code, provide additional data elements
|
|
; (gethash "accept" (getf env :headers)) => select output format
|
|
; set headers, render body
|
|
)
|
|
|
|
;;;; helper functions
|
|
|
|
(defun head (env)
|
|
(mapcar #'(lambda (e) (util:to-keyword e)) (getf env :message-head)))
|
|
|
|
(defun post-data (env)
|
|
(if (getf env :content-length)
|
|
(let* ((raw (getf env :raw-body))
|
|
(str (read-line (flexi-streams:make-flexi-stream raw))))
|
|
(quri.decode:url-decode-params str))))
|
|
|
|
(defun plist (alst)
|
|
(let ((a2 (mapcar #'(lambda (p) (cons (util:to-keyword (car p)) (cdr p))) alst)))
|
|
(alx:alist-plist a2)))
|