From cb8267df6c7a53f84baff710f16c392d62b18f07 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Thu, 25 Feb 2016 12:06:42 +0900 Subject: [PATCH] Define app for each controllers. --- app.lisp | 155 ++++++++++------------- controller.lisp | 96 ++++++++++++++ package.lisp | 9 +- skeleton/controller.lisp | 5 + skeleton/controller/action.lisp | 1 + skeleton/project/config/application.lisp | 3 +- skeleton/project/config/routes.lisp | 3 +- skeleton/project/skeleton.asd | 3 +- utopian.asd | 2 + view.lisp | 3 +- 10 files changed, 186 insertions(+), 94 deletions(-) create mode 100644 controller.lisp diff --git a/app.lisp b/app.lisp index 3635f7b..3432f18 100644 --- a/app.lisp +++ b/app.lisp @@ -1,90 +1,79 @@ (in-package #:cl-user) (defpackage utopian/app (:use #:cl) - (:import-from #:ningle - #:not-found) + (:import-from #:utopian/controller + #:controller + #:find-controller + #:find-controller-package + #:%route) (:import-from #:caveman2 - #:) - (:import-from #:caveman2 - #:on-exception - #:throw-code - #:clear-routing-rules - #:next-route #:*request* #:*response* - #:*session*) + #:*session* + #:throw-code + #:on-exception + #:redirect) (:import-from #:myway #:make-mapper + #:next-route #:dispatch) + (:import-from #:lack.component + #:call) (:import-from #:lack.request - #:request-parameters #:request-path-info - #:request-method) + #:request-method + #:request-env) (:import-from #:djula #:add-template-directory) (:export #:base-app #:project-root #:project-path - #:connect - #:route - #:next-route + #:mount #:redirect-to + + ;; from MyWay + #:next-route + + ;; from Caveman2 #:*request* #:*response* #:*session* - #:*action* - - ;; From Caveman2 #:on-exception - #:throw-code - #:clear-routing-rules)) + #:throw-code)) (in-package #:utopian/app) -(defparameter *action* nil) - (defvar *package-app* (make-hash-table :test 'eq)) (defvar *current-app*) -(defclass base-app () +(defun package-system (package) + (asdf:find-system + (asdf/package-inferred-system::package-name-system (package-name package)))) + +(defclass base-app (controller) ((root :initarg :root + :initform (asdf:component-pathname (package-system *package*)) :accessor app-root) (name :initarg :name + :initform (string-downcase + (ppcre:scan-to-strings "^[^/]+" + (asdf:component-name + (package-system *package*)))) :accessor app-name))) (defparameter *default-mapper* (myway:make-mapper)) -(defun find-controller (controller-name) - (let* ((package-name (format nil "~(~A~)/controllers/~(~A~)" - (app-name *current-app*) - controller-name)) - (controller (asdf:find-system package-name nil))) - (when controller - (asdf:load-system controller) - (find-package (string-upcase package-name))))) - -(defun find-controller-action (controller-name action-name) - (let ((controller (find-controller controller-name))) - (when controller - (multiple-value-bind (fn status) - (intern (string-upcase action-name) controller) - (when (and (fboundp fn) - (eq status :external)) - fn))))) - -(defun call-default-or-next (url-params) - (let ((action (find-controller-action - (getf url-params :controller) - (or (getf url-params :action) :index)))) - (if action - (let ((*action* action)) - (funcall action - (append (request-parameters *request*) - (loop for (k v) on url-params by #'cddr - collect (cons k v))))) - (throw-code 404)))) - -(myway:connect *default-mapper* "/:controller/?:action?/?:id?.?:format?" #'call-default-or-next) +(myway:connect *default-mapper* "/:controller/?:action?" + (lambda (url-params) + (let ((controller (find-controller (app-name *current-app*) + (getf url-params :controller)))) + (if controller + (let ((env (lack.request:request-env *request*))) + (setf (getf env :path-info) (format nil "/~A" + (or (getf url-params :action) ""))) + (call controller env)) + (throw-code 404)))) + :method :any) (defmethod ningle:not-found ((app base-app)) (multiple-value-bind (res foundp) @@ -102,47 +91,37 @@ (defun project-path (path) (merge-pathnames path (project-root))) -(defun package-system (package) - (asdf:find-system - (asdf/package-inferred-system::package-name-system (package-name package)))) - (defmethod initialize-instance :after ((app base-app) &rest initargs) (declare (ignore initargs)) - (unless (and (slot-boundp app 'root) - (slot-value app 'root)) - (setf (slot-value app 'root) - (asdf:component-pathname (package-system *package*)))) - (unless (and (slot-boundp app 'name) - (slot-value app 'name)) - (setf (slot-value app 'name) - (string-downcase - (ppcre:scan-to-strings "^[^/]+" - (asdf:component-name - (package-system *package*)))))) (djula:add-template-directory - (merge-pathnames #P"views/" (slot-value app 'root))) + (merge-pathnames #P"views/" (app-root app))) (setf (gethash *package* *package-app*) app) (setf *current-app* app)) -(defgeneric connect (app url action &key method regexp) - (:method ((app base-app) url action &key (method :get) regexp) - (setf (ningle:route app url :method method :regexp regexp) - (etypecase action - (function action) - (string - (let ((match - (nth-value 1 (ppcre:scan-to-strings "^([^:]+)::?(.+)$" - action)))) - (unless match - (error "Invalid controller: ~A" action)) - (let ((action (find-controller-action (aref match 0) (aref match 1)))) - (lambda (params) - (let ((*action* action)) - (funcall (fdefinition action) - (caveman2.nested-parameter:parse-parameters params))))))))))) - -(defun route (method url fn &key regexp) - (connect (gethash *package* *package-app*) url fn :method method :regexp regexp)) +(defun mount (mount-path controller) + (check-type controller string) + ;; Ensure the mount-path ends with "/". + (setf mount-path + (ppcre:regex-replace "/?$" mount-path "/")) + (let ((package (find-controller-package (app-name *current-app*) controller))) + (unless package + (error "Unknown (or internal) controller: ~A" controller)) + + (%route :any (format nil "~A*" mount-path) + (lambda (params) + (let ((path-info (request-path-info *request*))) + (cond + ((string= path-info mount-path) + (setf (request-path-info *request*) "/") + (call (gethash package *package-app*) params)) + ((and (< (length mount-path) + (length path-info)) + (string= path-info mount-path :end1 (length mount-path))) + (setf (request-path-info *request*) + (subseq path-info (length mount-path))) + (call (gethash package *package-app*) params)) + (t + (throw-code 404)))))))) ;; Rename the name of 'redirect' to 'redirect-to' (setf (fdefinition 'redirect-to) #'caveman2:redirect) diff --git a/controller.lisp b/controller.lisp new file mode 100644 index 0000000..7e2ad4b --- /dev/null +++ b/controller.lisp @@ -0,0 +1,96 @@ +(in-package #:cl-user) +(defpackage utopian/controller + (:use #:cl) + (:import-from #:ningle) + (:import-from #:caveman2 + #: + #:clear-routing-rules) + (:import-from #:cl-annot + #:defannotation) + (:import-from #:cl-annot.util + #:definition-form-type + #:definition-form-symbol + #:progn-form-last) + (:export #:controller + #:controller-instance + #:find-controller + #:find-controller-package + #:route + #:*action*)) +(in-package #:utopian/controller) + +(defvar *action*) + +(defclass controller () ()) + +(defvar *package-controller* (make-hash-table :test 'eq)) + +(defmethod initialize-instance :around ((controller controller) &rest initargs) + (declare (ignore initargs)) + (let ((instance (gethash *package* *package-controller*))) + (if instance + (progn + (clear-routing-rules instance) + instance) + (let ((instance (call-next-method))) + (setf (gethash *package* *package-controller*) instance) + instance)))) + +(defun find-controller-package (app-name name) + (let* ((package-name (format nil "~(~A~)/controllers/~(~A~)" + app-name + name)) + (controller (asdf:find-system package-name nil))) + (when controller + (asdf:load-system controller) + (find-package (string-upcase package-name))))) + +(defun find-controller (app-name name) + (let ((package (find-controller-package app-name name))) + (when package + (find-current-controller package)))) + +(defun find-current-controller (&optional (package *package*)) + (values (gethash package *package-controller*))) + +(defun canonicalize-method (method) + (etypecase method + (list (mapcar #'canonicalize-method method)) + (keyword method) + (symbol (intern (symbol-name method) :keyword)))) + +(defun %route (method url fn &key regexp identifier) + (when (stringp fn) + (destructuring-bind (controller action) + (ppcre:split "::?" fn) + (let ((package (find-controller-package (ppcre:scan-to-strings "^[^/]+" (package-name *package*)) + controller))) + (unless package + (error "Unknown package: ~A" controller)) + (multiple-value-bind (controller status) + (intern (string-upcase action) package) + (unless (and (eq status :external) + (fboundp controller)) + (error "Controller is not defined or internal")) + (setf fn (symbol-function controller)))))) + (let ((controller (find-current-controller))) + (setf (ningle:route controller url :method method :regexp regexp :identifier identifier) + (lambda (params) + (let ((*action* identifier)) + (funcall fn params)))))) + +(defannotation route (method routing-rule form) + (:arity 3) + (let* ((last-form (progn-form-last form)) + (type (definition-form-type last-form)) + (symbol (definition-form-symbol last-form)) + (method (canonicalize-method method))) + (case type + (cl:lambda + `(%route ',method ,routing-rule ,form)) + (cl:defun + `(progn + (%route ',method ,routing-rule ,form :identifier ',symbol) + ',symbol)) + ('nil + `(%route ,method ,routing-rule ,form))))) diff --git a/package.lisp b/package.lisp index 822f153..8d9ad78 100644 --- a/package.lisp +++ b/package.lisp @@ -6,4 +6,11 @@ :utopian/app :utopian/skeleton :utopian/watcher - :utopian/tasks)) + :utopian/tasks) + (:import-from :utopian/controller + :controller + :route + :*action*) + (:export :controller + :route + :*action*)) diff --git a/skeleton/controller.lisp b/skeleton/controller.lisp index 2ca23d9..97dc235 100644 --- a/skeleton/controller.lisp +++ b/skeleton/controller.lisp @@ -5,6 +5,11 @@ <%- @endloop %>)) (in-package :<% @var appname %>/controllers/<% @var name %>) +(syntax:use-syntax :annot) + +(defclass <% @var name %> (controller) ()) +(defparameter *<% @var name %>* (make-instance '<% @var name %>)) + <%- @loop actions %> <% @include controller/action.lisp %> <%- @endloop -%> diff --git a/skeleton/controller/action.lisp b/skeleton/controller/action.lisp index 353be65..f1dcdd5 100644 --- a/skeleton/controller/action.lisp +++ b/skeleton/controller/action.lisp @@ -1,3 +1,4 @@ +@route GET "/<% @var name %>" (defun <% @var name %> (params) (declare (ignore params)) (render nil)) diff --git a/skeleton/project/config/application.lisp b/skeleton/project/config/application.lisp index 12485fe..e43807b 100644 --- a/skeleton/project/config/application.lisp +++ b/skeleton/project/config/application.lisp @@ -4,7 +4,8 @@ (:export :application)) (in-package :<% @var name %>/config/application) -(defclass application (utopian:base-app) ()) +(defclass application (base-app) ()) + ;; ;; Error pages diff --git a/skeleton/project/config/routes.lisp b/skeleton/project/config/routes.lisp index 0d96a6c..5194954 100644 --- a/skeleton/project/config/routes.lisp +++ b/skeleton/project/config/routes.lisp @@ -5,8 +5,7 @@ (:export :*app*)) (in-package :<% @var name %>/config/routes) -(defvar *app* (make-instance 'application)) -(clear-routing-rules *app*) +(defparameter *app* (make-instance 'application)) ;; ;; Routing rules diff --git a/skeleton/project/skeleton.asd b/skeleton/project/skeleton.asd index eea8fbc..52a2ebf 100644 --- a/skeleton/project/skeleton.asd +++ b/skeleton/project/skeleton.asd @@ -5,6 +5,7 @@ :author "<% @var author %>" :license "<% @var license %>" :description "<% @var description %>" - :depends-on ("<% @var name %>/boot")) + :depends-on ("<% @var name %>/boot" + :cl-syntax-annot)) (asdf:register-system-packages "<% @var name %>/boot" '(:<% @var name %>)) diff --git a/utopian.asd b/utopian.asd index 4b460a2..74e7cd0 100644 --- a/utopian.asd +++ b/utopian.asd @@ -13,3 +13,5 @@ (asdf:register-system-packages "lack-component" '(#:lack.component)) (asdf:register-system-packages "lack-request" '(#:lack.request)) (asdf:register-system-packages "lack-middleware-csrf" '(#:lack.middleware.csrf)) +(asdf:register-system-packages "cl-annot" '(#:cl-annot #:cl-annot.util)) +(asdf:register-system-packages "ningle" '(#:ningle #:ningle.app)) diff --git a/view.lisp b/view.lisp index 5b86391..fc3441b 100644 --- a/view.lisp +++ b/view.lisp @@ -2,7 +2,8 @@ (defpackage utopian/view (:use #:cl) (:import-from #:utopian/app - #:*session* + #:*session*) + (:import-from #:utopian/controller #:*action*) (:import-from #:lack.middleware.csrf) (:import-from #:jonathan)