Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Big changes. New architecture: hierarchical modules.

  • Loading branch information...
commit 2b938988e36a51f42da1e1277d05e935b5797843 1 parent 633d331
@archimag authored
View
47 src/hunchentoot.lisp
@@ -11,6 +11,27 @@
(setf hunchentoot:*hunchentoot-default-external-format* hunchentoot::+utf-8+)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; redirect
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun apply-format-aux (format args)
+ (if (symbolp format)
+ (apply #'restas:genurl format args)
+ (if args
+ (apply #'format nil (cons format args))
+ format)))
+
+(defun redirect (route-symbol &rest args)
+ (hunchentoot:redirect
+ (hunchentoot:url-decode
+ (apply-format-aux route-symbol
+ (mapcar #'(lambda (s)
+ (if (stringp s)
+ (hunchentoot:url-encode s)
+ s))
+ args)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debuggable-acceptor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -58,10 +79,10 @@
;; dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defparameter *acceptors* nil)
-
(defparameter *default-host-redirect* nil)
+(defvar *request-pool*)
+
(defun header-host (request)
(cdr (assoc :host (hunchentoot:headers-in request))))
@@ -89,18 +110,11 @@
(setf (hunchentoot:return-code*)
hunchentoot:+HTTP-NOT-FOUND+))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; start
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; redirect
-
-(defun redirect (route-symbol &rest args)
- (hunchentoot:redirect
- (hunchentoot:url-decode
- (apply-format-aux route-symbol
- (mapcar #'(lambda (s)
- (if (stringp s)
- (hunchentoot:url-encode s)
- s))
- args)))))
+(defparameter *acceptors* nil)
(defun reconnect-all-routes ()
(iter (for acceptor in *acceptors*)
@@ -136,11 +150,4 @@
(slot-value vhost 'modules))
(reconnect-all-routes)))
-
-(defun site-url (submodule route-symbol &rest args)
- (if submodule
- (with-context (slot-value submodule 'context)
- (apply 'genurl route-symbol args))
- (apply 'genurl route-symbol args)))
-
View
57 src/module.lisp
@@ -25,6 +25,10 @@
(finalize-module-instance (find-package module)
context))))
+(defparameter +routes-symbol+ "*ROUTES*")
+(defparameter +baseurl-symbol+ "*BASEURL*")
+(defparameter +submodules-symbol+ "*SUBMODULES*")
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; submodule
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -37,34 +41,47 @@
(defmacro with-submodule-context (submodule &body body)
`(with-context (slot-value ,submodule 'context)
,@body))
+
+(defun submodule-baseurl (submodule)
+ (with-submodule-context submodule
+ (symbol-value (find-symbol +baseurl-symbol+
+ (slot-value submodule 'module)))))
+
+(defun submodule-full-baseurl (submodule)
+ (let ((prefix (submodule-baseurl submodule))
+ (parent (slot-value submodule 'parent)))
+ (if parent
+ (concatenate 'list
+ (submodule-full-baseurl parent)
+ prefix)
+ prefix)))
+
+(defun submodule-toplevel (submodule)
+ (let ((parent (slot-value submodule 'parent)))
+ (if parent
+ (submodule-toplevel parent)
+ submodule)))
-(defgeneric module-routes (module)
+(defgeneric module-routes (module submodule)
(:documentation "List routes of the module")
- (:method ((module symbol))
- (module-routes (find-package module))))
+ (:method ((module symbol) submodule)
+ (module-routes (find-package module)
+ submodule)))
(defun submodule-routes (submodule)
(with-submodule-context submodule
- (iter (for route in (module-routes (slot-value submodule 'module)))
- (unless (slot-value route 'submodule)
- (setf (slot-value route 'submodule)
- submodule))
+ (iter (for route in (module-routes (slot-value submodule 'module)
+ submodule))
(collect route))))
-
(defun connect-submodule (submodule mapper)
(iter (for route in (submodule-routes submodule))
(routes:connect mapper route)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; package as module
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defparameter +routes-symbol+ "*ROUTES*")
-(defparameter +baseurl-symbol+ "*BASEURL*")
-(defparameter +submodules-symbol+ "*SUBMODULES*")
-
(defmacro define-module (name &rest options)
(let* ((use (cdr (assoc :use options)))
(export (cdr (assoc :export options)))
@@ -89,15 +106,17 @@
`(defmethod finalize-module-instance ((module (eql ,*package*)) ,context)
,@body))
-(defmethod module-routes ((module package))
+(defmethod module-routes ((module package) submodule)
(alexandria:flatten (list* (iter (for route-symbol in-package (symbol-value (find-symbol +routes-symbol+ module)))
(collect (funcall (get (find-symbol (symbol-name route-symbol)
module)
- :initialize))))
- (let ((submodules (symbol-value (find-symbol +submodules-symbol+ module))))
- (if submodules
- (iter (for (key submodule) in-hashtable submodules)
- (collect (submodule-routes submodule))))))))
+ :initialize)
+ submodule)))
+ (iter (for (key sub) in-hashtable (symbol-value (find-symbol +submodules-symbol+ module)))
+ (collect (submodule-routes (make-instance 'submodule
+ :module (slot-value sub 'module)
+ :context (slot-value sub 'context)
+ :parent submodule)))))))
(defmacro define-submodule (name (module) &body bindings)
(let ((submodules (find-symbol +submodules-symbol+)))
View
17 src/packages.lisp
@@ -12,7 +12,6 @@
#:*bindings*
#:define-route
#:define-module
- #:plugin-update
#:make-context
#:context-add-variable
@@ -32,11 +31,10 @@
#:parse-host
#:start
- #:reconnect-all-plugins
- #:expand-text
- #:expand-file
+ #:reconnect-all-routes
#:genurl
+ #:genurl-toplevel
#:genurl-with-host
#:apply-format-aux
#:redirect
@@ -44,14 +42,5 @@
#:restas-request-bindings
#:process-route
- #:defhost
#:define-submodule
- #:*default-host-redirect*
-
- #:site-url))
-
-
-(in-package :restas)
-
-(defvar *request-pool*)
-(defvar *bindings*)
+ #:*default-host-redirect*))
View
82 src/route.lisp
@@ -8,20 +8,13 @@
(in-package :restas)
-(defgeneric process-route (route bindings))
-
(defvar *route* nil)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; routes
+(defvar *bindings*)
-(defun parse-template/package (tmpl package &optional parse-vars)
- (concatenate 'list
- (symbol-value (find-symbol +baseurl-symbol+ package))
- (routes:parse-template tmpl parse-vars)))
-
-(defun routes/package ()
- (symbol-value (find-symbol +routes-symbol+ *package*)))
+
+(defgeneric process-route (route bindings))
+(defgeneric process-route/impl (route bindings))
(defclass base-route (routes:route)
((submodule :initarg :submodule :initform nil)
@@ -29,8 +22,6 @@
(required-method :initarg :required-method :initform nil :reader route-required-method)
(arbitrary-requirement :initarg :arbitrary-requirement :initform nil :reader route-arbitrary-requirement)))
-(defgeneric process-route/impl (route bindings))
-
(defmethod routes:route-check-conditions ((route base-route) bindings)
(with-context (slot-value (slot-value route 'submodule)
'context)
@@ -55,14 +46,12 @@
(or (route-content-type route)
"text/html"))
res)))))
-
-
(defclass simple-route (base-route)
((symbol :initarg :symbol)))
(defmethod process-route ((route simple-route) bindings)
- (let ((*route* (slot-value route 'symbol)))
+ (let ((*route* route))
(call-next-method)))
(defmethod process-route/impl ((route simple-route) bindings)
@@ -71,12 +60,7 @@
(defmacro define-route (name (template &key content-type (method :get) requirement parse-vars) &body body)
- (let* ((package (symbol-package name))
- (parsed-template (parse-template/package (if (stringp template)
- template
- (eval template))
- package))
- (variables (iter (for var in (routes.unify:template-variables parsed-template))
+ (let* ((variables (iter (for var in (routes.unify:template-variables (routes:parse-template template)))
(collect (list (intern (symbol-name var))
(list 'cdr (list 'assoc var '*bindings*))))))
(handler-body (if variables
@@ -87,25 +71,32 @@
#'(lambda ()
,@handler-body))
(setf (get ',name :template)
- '(parse-template/package ,template ,package))
+ (routes:parse-template ,template))
(setf (get ',name :initialize)
- #'(lambda () (make-instance 'simple-route
- :template (parse-template/package ,template ,package ,parse-vars)
- :symbol ',name
- :content-type (or ,content-type "text/html")
- :required-method ,method
- :arbitrary-requirement ,requirement)))
- (intern (symbol-name ',name) (routes/package))
+ #'(lambda (submodule)
+ (make-instance 'simple-route
+ :template (concatenate 'list
+ (submodule-full-baseurl submodule)
+ (routes:parse-template ,template ,parse-vars))
+ :symbol ',name
+ :content-type (or ,content-type "text/html")
+ :required-method ,method
+ :arbitrary-requirement ,requirement
+ :submodule submodule)))
+ (intern (symbol-name ',name)
+ (symbol-value (find-symbol +routes-symbol+)))
(export ',name)
(eval-when (:execute)
(reconnect-all-routes)))))
-;;; generate-route-url
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; generate url by route
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun genurl (route-symbol &rest args)
+(defun genurl/impl (tmpl args)
(format nil
- "/~{~A~^/~}"
- (routes::apply-bindings (eval (get route-symbol :template))
+ "/~{~A~^/~}"
+ (routes::apply-bindings tmpl
(iter (for pair in (alexandria:plist-alist args))
(collect (cons (car pair)
(if (or (stringp (cdr pair))
@@ -113,6 +104,23 @@
(cdr pair)
(write-to-string (cdr pair)))))))))
+
+(defun genurl (route-symbol &rest args)
+ (genurl/impl (concatenate 'list
+ (submodule-full-baseurl (slot-value *route* 'submodule))
+ (get route-symbol :template))
+ args))
+
+(defun genurl-toplevel (submodule route-symbol &rest args)
+ (genurl/impl (concatenate 'list
+ (submodule-full-baseurl (submodule-toplevel (slot-value *route* 'submodule)))
+ (if submodule
+ (submodule-baseurl submodule))
+ (get route-symbol :template))
+ args))
+
+
+
(defun genurl-with-host (route &rest args)
(format nil
"http://~A~A"
@@ -120,9 +128,3 @@
(apply #'restas:genurl route args)))
-(defun apply-format-aux (format args)
- (if (symbolp format)
- (apply #'restas:genurl format args)
- (if args
- (apply #'format nil (cons format args))
- format)))
Please sign in to comment.
Something went wrong with that request. Please try again.