Define app for each controllers.

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
-                #:<app>)
-  (: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 (<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)

controller.lisp

@@ -0,0 +1,96 @@
+(in-package #:cl-user)
+(defpackage utopian/controller
+  (:use #:cl)
+  (:import-from #:ningle)
+  (:import-from #:caveman2
+                #:<app>
+                #: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 (<app>) ())
+
+(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)))))

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*))

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 -%>

skeleton/controller/action.lisp

@@ -1,3 +1,4 @@
+@route GET "/<% @var name %>"
 (defun <% @var name %> (params)
   (declare (ignore params))
   (render nil))

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

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

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 %>))

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

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)