Permalink
Browse files

init

  • Loading branch information...
1 parent 1b3def7 commit ddc6527edba209d1d0b41e7451477946b94a3039 @hairyhum hairyhum committed Jun 24, 2011
Showing with 13,426 additions and 0 deletions.
  1. +17 −0 .project
  2. +133 −0 src/controller.lisp
  3. +55 −0 src/core.lisp
  4. +43 −0 src/debug.lisp
  5. +28 −0 src/defpackage.lisp
  6. +68 −0 src/dispatcher.lisp
  7. +49 −0 src/extensions.lisp
  8. +33 −0 src/mvc.asd
  9. +30 −0 src/orm/defpackage.lisp
  10. +33 −0 src/orm/orm.lisp
  11. +37 −0 src/orm/record.lisp
  12. +176 −0 src/orm/table.lisp
  13. +47 −0 src/render.lisp
  14. +77 −0 src/routing.lisp
  15. +42 −0 src/template.lisp
  16. +40 −0 src/testfile.lisp
  17. +44 −0 src/view.lisp
  18. +20 −0 src/view/defpackage.lisp
  19. +47 −0 src/view/render.lisp
  20. +42 −0 src/view/template.lisp
  21. +46 −0 src/view/view.lisp
  22. +40 −0 test/authorization.lisp
  23. +22 −0 test/dash.lisp
  24. +7 −0 test/defpackage.lisp
  25. +122 −0 test/model/CRUD.lisp
  26. +8 −0 test/model/database.lisp
  27. +27 −0 test/model/defpackage.lisp
  28. +27 −0 test/model/send-mail.lisp
  29. +92 −0 test/model/tables.lisp
  30. +32 −0 test/model/tabs.lisp
  31. +72 −0 test/model/tasks.lisp
  32. +26 −0 test/model/user.lisp
  33. +9 −0 test/routes.lisp
  34. +4 −0 test/start.lisp
  35. +29 −0 test/tabs.lisp
  36. +24 −0 test/tasks.lisp
  37. +69 −0 test/testfile.lisp
  38. +33 −0 test/todotree.asd
  39. +11 −0 test/views/css/cupertino/.svn/all-wcprops
  40. +65 −0 test/views/css/cupertino/.svn/entries
  41. +578 −0 test/views/css/cupertino/.svn/text-base/jquery-ui-1.8.13.custom.css.svn-base
  42. +89 −0 test/views/css/cupertino/images/.svn/all-wcprops
  43. +504 −0 test/views/css/cupertino/images/.svn/entries
  44. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_diagonals-thick_90_eeeeee_40x40.png.svn-base
  45. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_flat_15_cd0a0a_40x100.png.svn-base
  46. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_glass_100_e4f1fb_1x400.png.svn-base
  47. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_glass_50_3baae3_1x400.png.svn-base
  48. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_glass_80_d7ebf9_1x400.png.svn-base
  49. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_highlight-hard_100_f2f5f7_1x100.png.svn-base
  50. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_highlight-hard_70_000000_1x100.png.svn-base
  51. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_highlight-soft_100_deedf7_1x100.png.svn-base
  52. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-bg_highlight-soft_25_ffef8f_1x100.png.svn-base
  53. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-icons_2694e8_256x240.png.svn-base
  54. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-icons_2e83ff_256x240.png.svn-base
  55. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-icons_3d80b3_256x240.png.svn-base
  56. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-icons_72a7cf_256x240.png.svn-base
  57. +5 −0 test/views/css/cupertino/images/.svn/prop-base/ui-icons_ffffff_256x240.png.svn-base
  58. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_diagonals-thick_90_eeeeee_40x40.png.svn-base
  59. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_flat_15_cd0a0a_40x100.png.svn-base
  60. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_glass_100_e4f1fb_1x400.png.svn-base
  61. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_glass_50_3baae3_1x400.png.svn-base
  62. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_glass_80_d7ebf9_1x400.png.svn-base
  63. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_highlight-hard_100_f2f5f7_1x100.png.svn-base
  64. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_highlight-hard_70_000000_1x100.png.svn-base
  65. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_highlight-soft_100_deedf7_1x100.png.svn-base
  66. BIN test/views/css/cupertino/images/.svn/text-base/ui-bg_highlight-soft_25_ffef8f_1x100.png.svn-base
  67. BIN test/views/css/cupertino/images/.svn/text-base/ui-icons_2694e8_256x240.png.svn-base
  68. BIN test/views/css/cupertino/images/.svn/text-base/ui-icons_2e83ff_256x240.png.svn-base
  69. BIN test/views/css/cupertino/images/.svn/text-base/ui-icons_3d80b3_256x240.png.svn-base
  70. BIN test/views/css/cupertino/images/.svn/text-base/ui-icons_72a7cf_256x240.png.svn-base
  71. BIN test/views/css/cupertino/images/.svn/text-base/ui-icons_ffffff_256x240.png.svn-base
  72. BIN test/views/css/cupertino/images/ui-bg_diagonals-thick_90_eeeeee_40x40.png
  73. BIN test/views/css/cupertino/images/ui-bg_flat_15_cd0a0a_40x100.png
  74. BIN test/views/css/cupertino/images/ui-bg_glass_100_e4f1fb_1x400.png
  75. BIN test/views/css/cupertino/images/ui-bg_glass_50_3baae3_1x400.png
  76. BIN test/views/css/cupertino/images/ui-bg_glass_80_d7ebf9_1x400.png
  77. BIN test/views/css/cupertino/images/ui-bg_highlight-hard_100_f2f5f7_1x100.png
  78. BIN test/views/css/cupertino/images/ui-bg_highlight-hard_70_000000_1x100.png
  79. BIN test/views/css/cupertino/images/ui-bg_highlight-soft_100_deedf7_1x100.png
  80. BIN test/views/css/cupertino/images/ui-bg_highlight-soft_25_ffef8f_1x100.png
  81. BIN test/views/css/cupertino/images/ui-icons_2694e8_256x240.png
  82. BIN test/views/css/cupertino/images/ui-icons_2e83ff_256x240.png
  83. BIN test/views/css/cupertino/images/ui-icons_3d80b3_256x240.png
  84. BIN test/views/css/cupertino/images/ui-icons_72a7cf_256x240.png
  85. BIN test/views/css/cupertino/images/ui-icons_ffffff_256x240.png
  86. +578 −0 test/views/css/cupertino/jquery-ui-1.8.13.custom.css
  87. BIN test/views/css/d.gif
  88. BIN test/views/css/d.png
  89. BIN test/views/css/loading.gif
  90. +200 −0 test/views/css/style.css
  91. +5 −0 test/views/css/tree-themes/.svn/all-wcprops
  92. +40 −0 test/views/css/tree-themes/.svn/entries
  93. +35 −0 test/views/css/tree-themes/apple/.svn/all-wcprops
  94. +198 −0 test/views/css/tree-themes/apple/.svn/entries
  95. +5 −0 test/views/css/tree-themes/apple/.svn/prop-base/bg.jpg.svn-base
  96. +5 −0 test/views/css/tree-themes/apple/.svn/prop-base/d.png.svn-base
  97. +5 −0 test/views/css/tree-themes/apple/.svn/prop-base/dot_for_ie.gif.svn-base
  98. +5 −0 test/views/css/tree-themes/apple/.svn/prop-base/throbber.gif.svn-base
  99. BIN test/views/css/tree-themes/apple/.svn/text-base/bg.jpg.svn-base
  100. BIN test/views/css/tree-themes/apple/.svn/text-base/d.png.svn-base
  101. BIN test/views/css/tree-themes/apple/.svn/text-base/dot_for_ie.gif.svn-base
  102. +61 −0 test/views/css/tree-themes/apple/.svn/text-base/style.css.svn-base
  103. BIN test/views/css/tree-themes/apple/.svn/text-base/throbber.gif.svn-base
  104. BIN test/views/css/tree-themes/apple/bg.jpg
  105. BIN test/views/css/tree-themes/apple/d.png
  106. BIN test/views/css/tree-themes/apple/dot_for_ie.gif
  107. +61 −0 test/views/css/tree-themes/apple/style.css
  108. BIN test/views/css/tree-themes/apple/throbber.gif
  109. +35 −0 test/views/css/tree-themes/classic/.svn/all-wcprops
  110. +198 −0 test/views/css/tree-themes/classic/.svn/entries
  111. +5 −0 test/views/css/tree-themes/classic/.svn/prop-base/d.gif.svn-base
  112. +5 −0 test/views/css/tree-themes/classic/.svn/prop-base/d.png.svn-base
  113. +5 −0 test/views/css/tree-themes/classic/.svn/prop-base/dot_for_ie.gif.svn-base
  114. +5 −0 test/views/css/tree-themes/classic/.svn/prop-base/throbber.gif.svn-base
  115. BIN test/views/css/tree-themes/classic/.svn/text-base/d.gif.svn-base
  116. BIN test/views/css/tree-themes/classic/.svn/text-base/d.png.svn-base
  117. BIN test/views/css/tree-themes/classic/.svn/text-base/dot_for_ie.gif.svn-base
  118. +77 −0 test/views/css/tree-themes/classic/.svn/text-base/style.css.svn-base
  119. BIN test/views/css/tree-themes/classic/.svn/text-base/throbber.gif.svn-base
  120. BIN test/views/css/tree-themes/classic/d.gif
  121. BIN test/views/css/tree-themes/classic/d.png
  122. BIN test/views/css/tree-themes/classic/dot_for_ie.gif
  123. +77 −0 test/views/css/tree-themes/classic/style.css
  124. BIN test/views/css/tree-themes/classic/throbber.gif
  125. +35 −0 test/views/css/tree-themes/default-rtl/.svn/all-wcprops
  126. +198 −0 test/views/css/tree-themes/default-rtl/.svn/entries
  127. +5 −0 test/views/css/tree-themes/default-rtl/.svn/prop-base/d.gif.svn-base
  128. +5 −0 test/views/css/tree-themes/default-rtl/.svn/prop-base/d.png.svn-base
  129. +5 −0 test/views/css/tree-themes/default-rtl/.svn/prop-base/dots.gif.svn-base
  130. +5 −0 test/views/css/tree-themes/default-rtl/.svn/prop-base/throbber.gif.svn-base
  131. BIN test/views/css/tree-themes/default-rtl/.svn/text-base/d.gif.svn-base
  132. BIN test/views/css/tree-themes/default-rtl/.svn/text-base/d.png.svn-base
  133. BIN test/views/css/tree-themes/default-rtl/.svn/text-base/dots.gif.svn-base
  134. +84 −0 test/views/css/tree-themes/default-rtl/.svn/text-base/style.css.svn-base
  135. BIN test/views/css/tree-themes/default-rtl/.svn/text-base/throbber.gif.svn-base
  136. BIN test/views/css/tree-themes/default-rtl/d.gif
  137. BIN test/views/css/tree-themes/default-rtl/d.png
  138. BIN test/views/css/tree-themes/default-rtl/dots.gif
  139. +84 −0 test/views/css/tree-themes/default-rtl/style.css
  140. BIN test/views/css/tree-themes/default-rtl/throbber.gif
  141. +29 −0 test/views/css/tree-themes/default/.svn/all-wcprops
  142. +164 −0 test/views/css/tree-themes/default/.svn/entries
  143. +5 −0 test/views/css/tree-themes/default/.svn/prop-base/d.gif.svn-base
  144. +5 −0 test/views/css/tree-themes/default/.svn/prop-base/d.png.svn-base
  145. +5 −0 test/views/css/tree-themes/default/.svn/prop-base/throbber.gif.svn-base
  146. BIN test/views/css/tree-themes/default/.svn/text-base/d.gif.svn-base
  147. BIN test/views/css/tree-themes/default/.svn/text-base/d.png.svn-base
  148. +74 −0 test/views/css/tree-themes/default/.svn/text-base/style.css.svn-base
  149. BIN test/views/css/tree-themes/default/.svn/text-base/throbber.gif.svn-base
  150. BIN test/views/css/tree-themes/default/d.gif
  151. BIN test/views/css/tree-themes/default/d.png
  152. +74 −0 test/views/css/tree-themes/default/style.css
  153. BIN test/views/css/tree-themes/default/throbber.gif
  154. +11 −0 test/views/css/ui-lightness/.svn/all-wcprops
  155. +65 −0 test/views/css/ui-lightness/.svn/entries
  156. +578 −0 test/views/css/ui-lightness/.svn/text-base/jquery-ui-1.8.13.custom.css.svn-base
  157. +89 −0 test/views/css/ui-lightness/images/.svn/all-wcprops
  158. +504 −0 test/views/css/ui-lightness/images/.svn/entries
  159. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_diagonals-thick_18_b81900_40x40.png.svn-base
  160. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_diagonals-thick_20_666666_40x40.png.svn-base
  161. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_flat_10_000000_40x100.png.svn-base
  162. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_glass_100_f6f6f6_1x400.png.svn-base
  163. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_glass_100_fdf5ce_1x400.png.svn-base
  164. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_glass_65_ffffff_1x400.png.svn-base
  165. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_gloss-wave_35_f6a828_500x100.png.svn-base
  166. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_highlight-soft_100_eeeeee_1x100.png.svn-base
  167. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-bg_highlight-soft_75_ffe45c_1x100.png.svn-base
  168. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-icons_222222_256x240.png.svn-base
  169. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-icons_228ef1_256x240.png.svn-base
  170. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-icons_ef8c08_256x240.png.svn-base
  171. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-icons_ffd27a_256x240.png.svn-base
  172. +5 −0 test/views/css/ui-lightness/images/.svn/prop-base/ui-icons_ffffff_256x240.png.svn-base
  173. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_diagonals-thick_18_b81900_40x40.png.svn-base
  174. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_diagonals-thick_20_666666_40x40.png.svn-base
  175. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_flat_10_000000_40x100.png.svn-base
  176. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_glass_100_f6f6f6_1x400.png.svn-base
  177. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_glass_100_fdf5ce_1x400.png.svn-base
  178. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_glass_65_ffffff_1x400.png.svn-base
  179. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_gloss-wave_35_f6a828_500x100.png.svn-base
  180. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_highlight-soft_100_eeeeee_1x100.png.svn-base
  181. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-bg_highlight-soft_75_ffe45c_1x100.png.svn-base
  182. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-icons_222222_256x240.png.svn-base
  183. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-icons_228ef1_256x240.png.svn-base
  184. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-icons_ef8c08_256x240.png.svn-base
  185. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-icons_ffd27a_256x240.png.svn-base
  186. BIN test/views/css/ui-lightness/images/.svn/text-base/ui-icons_ffffff_256x240.png.svn-base
  187. BIN test/views/css/ui-lightness/images/ui-bg_diagonals-thick_18_b81900_40x40.png
  188. BIN test/views/css/ui-lightness/images/ui-bg_diagonals-thick_20_666666_40x40.png
  189. BIN test/views/css/ui-lightness/images/ui-bg_flat_10_000000_40x100.png
  190. BIN test/views/css/ui-lightness/images/ui-bg_glass_100_f6f6f6_1x400.png
  191. BIN test/views/css/ui-lightness/images/ui-bg_glass_100_fdf5ce_1x400.png
  192. BIN test/views/css/ui-lightness/images/ui-bg_glass_65_ffffff_1x400.png
  193. BIN test/views/css/ui-lightness/images/ui-bg_gloss-wave_35_f6a828_500x100.png
  194. BIN test/views/css/ui-lightness/images/ui-bg_highlight-soft_100_eeeeee_1x100.png
  195. BIN test/views/css/ui-lightness/images/ui-bg_highlight-soft_75_ffe45c_1x100.png
  196. BIN test/views/css/ui-lightness/images/ui-icons_222222_256x240.png
  197. BIN test/views/css/ui-lightness/images/ui-icons_228ef1_256x240.png
  198. BIN test/views/css/ui-lightness/images/ui-icons_ef8c08_256x240.png
  199. BIN test/views/css/ui-lightness/images/ui-icons_ffd27a_256x240.png
  200. BIN test/views/css/ui-lightness/images/ui-icons_ffffff_256x240.png
  201. +578 −0 test/views/css/ui-lightness/jquery-ui-1.8.13.custom.css
  202. +172 −0 test/views/index.tal
  203. +26 −0 test/views/index_main.tal
  204. +16 −0 test/views/js/jquery-1.5.1.min.js
  205. +784 −0 test/views/js/jquery-ui-1.8.13.custom.min.js
  206. +96 −0 test/views/js/jquery.cookie.js
  207. +99 −0 test/views/js/jquery.hotkeys.js
  208. +4,544 −0 test/views/js/jquery.tree.js
  209. +118 −0 test/views/js/sortable.js
  210. +182 −0 test/views/js/tabs.js
  211. +15 −0 test/views/some.tal
  212. +20 −0 test/views/tab.tal
  213. +6 −0 test/views/test.tal
  214. +4 −0 test/views/tree.tal
View
@@ -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>
View
@@ -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))
View
@@ -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")))
+
+
View
@@ -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)
View
@@ -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
+ ))
+
View
@@ -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.

0 comments on commit ddc6527

Please sign in to comment.