Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
init
  • Loading branch information
hairyhum committed Jun 24, 2011
1 parent 1b3def7 commit ddc6527
Show file tree
Hide file tree
Showing 214 changed files with 13,426 additions and 0 deletions.
17 changes: 17 additions & 0 deletions .project
@@ -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>
133 changes: 133 additions & 0 deletions src/controller.lisp
@@ -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))
55 changes: 55 additions & 0 deletions src/core.lisp
@@ -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")))


43 changes: 43 additions & 0 deletions src/debug.lisp
@@ -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)
28 changes: 28 additions & 0 deletions src/defpackage.lisp
@@ -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
))

68 changes: 68 additions & 0 deletions src/dispatcher.lisp
@@ -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))

0 comments on commit ddc6527

Please sign in to comment.