Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Showing
214 changed files
with
13,426 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,17 @@ | ||
<?xml version="1.0" encoding="UTF-8"?> | ||
<projectDescription> | ||
<name>mvc</name> | ||
<comment></comment> | ||
<projects> | ||
</projects> | ||
<buildSpec> | ||
<buildCommand> | ||
<name>jasko.tim.lisp.lispBuilder</name> | ||
<arguments> | ||
</arguments> | ||
</buildCommand> | ||
</buildSpec> | ||
<natures> | ||
<nature>jasko.tim.lisp.lispNature</nature> | ||
</natures> | ||
</projectDescription> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,133 @@ | ||
;;;; Created on 2011-04-09 15:41:36 | ||
(in-package :mvc) | ||
(defparameter *view-types* | ||
(list (cons :html 'html-view) | ||
(cons :partial 'template-view) | ||
(cons :xml 'template-view) | ||
(cons :json 'json-view))) | ||
(defparameter *action* nil) | ||
(defparameter *around-list* nil) | ||
(defmacro defcontroller | ||
(name &rest params | ||
&key | ||
options | ||
view-type | ||
view-layout | ||
&allow-other-keys) | ||
"Define packeage with given name. TODO define some variables" | ||
(declare (ignore params)) | ||
(let ((defpackage-options (remove-if #'(lambda (opt) | ||
(member (car opt) | ||
'(:export))) | ||
(remove-if-not #'listp options)))) | ||
`(eval-when (:compile-toplevel :load-toplevel :execute) | ||
(let ((package (defpackage ,name ,@defpackage-options (:use :cl :mvc)))) | ||
(push package (default-controllers)) | ||
(defparameter-in-package *mapper* package (default-mapper)) | ||
(defun-in-package index package ()) | ||
(defparameter-in-package *default-action-name* package "index") | ||
(defparameter-in-package *filters* package (list :before nil :after nil :around nil)) | ||
(defparameter-in-package *view-type* package ,(if view-type `',(cdr (assoc view-type *view-types*)) `*default-view-type*)) | ||
;(defparameter-in-package *view-name* package ,@(if view-name view-type *default-view-name*)) | ||
(defparameter-in-package *view-layout* package ,(if view-layout view-layout)) | ||
package)))) | ||
(defparameter *default-controller* (defcontroller "Index")) | ||
(defun process-controller (controller action bindings) | ||
(init-context controller action bindings) | ||
(let ((*package* controller)) | ||
(render-view (apply-with-filters action)))) | ||
(defmacro make-view (&optional params &key name layout type) | ||
(let* ((view-type (or (cdr (assoc type *view-types*)) | ||
(cdr (assoc (get *action* :view-type) *view-types*)) | ||
(find-symbol-value *view-type*))) | ||
(view-name (or name | ||
(get *action* :view-name) | ||
(when (symbolp *action*) (symbol-name *action*)))) | ||
(view-layout (if (or (not (eql 'html-view view-type)) (ajax-request-p)) | ||
nil | ||
(or layout | ||
(get *action* :view-layout) | ||
(find-symbol-value *view-layout*) | ||
(package-name *package*))))) | ||
`(make-instance ',view-type | ||
,@(if (and view-name (not (eql view-type 'json-view))) `(:name ,view-name)) | ||
,@(if (and view-layout (not (eql view-type 'json-view))) `(:layout ,view-layout)) | ||
:params ,params))) | ||
(defun init-context (controller action bindings) | ||
(declare (ignore action)) | ||
(defparameter-in-package *session* controller hunchentoot:*session*) | ||
(defparameter-in-package *cookies-in* controller (hunchentoot:cookies-in*)) | ||
(defparameter-in-package *cookies-out* controller (hunchentoot:cookies-out*)) | ||
(defparameter-in-package *route-params* controller bindings)) | ||
(defun apply-with-filters (action) | ||
(let ((*action* action) | ||
(around (get-filters *package* action :around)) | ||
(before (get-filters *package* action :before)) | ||
(after (get-filters *package* action :after))) | ||
(flet ((apply-filters (filters) | ||
(mapcar #'funcall filters))) | ||
(apply-filters before) | ||
(let ((res (apply-around around))) | ||
(apply-filters after) | ||
res)))) | ||
(defmethod apply-around ((around list)) | ||
(let ((*around-list* (rest around)) | ||
(current (first around))) | ||
(typecase current | ||
(function (funcall current)) | ||
(null (apply *action* (get-action-params))) | ||
(t (call-next-filter))))) | ||
(defun get-action-params () | ||
(find-symbol-value *route-params*)) | ||
(defun call-next-filter () | ||
(apply-around *around-list*)) | ||
(defun get-filters (controller action keyword &aux (action-filter (get action keyword))) | ||
(flet ((is-for-action (filter action) | ||
(if (find action (filter-actions filter)) | ||
(not (slot-value filter 'inverse-actions)) | ||
(slot-value filter 'inverse-actions)))) | ||
(concatenate | ||
'list | ||
(remove-if-not | ||
#'functionp | ||
(mapcar #'filter-func | ||
(remove-if-not | ||
(lambda (filter) | ||
(is-for-action filter action)) | ||
(getf (find-symbol-value *filters* controller) keyword)))) | ||
(to-list action-filter)))) | ||
(defclass filter () | ||
((function :initarg :function :accessor filter-func) | ||
(actions :initform nil :accessor filter-actions) | ||
(inverse-actions :initform t))) | ||
(defmethod initialize-instance :after ((f filter) &key only except) | ||
(if only | ||
(let ((only (to-list only))) | ||
(setf (slot-value f 'inverse-actions) nil) | ||
(setf (filter-actions f) only)) | ||
(when except | ||
(let ((except (to-list except))) | ||
(setf (filter-actions f) except))))) | ||
(defun defilter (func keyword &key only except) | ||
(push (make-instance 'filter :function func :only only :except except) | ||
(getf (symbol-value (find-symbol "*FILTERS*")) keyword))) | ||
(defmacro defaction (name (&rest variables) | ||
(&key | ||
(method :any) | ||
before-filter | ||
after-filter | ||
around-filter | ||
(view-type 'html-view) | ||
view-name | ||
view-layout) | ||
&body body) | ||
`(let ((action (defun ,name (,@(if variables `(&key ,@variables &allow-other-keys))) ,@body))) | ||
(setf (symbol-plist action) | ||
(list :before-filter ,before-filter | ||
:after-filter ,after-filter | ||
:around-filter ,around-filter | ||
:view-type ',view-type | ||
:view-name ,view-name | ||
:method ,method | ||
:view-layout ,view-layout)) | ||
action)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,55 @@ | ||
;;;; Created on 2011-04-12 14:55:49 | ||
(defpackage :core | ||
(:use :cl :routes :hunchentoot :cl-annot)) | ||
(in-package :core) | ||
(annot:enable-annot-syntax) | ||
(defclass mvc-application () | ||
((mapper :initform (make-instance 'routes:mapper)) | ||
(controllers :initform nil) | ||
(routes :initform nil :accessor app-routes))) | ||
@export | ||
(defparameter *acceptors* nil) | ||
(defparameter *DEFAULT-HOST-REDIRECT* nil) | ||
@export | ||
(defparameter *default-controller-name* "index") | ||
@export | ||
(defparameter *default-action-name* "index") | ||
@export | ||
(defparameter *default-view-type* 'html-view) | ||
@export | ||
(defparameter *mvc-application* (make-instance 'mvc-application)) | ||
@export | ||
(defmacro default-mapper () | ||
`(slot-value *mvc-application* 'mapper)) | ||
@export | ||
(defmacro default-controllers () | ||
`(slot-value *mvc-application* 'controllers)) | ||
@export | ||
(defmacro default-routes () | ||
`(app-routes *mvc-application*)) | ||
@export | ||
(defun not-found-if-not (cond) | ||
"Redirect to 404 page if cond" | ||
(or cond | ||
(progn | ||
(setf (hunchentoot:return-code*) | ||
hunchentoot:+HTTP-NOT-FOUND+) | ||
(hunchentoot:abort-request-handler)))) | ||
@export | ||
(defun server-error (&optional err) | ||
(setf (hunchentoot:return-code*) | ||
hunchentoot:+http-internal-server-error+) | ||
(hunchentoot:abort-request-handler)) | ||
@export | ||
(defun default-if (cond) | ||
"Redirect to default page page if cond" | ||
(when cond | ||
(hunchentoot:redirect | ||
(hunchentoot:request-uri*) | ||
:host *default-host-redirect*))) | ||
@export | ||
(defun ajax-request-p () | ||
(when (boundp 'hunchentoot:*request*) | ||
(hunchentoot:header-in* "X-Requested-With"))) | ||
|
||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,43 @@ | ||
;;;; Created on 2011-05-26 21:56:39 | ||
(in-package :mvc) | ||
|
||
(defun kill-all-debugging-threads () | ||
"Used for destroy all debugging threads" | ||
(bt:with-lock-held (*debugging-threads-lock*) | ||
(dolist (thread *debugging-threads*) | ||
(when (ignore-errors | ||
(bt:destroy-thread thread) | ||
t) | ||
(setf *debugging-threads* | ||
(remove thread *debugging-threads*)))))) | ||
|
||
(defun debug-mode-on () | ||
"Enable debug mode" | ||
(setf *catch-errors-p* nil)) | ||
|
||
(defun debug-mode-off (&optional (kill-debugging-threads t)) | ||
"Turn off debug mode" | ||
(setf *catch-errors-p* t) | ||
(when kill-debugging-threads | ||
(kill-all-debugging-threads))) | ||
|
||
(defun maybe-invoke-debugger (condition) | ||
(cond | ||
((null *catch-errors-p*) | ||
(when (< (length *debugging-threads*) *max-debugging-threads*) | ||
(let ((thread (bt:current-thread))) | ||
(bt:with-lock-held (*debugging-threads-lock*) | ||
(push thread *debugging-threads*)) | ||
(unwind-protect | ||
(invoke-debugger condition) | ||
(bt:with-lock-held (*debugging-threads-lock*) | ||
(setf *debugging-threads* | ||
(remove thread *debugging-threads*))))))) | ||
(t (hunchentoot:maybe-invoke-debugger condition)))) | ||
|
||
(defun after-close-swank-connection (connection) | ||
"Turns off debug mode and destroy debugging threads after closing the connection with the swank-server" | ||
(declare (ignore connection)) | ||
(debug-mode-off t)) | ||
|
||
#+swank (swank::add-hook swank::*connection-closed-hook* 'after-close-swank-connection) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,28 @@ | ||
;;;; 2011-04-05 20:32:08 | ||
(in-package :common-lisp-user) | ||
(defpackage :mvc | ||
(:nicknames :mvc) | ||
(:use :cl :iterate :orm :view :core :routing) | ||
(:export | ||
#:fname | ||
#:start | ||
#:stop | ||
#:reset | ||
#:defilter | ||
#:defcontroller | ||
#:defroute | ||
#:defaction | ||
#:make-view | ||
#:render-template | ||
:table | ||
:deftable | ||
:create-instance | ||
:fetch | ||
:record | ||
:save | ||
:save-slots | ||
:destroy | ||
:destroy-instance | ||
:destroy-records | ||
)) | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,68 @@ | ||
;;;; Created on 2011-04-10 17:19:02 | ||
(in-package :mvc) | ||
(defclass mvc-generic-acceptor () ()) | ||
(defclass mvc-acceptor (hunchentoot:acceptor mvc-generic-acceptor) ()) | ||
(defclass mvc-ssl-acceptor (hunchentoot:ssl-acceptor mvc-generic-acceptor) ()) | ||
(defun dispatch-request (acceptor request) | ||
"Parse route and execute its processing" | ||
(declare (ignore acceptor)) | ||
(let ((mapper | ||
(slot-value *mvc-application* 'core::mapper)) | ||
(hunchentoot:*request* request)) | ||
(not-found-if-not mapper) | ||
(handler-case | ||
(multiple-value-bind (route bindings) (routes:match mapper (hunchentoot:request-uri*)) | ||
(not-found-if-not route) | ||
(process-route route (alexandria:alist-plist bindings))) | ||
(condition (err) (format nil "~a" err))))) | ||
(defgeneric process-route (route bindings) | ||
(:documentation "Select controller. Init controller context and call action")) | ||
(defparameter *bindings* nil) | ||
(defparameter *route* nil) | ||
(defmethod process-route | ||
((route route) bindings &aux (bindings (apply-defaults bindings route))) | ||
(let* ((controller | ||
(not-found-if-not | ||
(find-package (string-upcase | ||
(or (getf bindings :controller) | ||
(route-controller route)))))) | ||
(action | ||
(find-symbol (string-upcase | ||
(or (nil-if-empty (getf bindings :action)) | ||
(route-action route))) | ||
controller)) | ||
(*route* route)) | ||
(not-found-if-not (fboundp action)) | ||
(process-controller controller action bindings))) | ||
(defun apply-defaults (bindings route) | ||
(concatenate 'list bindings (route-defaults route))) | ||
(defun start (&key | ||
ssl-certificate-file | ||
ssl-privatekey-file | ||
ssl-privatekey-password | ||
(port (if ssl-certificate-file 443 80))) | ||
"Start mvc acceptor" | ||
(unless (find port *acceptors* :key #'hunchentoot:acceptor-port) | ||
(push (hunchentoot:start | ||
(if ssl-certificate-file | ||
(make-instance 'mvc-ssl-acceptor | ||
:ssl-certificate-file ssl-certificate-file | ||
:ssl-privatekey-file ssl-privatekey-file | ||
:ssl-privatekey-password ssl-privatekey-password | ||
:port port) | ||
(make-instance 'mvc-acceptor | ||
:port port))) | ||
*acceptors*))) | ||
(defun stop () | ||
(mapcar #'hunchentoot:stop *acceptors*) | ||
(setq *acceptors* nil)) | ||
(defun reset () | ||
(stop) | ||
(setf (default-routes) nil) | ||
(routes:reset-mapper (default-mapper))) | ||
(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) | ||
(defmethod hunchentoot:handle-request ((acceptor mvc-acceptor) request) | ||
(setf (hunchentoot:reply-external-format*) (flex:make-external-format :utf-8 :eol-style :lf)) | ||
(setf (hunchentoot:content-type*) "text/html; charset=utf-8") | ||
(dispatch-request acceptor request)) | ||
|
Oops, something went wrong.