Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

init

  • Loading branch information...
commit ddc6527edba209d1d0b41e7451477946b94a3039 1 parent 1b3def7
@hairyhum hairyhum authored
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
17 .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>
View
133 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))
View
55 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")))
+
+
View
43 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)
View
28 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
+ ))
+
View
68 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))
+
View
49 src/extensions.lisp
@@ -0,0 +1,49 @@
+;;;; Created on 2011-04-09 21:43:20
+(in-package :mvc)
+(defmacro defparameter-in-package
+ (name
+ package
+ &optional val
+ &aux
+ (n (typecase name
+ (string (string-upcase name))
+ (symbol (symbol-name name))))
+ (pcg (typecase package
+ (string (find-package package))
+ (symbol package)
+ (package package))))
+ "Define parameter for package."
+ `(let* ((s (intern ,n ,pcg)))
+ (setf (symbol-value s) ,val)))
+(defmacro find-symbol-value (name
+ &optional package
+ &aux
+ (n (typecase name
+ (null *package*)
+ (string (string-upcase name))
+ (symbol (symbol-name name)))))
+ `(let ((pcg ,package))
+ (symbol-value (find-symbol ,n (typecase pcg
+ (string (find-package pcg))
+ (symbol pcg)
+ (package pcg))))))
+(defmacro defun-in-package
+ (name
+ package
+ (&rest args)
+ &body body
+ &aux
+ (n (typecase name
+ (string (string-upcase name))
+ (symbol (symbol-name name))))
+ (pcg (typecase package
+ (string (find-package package))
+ (symbol package)
+ (package package))))
+ "Define function for package."
+ `(let* ((s (intern ,n ,pcg)))
+ (setf (symbol-function s) #'(lambda ,args ,@body))))
+(defun to-list (x)
+ (if (listp x) x (list x)))
+
+
View
33 src/mvc.asd
@@ -0,0 +1,33 @@
+;;;; 2011-04-05 20:32:08
+;;;;
+;;;; Think of this as your project file.
+;;;; Keep it up to date, and you can reload your project easily
+;;;; by right-clicking on it and selecting "Load Project"
+
+(defpackage #:mvc-asd
+ (:use :cl :asdf))
+
+(in-package :mvc-asd)
+
+(defsystem mvc
+ :name "mvc"
+ :version "0.1"
+ :serial t
+ :components ((:module "orm"
+ :components ((:file "record")
+ (:file "table" :depends-on ("record"))
+ (:file "defpackage" :depends-on ("table"))))
+ (:file "core")
+ (:file "routing" :depends-on ("core"))
+ (:module "view"
+ :components ((:file "defpackage")
+ (:file "view" :depends-on ("defpackage"))
+ (:file "template" :depends-on ("defpackage"))
+ (:file "render" :depends-on ("defpackage" "view" "template")))
+ :depends-on ("core" "routing"))
+ (:file "defpackage" :depends-on ("core" "routing"))
+ ;(:file "debug" :depends-on ("defpackage"))
+ (:file "extensions" :depends-on ("defpackage"))
+ (:file "controller" :depends-on ("defpackage" "core" "extensions" "view"))
+ (:file "dispatcher" :depends-on ("defpackage" "controller")))
+ :depends-on ( #:hunchentoot #:routes #:yaclml #:cl-json #:clsql #:cl-annot))
View
30 src/orm/defpackage.lisp
@@ -0,0 +1,30 @@
+;;;; 2011-05-28 20:35:00
+(in-package :common-lisp-user)
+(defpackage :orm
+ (:use :cl)
+ (:import-from :orm-table
+ :table
+ :deftable
+ :create-instance
+ :fetch
+ :destroy-instance
+ :destroy-records
+ )
+ (:import-from :orm-record
+ :record
+ :save
+ :save-slots
+ :destroy)
+ (:export
+ :table
+ :deftable
+ :create-instance
+ :fetch
+ :record
+ :save
+ :save-slots
+ :destroy
+ :destroy-instance
+ :destroy-records))
+(in-package :orm)
+
View
33 src/orm/orm.lisp
@@ -0,0 +1,33 @@
+;;;; 2011-05-28 20:35:00
+
+
+(in-package :common-lisp-user)
+
+(defpackage :orm
+ (:use :cl)
+ (:import-from :orm-table
+ :table
+ :deftable
+ :create-instance
+ :fetch
+ :destroy-instance
+ :destroy-records
+ )
+ (:import-from :orm-record
+ :record
+ :save
+ :save-slots
+ :destroy)
+ (:export
+ :table
+ :deftable
+ :create-instance
+ :fetch
+ :record
+ :save
+ :save-slots
+ :destroy
+ :destroy-instance
+ :destroy-records))
+(in-package :orm)
+
View
37 src/orm/record.lisp
@@ -0,0 +1,37 @@
+;;;; Created on 2011-05-28 20:40:19
+(defpackage :orm-record
+ (:use :cl)
+ (:import-from :clsql
+ :update-records-from-instance
+ :update-record-from-slots
+ :delete-instance-records))
+(in-package :orm-record)
+(cl-annot:enable-annot-syntax)
+@export
+(defclass record () ()
+ (:documentation "Class for table instances, represents database record."))
+@export
+(defmethod save ((rec record))
+ "Save this instance and reflect slot values to database."
+ (update-records-from-instance rec)
+ rec)
+@export
+(defmethod save-slots ((rec record) slots)
+ "Save this instance and reflect slot values to database."
+ (update-record-from-slots rec slots)
+ rec)
+@export
+(defun pkey-name (view-class-name)
+ (clsql-sys::slot-definition-name (car (clsql-sys::keyslots-for-class (find-class view-class-name)))))
+@export
+(defmethod destroy ((rec record))
+ "Delete this instance from the database.
+I want to use `delete' for this name, but it is already used in very famous package :p."
+ (delete-instance-records rec))
+@export
+(defmethod destroy ((nothing null))
+ nothing)
+@export
+(defmethod attributes ((rec record))
+ "Return a list of slot names."
+ (list-attributes rec))
View
176 src/orm/table.lisp
@@ -0,0 +1,176 @@
+;;;; Created on 2011-05-28 20:42:16
+(defpackage :orm-table
+ (:use :cl)
+ (:import-from :clsql
+ :enable-sql-reader-syntax
+ :create-view-from-class
+ :select
+ :sql-expression
+ :sql-operator
+ :table-exists-p
+ :sql-and
+ :sql-=
+ :sql-in
+ :sql-count)
+ (:import-from :clsql-sys :standard-db-class)
+ (:import-from :orm-record
+ :record
+ :save
+ :save-slots
+ :destroy
+ :pkey-name))
+(in-package :orm-table)
+(cl-annot:enable-annot-syntax)
+@export
+(defclass table (clsql-sys::standard-db-class) ()
+ (:documentation "Metaclass for database tables."))
+@export
+(defmethod create-instance ((table symbol) &rest initargs)
+ (apply #'create-instance (find-class table) initargs))
+@export
+(defmethod create-instance ((table table) &rest initargs)
+ "Same as `make-instance' except for calling `save' it then.
+Example:
+ (create-instance 'person :name \"Eitarow Fukamachi\")"
+ (let ((new-instance (apply #'make-instance table initargs)))
+ (save new-instance)
+ new-instance))
+(defun remove-nil-from-plist (plist)
+ (loop for (k v) on plist by #'cddr
+ unless (eq v nil)
+ append (list k v)))
+@export
+(defmethod destroy-instance ((table symbol) id)
+ (destroy-instance (find-class table) id))
+@export
+(defmethod destroy-instance ((table table) id)
+ (let ((instance (fetch table id)))
+ (destroy instance)))
+@export
+(defmethod fetch ((table symbol) ids-or-key
+ &key where conditions order-by offset limit group-by)
+ (fetch (find-class table) ids-or-key
+ :where where
+ :conditions conditions
+ :order-by order-by
+ :offset offset
+ :limit limit
+ :group-by group-by))
+@export
+(defmethod destroy-records ((table symbol) &key where conditions)
+ (clsql:delete-records
+ :from (symbol-name table)
+ :where
+ (cond
+ ((and where conditions)
+ (sql-and where (normalize-conditions conditions)))
+ (where (sql-and where))
+ (conditions (sql-and (normalize-conditions conditions)))
+ (t nil))))
+@export
+(defmethod fetch ((table table) ids-or-key
+ &key where conditions order-by offset limit group-by)
+ "Find records from `table' and return it.
+`ids-or-key' must be :first, :all, or a number, represents primary key, or the list.
+
+Example:
+ ;; Fetch a record, id=1.
+ (fetch person 1)
+ ;; Fetch records, country=jp
+ (fetch person :conditions '(:country \"jp\"))"
+ (setf table (class-name table))
+ (etypecase
+ ids-or-key
+ (keyword (ecase ids-or-key
+ (:first
+ (car
+ (apply
+ #'select table :flatp t
+ (remove-nil-from-plist
+ `(:limit 1
+ :refresh t
+ :offset ,offset
+ :order-by ,(normalize-order-by order-by)
+ :group-by ,group-by
+ :where ,(cond
+ ((and where conditions)
+ (sql-and where (normalize-conditions conditions)))
+ (where where)
+ (conditions (normalize-conditions conditions))))))))
+ (:count
+ (car
+ (apply
+ #'select (sql-count (sql-expression :attribute "*")) :from table :flatp t
+ (remove-nil-from-plist
+ `(:offset ,offset
+ :order-by ,(normalize-order-by order-by)
+ :group-by ,group-by
+ :where ,(cond
+ ((and where conditions)
+ (sql-and where (normalize-conditions conditions)))
+ (where where)
+ (conditions (normalize-conditions conditions))))))))
+ (:all
+ (apply
+ #'select table :flatp t
+ (remove-nil-from-plist
+ `(:limit ,limit
+ :refresh t
+ :offset ,offset
+ :order-by ,(normalize-order-by order-by)
+ :group-by ,group-by
+ :where ,(cond
+ ((and where conditions)
+ (sql-and where (normalize-conditions conditions)))
+ (where where)
+ (conditions (normalize-conditions conditions)))))))))
+ ((or number string)
+ (car
+ (apply
+ #'select table
+ :refresh t
+ :where
+ (cond
+ ((and where conditions)
+ (sql-and (sql-= (sql-expression :attribute (pkey-name table)) ids-or-key) where (normalize-conditions conditions)))
+ (where (sql-and (sql-= (sql-expression :attribute (pkey-name table)) ids-or-key) where))
+ (conditions (sql-and (sql-= (sql-expression :attribute (pkey-name table)) ids-or-key) (normalize-conditions conditions)))
+ (t (sql-= (sql-expression :attribute (pkey-name table)) ids-or-key)))
+ :flatp t
+ (remove-nil-from-plist
+ `(:order-by ,(normalize-order-by order-by) :group-by ,group-by)))))
+ (cons
+ (apply
+ #'select table
+ :refresh t
+ :where
+ (if where
+ (sql-and (sql-in (sql-expression :attribute (pkey-name table)) ids-or-key) where)
+ (sql-in (sql-expression :attribute (pkey-name table)) ids-or-key))
+ :flatp t
+ (remove-nil-from-plist
+ `(:limit ,limit
+ :offset ,offset
+ :order-by ,(normalize-order-by order-by)
+ :group-by ,group-by))))))
+@export
+(defmacro deftable (class supers slots &optional cl-options)
+ "Define a table schema. This is just a wrapper of `clsql:def-view-class',
+so, see CLSQL documentation to get more informations.
+<http://clsql.b9.com/manual/def-view-class.html>"
+ `(progn
+ (clsql:def-view-class ,class (record ,@supers)
+ ,slots
+ ,@(if (find :metaclass `,cl-options :key #'car)
+ `,cl-options
+ (cons '(:metaclass table) `,cl-options)))
+; (unless (table-exists-p ',class)
+; (create-view-from-class ',class))
+ (defvar ,class (find-class ',class))))
+(defun normalize-conditions (conditions)
+ (apply #'sql-and
+ (loop for (k v) on conditions by #'cddr
+ collect (sql-= (sql-expression :attribute k) v))))
+(defun normalize-order-by (order-by)
+ (loop for (k v) on order-by by #'cddr
+ collect (list (sql-expression :attribute k) v)))
View
47 src/render.lisp
@@ -0,0 +1,47 @@
+;;;; Created on 2011-05-15 16:36:12
+(in-package :mvc)
+
+(defmethod render-view ((text string))
+ text)
+
+(defmethod render-view ((view-func function))
+ (funcall view-func))
+
+(defmethod render-view :before ((code integer))
+ (setf (hunchentoot:return-code*) code))
+
+(defmethod render-view ((octets vector))
+ octets)
+
+(defmethod render-view ((file pathname))
+ (if (probe-file file)
+ (hunchentoot:handle-static-file file
+ (or (hunchentoot:mime-type file)
+ (hunchentoot:content-type hunchentoot:*reply*)))
+ (not-found-if-not nil)))
+
+(defmethod render-view ((object (eql nil)))
+ (render-view hunchentoot:+http-not-found+))
+
+(defmethod render-view (object)
+ (error "Unknown as render ~A " object))
+
+(defmethod render-view ((data list)))
+
+(defmethod render-view ((view template-view))
+ (render-template (not-found-if-not (view-name view)) (view-params view)))
+
+(defmethod render-view ((view json-view))
+ (json:encode-json-plist-to-string (view-params view)))
+
+(defmethod render-view :around ((view html-view))
+ (if (ajax-request-p)
+ (progn
+ (hunchentoot:no-cache)
+ (call-next-method))
+ (progn
+ (render-template (not-found-if-not (view-layout view)) (append (list :template (view-name view)) (view-params view)))
+ )))
+
+(defmethod render-view ((view redirect-view))
+ (hunchentoot:redirect (redirect-view-url view)))
View
77 src/routing.lisp
@@ -0,0 +1,77 @@
+;;;; Created on 2011-04-12 15:02:47
+(defpackage :routing
+ (:use :cl :core :cl-annot :iterate)
+ (:export
+ :route-action
+ :route-controller
+ :route-name
+ :route-defaults))
+(in-package :routing)
+(annot:enable-annot-syntax)
+@export
+(defclass route (routes:route)
+ ((controller :initarg :controller :initform *default-controller-name* :accessor route-controller)
+ (action :initarg :action :initform *default-action-name* :accessor route-action)
+ (defaults :initarg :defaults :accessor route-defaults)
+ (name :initarg :name :accessor route-name)
+ (method :initarg :method)
+ (requirements :initarg :requirements)))
+@export
+(defun nil-if-empty (string)
+ (if (and (stringp string) (string= string ""))
+ nil
+ string))
+@export
+(defun defroute (name
+ template
+ &key
+ action
+ controller
+ defaults
+ (method :any)
+ requirements
+ parse-vars)
+ (let ((route (make-instance 'route
+ :name name
+ :template (routes:parse-template template parse-vars)
+ :controller controller
+ :action (or action *default-action-name*)
+ :defaults defaults
+ :method method
+ :requirements requirements)))
+ (routes:connect (default-mapper) route)
+ (push route (default-routes))
+ route))
+@export
+(defun clear-routes ()
+ (routes:reset-mapper (default-mapper))
+ (setf (mvc::default-routes) nil)
+ )
+@export
+(defun find-route (route-name)
+ (find-if (lambda (route) (string= (route-name route) route-name)) (default-routes)))
+@export
+(defun genurl-full (route &rest args)
+ (let ((uri (genurl/impl (route-template route) args)))
+ (setf (puri:uri-scheme uri)
+ :http)
+ (setf (puri:uri-host uri)
+ (if (boundp 'hunchentoot:*request*)
+ (hunchentoot:host)
+ "localhost"))
+ (puri:render-uri uri nil)))
+@export
+(defun genurl (route &rest args)
+ (puri:render-uri (genurl/impl (route-template route) args) nil))
+(defun route-template (route)
+ (routes:route-template route))
+(defun genurl/impl (tmpl args)
+ (let ((uri (make-instance 'puri:uri)))
+ (setf (puri:uri-parsed-path uri)
+ (cons :absolute
+ (routes::apply-bindings
+ tmpl
+ (iterate (for (key value) :on args :by #'cddr)
+ (collect (cons key (if (listp value) value (princ-to-string value))))))))
+ uri))
+
View
42 src/template.lisp
@@ -0,0 +1,42 @@
+;;;; Created on 2011-05-22 21:25:05
+
+(in-package :mvc)
+
+(defvar *view-dir* (merge-pathnames #p"views/"))
+
+(defvar *generator*
+ (make-instance 'yaclml:file-system-generator
+ :root-directories (list *view-dir*))
+ "A filesystem-based TAL generator that looks for templates only in
+ current directory.")
+
+(defun plist-tal-env (pairs)
+ "Creates a fresh tal environment from the plist PAIRS."
+ (labels ((keyword-to-symbol (keyword)
+ (if (keywordp keyword)
+ (intern (symbol-name keyword))
+ keyword))
+ (list-tal-env (value)
+ (if (first value)
+ (if (keywordp (first value))
+ (plist-tal-env value)
+ (mapcar (lambda (val) (if (listp val) (list-tal-env val) (list val))) value))
+ nil)))
+ (list
+ (iterate (for (key value) :on pairs :by #'cddr)
+ (collect
+ (cons (keyword-to-symbol key)
+ (if (listp value)
+ (list-tal-env value)
+ value)))))))
+
+(defun render-template (name env)
+ (let ((template (yaclml:load-tal *generator* (concatenate 'string name ".tal"))))
+ (when template
+ (YACLML:WITH-YACLML-OUTPUT-TO-STRING (funcall template
+ (if (listp env)
+ (if (keywordp (first env))
+ (plist-tal-env env)
+ env)
+ (list env))
+ *generator*)))))
View
40 src/testfile.lisp
@@ -0,0 +1,40 @@
+;;;; Created on 2011-04-12 22:03:35
+; MAIN TODO: controller and action
+; CURRENT TODO: action filter stack
+(mvc::reset)
+(mvc:defcontroller :init)
+(in-package :init)
+;(defun some-action (&key some variable) (write-to-string (list some variable)))
+(defun http-hello-world-2(&rest args)
+ (declare (ignore args))
+
+ "Ïðèâåò ìèð!")
+
+(mvc:defaction some-action (some variable) ()
+ (write-to-string *route-params*)
+ ;(hunchentoot:abort-request-handler)
+ (mvc:make-view (list :vars (list (list :id 1 :name "name"))) :name "template-name" :layout "some" :type :html))
+
+
+;(mvc:defilter (lambda () (setf (getf *route-params* :some) "value")) :before)
+(mvc:defroute "some-route" "" :action "some-action" :controller "init")
+(mvc:defroute "some-route1" ":some/:variable" :action "some-action" :controller "init")
+(mvc:defroute "some-other-route" ":some/:variable/with-other" :defaults (list :other "value") :action "some-action" :controller "init")
+(mvc:start)
+
+
+
+
+
+
+
+(let* ((package (symbol-package (type-of (first (get-tabs nil)))))
+ (func (find-symbol (string-upcase "sort-order") package)))
+ (when (fboundp func) "found")
+ )
+
+
+
+
+
+
View
44 src/view.lisp
@@ -0,0 +1,44 @@
+;;;; Created on 2011-04-10 00:58:59
+
+(in-package :mvc)
+
+(defclass view-base () ())
+(defclass data-view (view-base)
+ ((params :initarg :params :initform nil :accessor view-params :type list)))
+
+;;;
+; TEMPLATE views
+;;;
+(defclass template-view (data-view)
+ ((name :initarg :name :accessor view-name :type string)))
+(defclass html-view (template-view)
+ ((layout :initarg :layout :accessor view-layout :type string)))
+(defclass xml-view (template-view) ())
+
+;;;
+; Data views
+;;;
+;(defclass xml-plist-view (data-view) ())
+(defclass json-view (data-view) ())
+
+;;;
+; Advanced views
+;;;
+(defclass widget-view (view-base) ())
+(defclass javascript-view (view-base) ())
+
+;;;
+; Redirect views
+;;;
+(defclass redirect-view (view-base)
+ ((url :initarg :url :accessor redirect-view-url)))
+(defclass referer-view (redirect-view) ())
+
+(defmethod initialize-instance ((view redirect-view) &rest route-params &key route-name)
+ (when route-name
+ (setf (slot-value view 'url) (genurl (find-route route-name) (alexandria:remove-from-plist route-params :url :route-name)))))
+
+(defmethod initialize-instance ((view referer-view) &rest args)
+ (declare (ignore args))
+ (setf (slot-value view 'url) (hunchentoot:referer)))
+
View
20 src/view/defpackage.lisp
@@ -0,0 +1,20 @@
+;;;; Created on 2011-06-06 23:38:49
+(in-package :common-lisp-user)
+
+(defpackage :view
+ (:nicknames :view)
+ (:use :cl :json :iterate :core :routing)
+ (:export
+ #:render-template
+ #:render-view
+ #:view-params
+ #:view-name
+ #:view-layout
+ :html-view
+ :template-view
+ :xml-view
+ :json-view
+ :widget-view
+ :javascript-view
+ :redirect-view
+ :referer-view))
View
47 src/view/render.lisp
@@ -0,0 +1,47 @@
+;;;; Created on 2011-05-15 16:36:12
+(in-package :view)
+
+(defmethod render-view ((text string))
+ text)
+
+(defmethod render-view ((view-func function))
+ (funcall view-func))
+
+(defmethod render-view :before ((code integer))
+ (setf (hunchentoot:return-code*) code))
+
+(defmethod render-view ((octets vector))
+ octets)
+
+(defmethod render-view ((file pathname))
+ (if (probe-file file)
+ (hunchentoot:handle-static-file file
+ (or (hunchentoot:mime-type file)
+ (hunchentoot:content-type hunchentoot:*reply*)))
+ (not-found-if-not nil)))
+
+(defmethod render-view ((object (eql nil)))
+ (render-view hunchentoot:+http-not-found+))
+
+(defmethod render-view (object)
+ (error "Unknown as render ~A " object))
+
+(defmethod render-view ((data list)))
+
+(defmethod render-view ((view template-view))
+ (render-template (not-found-if-not (view-name view)) (view-params view)))
+
+(defmethod render-view ((view json-view))
+ (json:encode-json-plist-to-string (view-params view)))
+
+(defmethod render-view :around ((view html-view))
+ (if (ajax-request-p)
+ (progn
+ (hunchentoot:no-cache)
+ (call-next-method))
+ (progn
+ (render-template (not-found-if-not (view-layout view)) (append (list :template (view-name view)) (view-params view)))
+ )))
+
+(defmethod render-view ((view redirect-view))
+ (hunchentoot:redirect (redirect-view-url view)))
View
42 src/view/template.lisp
@@ -0,0 +1,42 @@
+;;;; Created on 2011-05-22 21:25:05
+(in-package :view)
+(defvar *view-dir* (merge-pathnames #p"views/"))
+
+(defvar *generator*
+(make-instance 'yaclml:file-system-generator
+ :root-directories (list *view-dir*))
+ "A filesystem-based TAL generator that looks for templates only in
+ current directory.")
+
+(defun plist-tal-env (pairs)
+ "Creates a fresh tal environment from the plist PAIRS."
+ (labels ((keyword-to-symbol (keyword)
+ (if (keywordp keyword)
+ (intern (symbol-name keyword))
+ keyword))
+ (list-tal-env (value)
+ (if (first value)
+ (if (keywordp (first value))
+ (plist-tal-env value)
+ (mapcar (lambda (val) (if (listp val) (list-tal-env val) (list val))) value))
+ nil)))
+ (list
+ (iterate (for (key value) :on (if (and (listp pairs) (keywordp (first pairs))) pairs (list pairs)) :by #'cddr)
+ (collect
+ (cons (keyword-to-symbol key)
+ (if (listp value)
+ (list-tal-env value)
+ value)))))))
+(defun render-template (name env &key template)
+ (let ((env-tal (if (listp env)
+ (if (keywordp (first env))
+ (plist-tal-env env)
+ env)
+ (list env))))
+ (if template
+ (yaclml:with-yaclml-output-to-string (funcall (yaclml:compile-tal-string template) env-tal nil))
+ (let ((template (yaclml:load-tal *generator* (concatenate 'string name ".tal"))))
+ (when template
+ (YACLML:WITH-YACLML-OUTPUT-TO-STRING (funcall template
+ env-tal
+ *generator*)))))))
View
46 src/view/view.lisp
@@ -0,0 +1,46 @@
+;;;; Created on 2011-04-10 00:58:59
+
+(in-package :view)
+
+(defclass view-base () ())
+(defclass data-view (view-base)
+ ((params :initarg :params :initform nil :accessor view-params :type list)))
+
+;;;
+; TEMPLATE views
+;;;
+(defclass template-view (data-view)
+ ((name :initarg :name :accessor view-name :type string)))
+(defclass html-view (template-view)
+ ((layout :initarg :layout :accessor view-layout :type string)))
+(defclass xml-view (template-view) ())
+
+;;;
+; Data views
+;;;
+;(defclass xml-plist-view (data-view) ())
+(defclass json-view (data-view) ())
+
+;;;
+; Advanced views
+;;;
+(defclass widget-view (view-base) ())
+(defclass javascript-view (view-base) ())
+
+;;;
+; Redirect views
+;;;
+(defclass redirect-view (view-base)
+ ((url :initarg :url :accessor redirect-view-url)))
+(defclass referer-view (redirect-view) ())
+
+(defmethod initialize-instance :after ((view redirect-view) &rest route-params &key route-name &allow-other-keys)
+ (when route-name
+ (let ((route (find-route route-name)))
+ (when route
+ (setf (slot-value view 'url) (apply #'genurl route (alexandria:remove-from-plist route-params :url :route-name)))))))
+
+(defmethod initialize-instance :after ((view referer-view) &rest args)
+ (declare (ignore args))
+ (setf (slot-value view 'url) (hunchentoot:referer)))
+
View
40 test/authorization.lisp
@@ -0,0 +1,40 @@
+;;;; Created on 2011-06-02 14:28:21
+(in-package :todotree)
+(defparameter *user* nil)
+(defun user-id () (if *user* (id *user*) 0))
+(defun utime+ (time amount unit &optional time-zone offset)
+ (let ((local (local-time:universal-to-timestamp time)))
+ (local-time:timestamp-to-universal (local-time:timestamp+ local amount unit time-zone offset))))
+(defun utime- (time amount unit &optional time-zone offset)
+ (let ((local (local-time:universal-to-timestamp time)))
+ (local-time:timestamp-to-universal (local-time:timestamp- local amount unit time-zone offset))))
+(defun load-user ()
+ (setq *user* (or (hunchentoot:session-value :user)
+ (try-load-user-cookies))))
+(defun try-load-user-cookies ()
+ (let ((email (hunchentoot:cookie-in "login-email"))
+ (key (hunchentoot:cookie-in "login-key")))
+ (when email
+ (let ((user (get-user email)))
+ (if (and user
+ (string-equal key (get-user-hash email (user-password user) t)))
+ (setq *user* (setf (hunchentoot:session-value :user) user))
+ (clear-user-cookies))))))
+(defun get-user-hash (email password &optional password-hashed)
+ (hash-password (concatenate 'string email (if password-hashed password (hash-password password)))))
+(defun set-user-cookies (user)
+ (hunchentoot:set-cookie "login-email" :value (user-email user) :expires (utime+ (get-universal-time) 7 :day))
+ (hunchentoot:set-cookie "login-key" :value (get-user-hash (user-email user) (user-password user) t) :expires (utime+ (get-universal-time) 7 :day))
+ (setf (hunchentoot:session-value :user) user)
+ (setq *user* user))
+(defun clear-user-cookies ()
+ (hunchentoot:set-cookie "login-email" :value nil :expires (utime- (get-universal-time) 1 :day))
+ (hunchentoot:set-cookie "login-key" :value nil :expires (utime- (get-universal-time) 1 :day))
+ (hunchentoot:delete-session-value :user)
+ (setq *user* nil))
+(defun authorize-user (email password &optional password-hashed)
+ (let ((user (get-user* email password password-hashed)))
+ (if user
+ (set-user-cookies user)
+ (clear-user-cookies))))
+
View
22 test/dash.lisp
@@ -0,0 +1,22 @@
+;;;; Created on 2011-06-02 14:06:06
+(in-package :todotree)
+(defcontroller :index :options ((:use :todotree :todotree-model) (:import-from :todotree :user-id :*user*)) :view-type :html :view-layout "index")
+(in-package :index)
+(defilter #'todotree::load-user :before)
+(defaction index () ()
+ (let ((tabs (get-tabs (user-id))))
+ (make-view (list :user todotree::*user* :tabs tabs) :name "index")))
+(defaction js (file-name) ()
+ (make-pathname :directory "views/js/" :name file-name :type "js"))
+(defun list-concat (list &optional delimiter)
+ (reduce (lambda (a b)
+ (concatenate 'string a delimiter b))
+ (remove-if-not #'stringp list)))
+(defaction style (file-name) ()
+ (write-to-string file-name)
+ (concatenate 'string "views/css/" (list-concat file-name "/"))
+ (pathname (concatenate 'string "views/css/" (list-concat file-name "/"))))
+
+
+
+
View
7 test/defpackage.lisp
@@ -0,0 +1,7 @@
+;;;; 2011-05-29 15:16:59
+(in-package :common-lisp-user)
+(defpackage :todotree
+ (:nicknames :todotree)
+ (:use :cl :mvc :todotree-model)
+ (:export :*user* :user-id))
+
View
122 test/model/CRUD.lisp
@@ -0,0 +1,122 @@
+;;;; Created on 2011-05-31 14:46:54
+(in-package :todotree-model)
+
+;
+;Help functions
+;
+
+(defun not-nil-keys (plist &optional result)
+ (flet ((keyword-to-symbol (keyword)
+ (if (keywordp keyword)
+ (intern (symbol-name keyword))
+ keyword)))
+ (alexandria:doplist (key value plist result)
+ (when value
+ (push (keyword-to-symbol key) result)))))
+(defun hash-password (password)
+ (ironclad:byte-array-to-hex-string
+ (ironclad:digest-sequence
+ :md5
+ (ironclad:ascii-string-to-byte-array password))))
+
+;
+; Context
+;
+(defun add-context (name user-id &optional description)
+ (create-instance 'context :name name :user-id user-id :description description))
+(defun update-context (id &rest params &key name description)
+ (save-slots (make-instance 'context :id id :name name :description description)
+ (not-nil-keys params nil)))
+(defun delete-context (id)
+ (destroy-instance 'context id))
+;
+; Tag
+;
+(defun add-tag (name user-id &optional color picture tab-id)
+ (create-instance 'tag :name name :user-id user-id :color color :picture picture :tab-id tab-id))
+(defun update-tag (id &rest params &key name color picture tab-id)
+ (save-slots (make-instance 'tag :id id :name name :color color :picture picture :tab-id tab-id)
+ (not-nil-keys params nil)))
+(defun delete-tag (id)
+ (destroy-instance 'tag id))
+
+;
+; Note
+;
+(defun add-note (text user-id &optional color task-id tab-id)
+ (create-instance 'note :text text :user-id user-id :color color :task-id task-id :tab-id tab-id))
+(defun update-note (id &rest params &key text color task-id tab-id)
+ (save-slots (make-instance 'note :id id :text text :color color :task-id task-id :tab-id tab-id)
+ (not-nil-keys params nil)))
+(defun delete-note (id)
+ (destroy-instance 'note id))
+
+;
+; Task
+;
+(defun add-task (name user-id &optional priority description started active date-due parent-task-id tab-id color)
+ (create-instance 'task
+ :name name
+ :user-id user-id
+ :priority (or priority :normal)
+ :description (or description "")
+ :date-add (clsql:get-time)
+ :date-start (if started (clsql:get-time))
+ :date-due date-due
+ :parent-task-id (or parent-task-id 0)
+ :tab-id tab-id
+ :color color
+ :active active))
+(defun update-task (id &rest params &key name priority description started active completed date-due parent-task-id tab-id color)
+ (save (update-slots (fetch 'task id)
+ params)))
+
+(defun update-slots (instance slots)
+ (alexandria:doplist (key val slots)
+ (let ((func (find-symbol (concatenate 'string (symbol-name (type-of instance)) "-" (symbol-name key)))))
+ (when (and func (fboundp func))
+ (funcall (fdefinition (list 'setf func)) val instance))))
+ instance)
+
+(defun delete-task (id)
+ (destroy-instance 'task id))
+
+;
+; User
+;
+(defun add-user (email password
+ &optional first-name last-name
+ &key password-hashed)
+ (create-instance 'user
+ :email email
+ :password (if password-hashed
+ password
+ (hash-password password))
+ :first-name first-name
+ :last-name last-name))
+(defun update-user (id &rest params
+ &key email password first-name last-name)
+ (save-slots (update-slots (fetch 'user id)
+ params)
+ (not-nil-keys params nil)))
+(defun delete-user (id)
+ (destroy-instance 'user id))
+
+;
+; Tab
+;
+(defun add-tab (name type user-id &key date sort-order)
+ (create-instance 'tab
+ :name (or name
+ (string-capitalize (symbol-name type)))
+ :type type
+ :date date
+ :sort-order (or sort-order 0)
+ :user-id user-id))
+(defun update-tab (id &rest args &key name type date sort-order)
+ (save-slots (update-slots (fetch 'tab id)
+ params)
+ (not-nil-keys params nil)))
+(defun delete-tab (id)
+ (destroy-instance 'tab id))
+
View
8 test/model/database.lisp
@@ -0,0 +1,8 @@
+;;;; Created on 2011-05-30 14:33:29
+(in-package :todotree-model)
+
+(defvar *db* nil)
+(setf *db*
+ (connect '("192.168.0.1" "todolisp" "postgres" "danniill")
+ :database-type :postgresql-socket
+ :if-exists :old))
View
27 test/model/defpackage.lisp
@@ -0,0 +1,27 @@
+;;;; Created on 2011-05-30 14:25:19
+(in-package :common-lisp-user)
+
+(defpackage :todotree-model
+ (:nicknames :todotree-model)
+ (:use :cl :mvc :clsql)
+ (:export
+ :id
+ :get-tabs
+ :user
+ :tab
+ :task
+ :task-completed
+ :get-user*
+ :get-user
+ :hash-password
+ :user-password
+ :user-email
+ :get-tab-tasks
+ :get-unsorted-tasks
+ :get-child-tasks
+ :create-tab
+ :tab-name
+ :delete-tab
+ :add-tab-task
+ :toggle-task
+ :add-child-task))
View
27 test/model/send-mail.lisp
@@ -0,0 +1,27 @@
+;;;; Created on 2011-06-01 13:54:36
+(in-package :todotree-model)
+(defparameter *new-user-format* "<div><div><h1>Ïðèâåò, âàø ïàðîëü: ~a </h1><p>Ìû ïðîñòî óâåðåíû, ÷òî Âàì îí ñîâñåì íå íðàâèòñÿ.<br>Ïîýòîìó íå ñòåñíÿéòåñü ïîìåíÿòü åãî íà ëþáîé äðóãîé â ðàçäåëå «Íàñòðîéêè».</p><p>---- <br>Àäìèíèñòðàöèÿ</p></div></div>")
+(defgeneric send-mail (email object &key type))
+(defmethod send-mail (email (object null) &key type)
+ (declare (ignore email object type))
+ "Error in send-mail! No object specified")
+(defmethod send-mail (email (value string) &key type)
+ (case type
+ (:new-user
+ (bordeaux-threads:make-thread (lambda() (smtp-send email "New user registration" (format nil *new-user-format* value)))))
+ (otherwise "Error sending email! No such email type")))
+(defparameter *smtp-account*
+ (list :host "smtp.gmail.com"
+ :authentication (list "hairyhum@gmail.com" "danniill")
+ :from "noreply@gmail.com"
+ :ssl t))
+(defun smtp-send (to topic message)
+ (handler-case
+ (cl-smtp:send-email (getf *smtp-account* :host)
+ (getf *smtp-account* :from)
+ to
+ topic
+ message
+ :ssl (getf *smtp-account* :ssl)
+ :authentication (getf *smtp-account* :authentication))
+ (error nil)))
View
92 test/model/tables.lisp
@@ -0,0 +1,92 @@
+;;;; Created on 2011-05-30 14:34:58
+(in-package :todotree-model)
+
+(deftable user ()
+ ((id
+ :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :accessor id
+ :initarg :id)
+ (email
+ :type string
+ :accessor user-email)
+ (password
+ :type string
+ :accessor user-password)
+ (first-name
+ :type string
+ :initform ""
+ :accessor user-first-name)
+ (last-name
+ :type string
+ :initform ""
+ :accessor user-last-name)))
+(deftable task ()
+ ((id
+ :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :initarg :id
+ :accessor id)
+ (name
+ :type string
+ :initarg :name
+ :accessor task-name)
+ (user-id
+ :type integer
+ :initarg :user-id
+ :accessor task-user-id)
+ (priority
+ :type keyword
+ :initarg :priority
+ :accessor task-priority)
+ (date-due
+ :type clsql:date
+ :initarg :date-due
+ :accessor task-date-due)
+ (completed
+ :type boolean
+ :initarg :completed
+ :accessor task-completed)
+ (tab-id
+ :type integer
+ :initform 0
+ :initarg :tab-id
+ :accessor task-tab-id)
+ (parent-task-id
+ :type integer
+ :initform 0
+ :initarg :parent-task-id
+ :accessor task-parent-task-id)))
+(deftable tab ()
+ ((id
+ :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :accessor id
+ :initarg :id)
+ (name
+ :type string
+ :initarg :name
+ :accessor tab-name)
+ (sort-order
+ :type integer
+ :initarg :sort-order
+ :accessor tab-sort-order)
+ (type
+ :type keyword
+ :initarg :type
+ :accessor tab-type)
+ (date
+ :type clsql:date
+ :initarg :date
+ :accessor tab-date)
+ (user-id
+ :type integer
+ :initarg :user-id
+ :accessor tab-user-id)
+ (tasks
+ :db-kind :virtual
+ :accessor tab-tasks
+ :initform nil)))
View
32 test/model/tabs.lisp
@@ -0,0 +1,32 @@
+;;;; Created on 2011-06-10 20:07:29
+(in-package :todotree-model)
+(defmethod get-unsorted-tasks ((user-id integer))
+ (fetch 'task :all :conditions (LIST :user-id user-id :tab-id 0 :parent-task-id 0)))
+(defmethod get-unsorted-tasks ((nothing null))
+ (fetch 'task :all :conditions (LIST :user-id 0 :tab-id 0 :parent-task-id 0)))
+(defmethod get-tab-tasks ((tab tab))
+ (let ((type (tab-type tab)))
+ (if (eql type :custom)
+ (filter-tasks* (tab-date tab) (tab-user-id tab) :tags nil :segment "day")
+ (filter-tasks type (tab-user-id tab)))))
+(defmethod instance-refreshed ((tab tab))
+ (setf (tab-tasks tab) (get-tab-tasks tab)))
+(defmethod get-tabs ((nothing null))
+ (fetch 'tab :all :conditions (list :user-id 0)))
+(defmethod get-tabs ((user-id integer))
+ (fetch 'tab :all :conditions (list :user-id user-id)))
+(defun create-tab (name type user-id &optional date)
+ (let ((type (find-symbol (string-upcase type) :keyword)))
+ (if (eql :custom type)
+ (add-tab name type user-id :date (or date (clsql:get-date)))
+ (when (find type (list :today :tomorrow :week :next-week :month :next-month))
+ (add-tab name type user-id :date (second (multiple-value-list (get-period-dates type))))))))
+(defmethod add-tab-task ((tab tab) name &key user-id priority description started active date-due color)
+ (add-task name (or user-id (tab-user-id tab)) priority description started active (or date-due (get-tab-date tab) (clsql:get-time)) nil (id tab) color))
+(defmethod add-tab-task ((tab-id integer) name &key user-id priority description started active date-due color)
+ (add-task name user-id priority description started active (or date-due (clsql:get-time)) nil tab-id color))
+(defmethod get-tab-date ((tab tab))
+ (let ((type (tab-type tab)))
+ (if (eql type :custom)
+ (tab-date tab)
+ (second (multiple-value-list (get-period-dates type))))))
View
72 test/model/tasks.lisp
@@ -0,0 +1,72 @@
+;;;; Created on 2011-05-31 22:20:59
+(in-package :todotree-model)
+(defmethod task-has-children ((task task))
+ (> (fetch 'task :count :conditions (list :parent-task-id (id task))) 0))
+(defmethod get-child-tasks ((parent-id integer) user-id)
+ (fetch 'task :all :conditions (list :parent-task-id parent-id :user-id user-id)))
+(defmethod get-child-tasks ((task task) user-id)
+ (get-child-tasks (id task) user-id))
+(defmethod get-child-tasks ((nothing null) user-id)
+ (declare (ignore nothing user-id)))
+(defun sql-date+ (date amount unit)
+ (when (eql unit :week)
+ (setq unit :day)
+ (setq amount (* amount 7)))
+ (clsql:date+ date (make-instance 'clsql:duration unit amount)))
+(defun sql-date- (date amount unit)
+ (when (eql unit :week)
+ (setq unit :day)
+ (setq amount (* amount 7)))
+ (clsql:date- date (make-instance 'clsql:duration unit amount)))
+(defun get-period-dates (period)
+ (case period
+ (:today
+ (values "day" (clsql:get-date)))
+ (:tomorrow
+ (values "day" (sql-date+ (clsql:get-date) 1 :day)))
+ (:week
+ (values "week" (sql-trunc-week (clsql:get-date))))
+ (:next-week
+ (values "week" (sql-trunc-week (sql-date+ (clsql:get-date) 1 :week))))
+ (:month
+ (values "month" (sql-trunc-month (clsql:get-date))))
+ (:next-month
+ (values "month" (sql-trunc-month (sql-date+ (clsql:get-date) 1 :month))))
+ (otherwise (values nil nil))))
+(defun sql-trunc-week (date)
+ (sql-date- date (- (clsql:date-dow date) 1) :day ))
+(defun sql-trunc-month (date)
+ (sql-date- date (- (third (multiple-value-list (clsql:date-ymd date))) 1) :day))
+(defun filter-tasks* (date user-id &key segment)
+ (if segment
+ (fetch 'task :all :conditions (list :user-id user-id) :where (clsql:sql-= (clsql:sql-function "date_trunc" segment (clsql:sql-expression :attribute "date_due")) date))
+ (fetch 'task :all :conditions (list :date date :user-id user-id))))
+(defmethod filter-tasks ((time clsql:wall-time) user-id &key segment)
+ (filter-tasks* time user-id :segment segment))
+(defmethod filter-tasks ((date clsql:date) user-id &key (segment "day"))
+ (filter-tasks* date user-id :segment segment))
+(defmethod filter-tasks ((period keyword) user-id &key segment)
+ (declare (ignore segment))
+ (multiple-value-bind (segment date) (get-period-dates period)
+ (filter-tasks* date user-id :segment segment)))
+(defmethod toggle-task ((task task) &optional checked)
+ (let ((completed (if checked (if (string-equal checked "true") "t" "f") "t")))
+ (update-task (id task) :completed (string-equal completed "t"))
+ (clsql:update-records 'task :av-pairs (list (list 'completed completed)) :where (clsql:sql-= (clsql:sql-expression :attribute 'parent-task-id) (id task)))))
+(defmethod toggle-task ((id integer) &optional checked)
+ (let ((task (fetch 'task id)))
+ (when task (toggle-task task checked))))
+(defmethod toggle-task ((id string) &optional checked)
+ (let ((task (fetch 'task id)))
+ (when task (toggle-task task checked))))
+(defmethod add-child-task ((task task) name &key priority description started active date-due color)
+ (add-task name (task-user-id task) priority description started active date-due (id task) nil color))
+(defmethod add-child-task ((task-id integer) name &key priority description started active date-due color)
+ (add-child-task (fetch 'task task-id) name :priority priority :description description :started started :active active :date-due date-due :color color))
+(defmethod add-child-task ((task-id string) name &key priority description started active date-due color)
+ (let ((priority (if (and priority (not (string-equal "" priority)))
+ (intern (string-upcase priority) :keyword)
+ :normal)))
+ (add-child-task (fetch 'task task-id) name :priority priority :description description :started started :active active :date-due date-due :color color)))
+
+
View
26 test/model/user.lisp
@@ -0,0 +1,26 @@
+;;;; Created on 2011-06-02 14:08:22
+(in-package :todotree-model)
+(defun generate-password (&optional length)
+ (map 'string
+ (lambda(arg)
+ (declare (ignore arg))
+ (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$^*" (random 68)))
+ (make-list (or length 8))))
+(defun register-user (email)
+ (if (fetch 'user :first :conditions (list :email email))
+ "Email already exist!"
+ (let ((password (generate-password)))
+ (add-user email password)
+ (send-mail email password :type :new-user))))
+(defmethod get-user ((nithing (eql nil)))
+ nil)
+(defmethod get-user ((id integer))
+ (fetch 'user id))
+(defmethod get-user ((email string))
+ (fetch 'user :first :conditions (list :email email)))
+
+(defun get-user* (email password &optional password-hashed)
+ (fetch 'user
+ :first
+ :conditions (list :email email
+ :password (if password-hashed password (hash-password password)))))
View
9 test/routes.lisp
@@ -0,0 +1,9 @@
+;;;; Created on 2011-06-10 20:14:51
+(defroute "tab-content" "/tabs/content/:id" :action "content" :controller "tabs")
+(defroute "delete-tab" "/tabs/delete/:id" :action "delete-action" :controller "tabs")
+(defroute "create-tab" "/tabs/create" :action "create" :controller "tabs")
+(defroute "task-children" "/tasks/get-children" :action "get-children" :controller "tasks")
+(defroute "delete-task" "/tasks/delete-completed/:tab-id" :action "delete-completed" :controller "tasks")
+(defroute "add-task" "/tasks/add/:tab-id" :action "add" :controller "tasks")
+(defroute "check-task" "/tasks/check/:id/:checked" :action "check" :controller "tasks")
+(defroute "add-subtask" "/tasks/add-subtask/:parent-id" :action "add-subtask" :controller "tasks")
View
4 test/start.lisp
@@ -0,0 +1,4 @@
+;;;; Created on 2011-06-03 21:12:14
+(in-package :todotree)
+(setq *default-pathname-defaults* (pathname "d:/lisp/workspace/todotree/"))
+(mvc:start)
View
29 test/tabs.lisp
@@ -0,0 +1,29 @@
+;;;; Created on 2011-06-05 15:03:31
+(in-package :todotree)
+(defcontroller :tabs
+ :options ((:use :todotree :todotree-model)
+ (:import-from :todotree :user-id :*user*))
+ :view-type :json
+ :view-layout "index")
+(in-package :tabs)
+(defilter #'todotree::load-user :before)
+(defaction content (id) ()
+ (let ((tasks (if (string-equal "unsorted" id)
+ (get-unsorted-tasks (user-id))
+ (get-tab-tasks (fetch 'tab id)))))
+ (make-view (list :user todotree::*user*
+ :tasks tasks)
+ :type :partial
+ :name "tab")))
+(defaction create () (:view-type :json)
+ (let ((tab (create-tab (hunchentoot:parameter "name")
+ (hunchentoot:parameter "type")
+ (user-id)
+ (clsql:parse-date-time (hunchentoot:parameter "date")))))
+ (if tab
+ (make-view (list :id (id tab)
+ :name (tab-name tab)))
+ (make-view))))
+(defaction delete-action (id) (:view-type :json)
+ (todotree-model:delete-tab id)
+ (make-view (list :id id)))
View
24 test/tasks.lisp
@@ -0,0 +1,24 @@
+;;;; Created on 2011-06-02 14:00:48
+(in-package :todotree)
+(defcontroller :tasks :options ((:use :todotree :todotree-model) (:import-from :todotree :user-id :*user*)) :view-type :html)
+(in-package :tasks)
+(defaction get-children ()()
+ (let ((tasks (get-child-tasks (parse-integer (hunchentoot:parameter "id") :junk-allowed t) (user-id))))
+ (make-view (list :user todotree::*user* :tasks tasks) :name "tree" :type :partial)))
+(defaction delete-completed (tab-id) (:view-type :json)
+ (destroy-records 'task :conditions (list :tab-id (if (string-equal tab-id "unsorted") 0 tab-id) :completed t))
+ (make-view (list :tab-id tab-id) :type :json))
+(defaction add (tab-id) ()
+ (let ((priority (intern (string-upcase (hunchentoot:parameter "priority")) :keyword)))
+ (if (string-equal tab-id "unsorted")
+ (add-tab-task 0 (hunchentoot:parameter "name") :priority priority :user-id (user-id))
+ (add-tab-task (fetch 'tab tab-id) (hunchentoot:parameter "name") :priority priority)))
+ (make-view (list :tab-id tab-id) :type :json))
+(defaction check (id checked) ()
+ (toggle-task id checked)
+ (make-view (list :completed (task-completed (fetch 'task id))) :type :json))
+(defaction add-subtask (parent-id) ()
+ (add-child-task parent-id
+ (hunchentoot:parameter "name")
+ :priority (hunchentoot:parameter "priority"))
+ (make-view (list :id parent-id) :type :json))
View
69 test/testfile.lisp
@@ -0,0 +1,69 @@
+;;;; Created on 2011-05-29 20:21:37
+
+(defpackage :test (:use :cl
+ :clsql
+ :mvc))
+(in-package :test)
+(defvar *db* nil)
+(setf *db*
+ (clsql:connect '("localhost" "testbase" "postgres" "danniill")
+ :database-type :postgresql-socket
+ :if-exists :old))
+(deftable task ()
+ ((id
+ :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :initarg :id)
+ (name
+ :type string
+ :initarg :name
+ :accessor task-name)
+ (date
+ :type clsql:wall-time
+ :initarg :date
+ :accessor task-description)
+ (user-id
+ :type integer)
+ (tags
+ :reader task-tags
+ :db-kind :join
+ :db-info (
+ :join-class task-tag
+ :home-key id
+ :foreign-key task-id
+ :set t))))
+
+(deftable tag ()
+ ((id
+ :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :initarg :id)
+ (name
+ :type string)))
+(deftable task-tag ()
+ ((id :type integer
+ :db-kind :key
+ :db-constraints (:not-null :auto-increment)
+ :initarg :id)
+ (task-id
+ :type integer
+ :db-constraints :not-null
+ :initarg :task-id)
+ (tag-id
+ :type integer
+ :db-constraints :not-null
+ :initarg :tag-id)))
+
+(defun add-link (task tag)
+ (create-instance 'task-tag :task-id task :tag-id tag))
+
+
+(let ((me (make-instance 'task)))
+ (setf (task-name me) "çàäà÷à")
+ (setf (task-description me) (clsql:w))
+ (save me))
+
+(clsql:select 'task :where (clsql:sql-= (clsql:sql-function "date_trunc" "week" (clsql:sql-expression :attribute "date")) )
+(clsql:select 'task :where (clsql:sql-= (clsql:sql-function "date_trunc" "week" (clsql:get-date)) (clsql:sql-function "date_trunc" "week" (clsql:sql-expression :attribute "date"))))
View
33 test/todotree.asd
@@ -0,0 +1,33 @@
+;;;; 2011-05-29 15:16:59
+;;;;
+;;;; Think of this as your project file.
+;;;; Keep it up to date, and you can reload your project easily
+;;;; by right-clicking on it and selecting "Load Project"
+
+(defpackage #:todotree-asd
+ (:use :cl :asdf))
+
+(in-package :todotree-asd)
+
+(defsystem todotree
+ :name "todotree"
+ :version "0.1"
+ :serial t
+ :components ((:module "model"
+ :components ((:file "defpackage")
+ (:file "database" :depends-on ("defpackage"))
+ (:file "tables" :depends-on ("defpackage"))
+ (:file "CRUD" :depends-on ("defpackage" "tables"))
+ (:file "send-mail" :depends-on ("defpackage"))
+ (:file "user" :depends-on ("defpackage" "send-mail"))
+ (:file "tasks" :depends-on ("defpackage" "CRUD"))
+ (:file "tabs" :depends-on ("defpackage" "CRUD"))
+ ))
+ (:file "defpackage")
+ (:file "authorization" :depends-on ("defpackage"))
+ (:file "routes" :depends-on ("defpackage"))
+ (:file "dash" :depends-on ("defpackage" "authorization"))
+ (:file "tabs" :depends-on ("defpackage" "authorization"))
+ (:file "tasks" :depends-on ("defpackage" "authorization"))
+ (:file "start"))
+ :depends-on (#:mvc #:ironclad #:local-time #:cl-smtp))
View
11 test/views/css/cupertino/.svn/all-wcprops
@@ -0,0 +1,11 @@
+K 25
+svn:wc:ra_dav:version-url
+V 63
+/svn/lisp-mvc_framework/!svn/ver/2/todotree/views/css/cupertino
+END
+jquery-ui-1.8.13.custom.css
+K 25
+svn:wc:ra_dav:version-url
+V 91
+/svn/lisp-mvc_framework/!svn/ver/2/todotree/views/css/cupertino/jquery-ui-1.8.13.custom.css
+END
View
65 test/views/css/cupertino/.svn/entries
@@ -0,0 +1,65 @@
+10
+
+dir
+2
+http://lisp-mvc.unfuddle.com/svn/lisp-mvc_framework/todotree/views/css/cupertino
+http://lisp-mvc.unfuddle.com/svn/lisp-mvc_framework
+
+
+
+2011-06-10T16:28:28.115490Z
+2
+hairyhum
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ac95b44f-471c-48cd-8414-b967058da7d4
+
+jquery-ui-1.8.13.custom.css
+file
+
+
+
+
+2011-06-01T07:59:44.000000Z
+91a3df8885aad587eb667aadd6ca8f2f
+2011-06-10T16:28:28.115490Z
+2
+hairyhum
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+34360
+
+images
+dir
+
View
578 test/views/css/cupertino/.svn/text-base/jquery-ui-1.8.13.custom.css.svn-base
@@ -0,0 +1,578 @@
+/*
+ * jQuery UI CSS Framework 1.8.13
+ *
+ * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about)
+ * Dual licensed under the MIT or GPL Version 2 licenses.
+ * http://jquery.org/license
+ *
+ * http://docs.jquery.com/UI/Theming/API
+ */
+
+/* Layout helpers
+----------------------------------*/
+.ui-helper-hidden { display: none; }
+.ui-helper-hidden-accessible { position: absolute !important; clip: rect(1px 1px 1px 1px); clip: rect(1px,1px,1px,1px); }
+.ui-helper-reset { margin: 0; padding: 0; border: 0; outline: 0; line-height: 1.3; text-decoration: none; font-size: 100%; list-style: none; }
+.ui-helper-clearfix:after { content: "."; display: block; height: 0; clear: both; visibility: hidden; }
+.ui-helper-clearfix { display: inline-block; }
+/* required comment for clearfix to work in Opera \*/
+* html .ui-helper-clearfix { height:1%; }
+.ui-helper-clearfix { display:block; }
+/* end clearfix */
+.ui-helper-zfix { width: 100%; height: 100%; top: 0; left: 0; position: absolute; opacity: 0; filter:Alpha(Opacity=0); }
+
+
+/* Interaction Cues
+----------------------------------*/
+.ui-state-disabled { cursor: default !important; }
+
+
+/* Icons
+----------------------------------*/
+
+/* states and images */
+.ui-icon { display: block; text-indent: -99999px; overflow: hidden; background-repeat: no-repeat; }
+
+
+/* Misc visuals
+----------------------------------*/
+
+/* Overlays */
+.ui-widget-overlay { position: absolute; top: 0; left: 0; width: 100%; height: 100%; }
+
+
+/*
+ * jQuery UI CSS Framework 1.8.13
+ *
+ * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about)
+ * Dual licensed under the MIT or GPL Version 2 licenses.
+ * http://jquery.org/license
+ *
+ * http://docs.jquery.com/UI/Theming/API
+ *
+ * To view and modify this theme, visit http://jqueryui.com/themeroller/?ffDefault=Lucida%20Grande,%20Lucida%20Sans,%20Arial,%20sans-serif&fwDefault=bold&fsDefault=1.1em&cornerRadius=6px&bgColorHeader=deedf7&bgTextureHeader=03_highlight_soft.png&bgImgOpacityHeader=100&borderColorHeader=aed0ea&fcHeader=222222&iconColorHeader=72a7cf&bgColorContent=f2f5f7&bgTextureContent=04_highlight_hard.png&bgImgOpacityContent=100&borderColorContent=dddddd&fcContent=362b36&iconColorContent=72a7cf&bgColorDefault=d7ebf9&bgTextureDefault=02_glass.png&bgImgOpacityDefault=80&borderColorDefault=aed0ea&fcDefault=2779aa&iconColorDefault=3d80b3&bgColorHover=e4f1fb&bgTextureHover=02_glass.png&bgImgOpacityHover=100&borderColorHover=74b2e2&fcHover=0070a3&iconColorHover=2694e8&bgColorActive=3baae3&bgTextureActive=02_glass.png&bgImgOpacityActive=50&borderColorActive=2694e8&fcActive=ffffff&iconColorActive=ffffff&bgColorHighlight=ffef8f&bgTextureHighlight=03_highlight_soft.png&bgImgOpacityHighlight=25&borderColorHighlight=f9dd34&fcHighlight=363636&iconColorHighlight=2e83ff&bgColorError=cd0a0a&bgTextureError=01_flat.png&bgImgOpacityError=15&borderColorError=cd0a0a&fcError=ffffff&iconColorError=ffffff&bgColorOverlay=eeeeee&bgTextureOverlay=08_diagonals_thick.png&bgImgOpacityOverlay=90&opacityOverlay=80&bgColorShadow=000000&bgTextureShadow=04_highlight_hard.png&bgImgOpacityShadow=70&opacityShadow=30&thicknessShadow=7px&offsetTopShadow=-7px&offsetLeftShadow=-7px&cornerRadiusShadow=8px
+ */
+
+
+/* Component containers
+----------------------------------*/
+.ui-widget { font-family: Lucida Grande, Lucida Sans, Arial, sans-serif; font-size: 1.1em; }
+.ui-widget .ui-widget { font-size: 1em; }
+.ui-widget input, .ui-widget select, .ui-widget textarea, .ui-widget button { font-family: Lucida Grande, Lucida Sans, Arial, sans-serif; font-size: 1em; }
+.ui-widget-content { border: 1px solid #dddddd; background: #f2f5f7 url(images/ui-bg_highlight-hard_100_f2f5f7_1x100.png) 50% top repeat-x; color: #362b36; }
+.ui-widget-content a { color: #362b36; }
+.ui-widget-header { border: 1px solid #aed0ea; background: #deedf7 url(images/ui-bg_highlight-soft_100_deedf7_1x100.png) 50% 50% repeat-x; color: #222222; font-weight: bold; }
+.ui-widget-header a { color: #222222; }
+
+/* Interaction states
+----------------------------------*/
+.ui-state-default, .ui-widget-content .ui-state-default, .ui-widget-header .ui-state-default { border: 1px solid #aed0ea; background: #d7ebf9 url(images/ui-bg_glass_80_d7ebf9_1x400.png) 50% 50% repeat-x; font-weight: bold; color: #2779aa; }
+.ui-state-default a, .ui-state-default a:link, .ui-state-default a:visited { color: #2779aa; text-decoration: none; }
+.ui-state-hover, .ui-widget-content .ui-state-hover, .ui-widget-header .ui-state-hover, .ui-state-focus, .ui-widget-content .ui-state-focus, .ui-widget-header .ui-state-focus { border: 1px solid #74b2e2; background: #e4f1fb url(images/ui-bg_glass_100_e4f1fb_1x400.png) 50% 50% repeat-x; font-weight: bold; color: #0070a3; }
+.ui-state-hover a, .ui-state-hover a:hover { color: #0070a3; text-decoration: none; }
+.ui-state-active, .ui-widget-content .ui-state-active, .ui-widget-header .ui-state-active { border: 1px solid #2694e8; background: #3baae3 url(images/ui-bg_glass_50_3baae3_1x400.png) 50% 50% repeat-x; font-weight: bold; color: #ffffff; }
+.ui-state-active a, .ui-state-active a:link, .ui-state-active a:visited { color: #ffffff; text-decoration: none; }
+.ui-widget :active { outline: none; }
+
+/* Interaction Cues
+----------------------------------*/
+.ui-state-highlight, .ui-widget-content .ui-state-highlight, .ui-widget-header .ui-state-highlight {border: 1px solid #f9dd34; background: #ffef8f url(images/ui-bg_highlight-soft_25_ffef8f_1x100.png) 50% top repeat-x; color: #363636; }
+.ui-state-highlight a, .ui-widget-content .ui-state-highlight a,.ui-widget-header .ui-state-highlight a { color: #363636; }
+.ui-state-error, .ui-widget-content .ui-state-error, .ui-widget-header .ui-state-error {border: 1px solid #cd0a0a; background: #cd0a0a url(images/ui-bg_flat_15_cd0a0a_40x100.png) 50% 50% repeat-x; color: #ffffff; }
+.ui-state-error a, .ui-widget-content .ui-state-error a, .ui-widget-header .ui-state-error a { color: #ffffff; }
+.ui-state-error-text, .ui-widget-content .ui-state-error-text, .ui-widget-header .ui-state-error-text { color: #ffffff; }
+.ui-priority-primary, .ui-widget-content .ui-priority-primary, .ui-widget-header .ui-priority-primary { font-weight: bold; }
+.ui-priority-secondary, .ui-widget-content .ui-priority-secondary, .ui-widget-header .ui-priority-secondary { opacity: .7; filter:Alpha(Opacity=70); font-weight: normal; }
+.ui-state-disabled, .ui-widget-content .ui-state-disabled, .ui-widget-header .ui-state-disabled { opacity: .35; filter:Alpha(Opacity=35); background-image: none; }
+
+/* Icons
+----------------------------------*/
+
+/* states and images */
+.ui-icon { width: 16px; height: 16px; background-image: url(images/ui-icons_72a7cf_256x240.png); }
+.ui-widget-content .ui-icon {background-image: url(images/ui-icons_72a7cf_256x240.png); }
+.ui-widget-header .ui-icon {background-image: url(images/ui-icons_72a7cf_256x240.png); }
+.ui-state-default .ui-icon { background-image: url(images/ui-icons_3d80b3_256x240.png); }
+.ui-state-hover .ui-icon, .ui-state-focus .ui-icon {background-image: url(images/ui-icons_2694e8_256x240.png); }
+.ui-state-active .ui-icon {background-image: url(images/ui-icons_ffffff_256x240.png); }
+.ui-state-highlight .ui-icon {background-image: url(images/ui-icons_2e83ff_256x240.png); }
+.ui-state-error .ui-icon, .ui-state-error-text .ui-icon {background-image: url(images/ui-icons_ffffff_256x240.png); }
+
+/* positioning */
+.ui-icon-carat-1-n { background-position: 0 0; }
+.ui-icon-carat-1-ne { background-position: -16px 0; }
+.ui-icon-carat-1-e { background-position: -32px 0; }
+.ui-icon-carat-1-se { background-position: -48px 0; }
+.ui-icon-carat-1-s { background-position: -64px 0; }
+.ui-icon-carat-1-sw { background-position: -80px 0; }
+.ui-icon-carat-1-w { background-position: -96px 0; }
+.ui-icon-carat-1-nw { background-position: -112px 0; }
+.ui-icon-carat-2-n-s { background-position: -128px 0; }
+.ui-icon-carat-2-e-w { background-position: -144px 0; }
+.ui-icon-triangle-1-n { background-position: 0 -16px; }
+.ui-icon-triangle-1-ne { background-position: -16px -16px; }
+.ui-icon-triangle-1-e { background-position: -32px -16px; }
+.ui-icon-triangle-1-se { background-position: -48px -16px; }
+.ui-icon-triangle-1-s { background-position: -64px -16px; }
+.ui-icon-triangle-1-sw { background-position: -80px -16px; }
+.ui-icon-triangle-1-w { background-position: -96px -16px; }
+.ui-icon-triangle-1-nw { background-position: -112px -16px; }
+.ui-icon-triangle-2-n-s { background-position: -128px -16px; }
+.ui-icon-triangle-2-e-w { background-position: -144px -16px; }
+.ui-icon-arrow-1-n { background-position: 0 -32px; }
+.ui-icon-arrow-1-ne { background-position: -16px -32px; }
+.ui-icon-arrow-1-e { background-position: -32px -32px; }
+.ui-icon-arrow-1-se { background-position: -48px -32px; }
+.ui-icon-arrow-1-s { background-position: -64px -32px; }
+.ui-icon-arrow-1-sw { background-position: -80px -32px; }
+.ui-icon-arrow-1-w { background-position: -96px -32px; }
+.ui-icon-arrow-1-nw { background-position: -112px -32px; }
+.ui-icon-arrow-2-n-s { background-position: -128px -32px; }
+.ui-icon-arrow-2-ne-sw { background-position: -144px -32px; }
+.ui-icon-arrow-2-e-w { background-position: -160px -32px; }
+.ui-icon-arrow-2-se-nw { background-position: -176px -32px; }
+.ui-icon-arrowstop-1-n { background-position: -192px -32px; }
+.ui-icon-arrowstop-1-e { background-position: -208px -32px; }
+.ui-icon-arrowstop-1-s { background-position: -224px -32px; }
+.ui-icon-arrowstop-1-w { background-position: -240px -32px; }
+.ui-icon-arrowthick-1-n { background-position: 0 -48px; }
+.ui-icon-arrowthick-1-ne { background-position: -16px -48px; }
+.ui-icon-arrowthick-1-e { background-position: -32px -48px; }
+.ui-icon-arrowthick-1-se { background-position: -48px -48px; }
+.ui-icon-arrowthick-1-s { background-position: -64px -48px; }
+.ui-icon-arrowthick-1-sw { background-position: -80px -48px; }
+.ui-icon-arrowthick-1-w { background-position: -96px -48px; }
+.ui-icon-arrowthick-1-nw { background-position: -112px -48px; }
+.ui-icon-arrowthick-2-n-s { background-position: -128px -48px; }
+.ui-icon-arrowthick-2-ne-sw { background-position: -144px -48px; }
+.ui-icon-arrowthick-2-e-w { background-position: -160px -48px; }
+.ui-icon-arrowthick-2-se-nw { background-position: -176px -48px; }
+.ui-icon-arrowthickstop-1-n { background-position: -192px -48px; }
+.ui-icon-arrowthickstop-1-e { background-position: -208px -48px; }
+.ui-icon-arrowthickstop-1-s { background-position: -224px -48px; }
+.ui-icon-arrowthickstop-1-w { background-position: -240px -48px; }
+.ui-icon-arrowreturnthick-1-w { background-position: 0 -64px; }
+.ui-icon-arrowreturnthick-1-n { background-position: -16px -64px; }
+.ui-icon-arrowreturnthick-1-e { background-position: -32px -64px; }
+.ui-icon-arrowreturnthick-1-s { background-position: -48px -64px; }
+.ui-icon-arrowreturn-1-w { background-position: -64px -64px; }
+.ui-icon-arrowreturn-1-n { background-position: -80px -64px; }
+.ui-icon-arrowreturn-1-e { background-position: -96px -64px; }
+.ui-icon-arrowreturn-1-s { background-position: -112px -64px; }
+.ui-icon-arrowrefresh-1-w { background-position: -128px -64px; }
+.ui-icon-arrowrefresh-1-n { background-position: -144px -64px; }
+.ui-icon-arrowrefresh-1-e { background-position: -160px -64px; }
+.ui-icon-arrowrefresh-1-s { background-position: -176px -64px; }
+.ui-icon-arrow-4 { background-position: 0 -80px; }
+.ui-icon-arrow-4-diag { background-position: -16px -80px; }
+.ui-icon-extlink { background-position: -32px -80px; }
+.ui-icon-newwin { background-position: -48px -80px; }
+.ui-icon-refresh { background-position: -64px -80px; }
+.ui-icon-shuffle { background-position: -80px -80px; }
+.ui-icon-transfer-e-w { background-position: -96px -80px; }
+.ui-icon-transferthick-e-w { background-position: -112px -80px; }
+.ui-icon-folder-collapsed { background-position: 0 -96px; }
+.ui-icon-folder-open { background-position: -16px -96px; }
+.ui-icon-document { background-position: -32px -96px; }
+.ui-icon-document-b { background-position: -48px -96px; }
+.ui-icon-note { background-position: -64px -96px; }
+.ui-icon-mail-closed { background-position: -80px -96px; }
+.ui-icon-mail-open { background-position: -96px -96px; }
+.ui-icon-suitcase { background-position: -112px -96px; }
+.ui-icon-comment { background-position: -128px -96px; }
+.ui-icon-person { background-position: -144px -96px; }
+.ui-icon-print { background-position: -160px -96px; }
+.ui-icon-trash { background-position: -176px -96px; }
+.ui-icon-locked { background-position: -192px -96px; }
+.ui-icon-unlocked { background-position: -208px -96px; }
+.ui-icon-bookmark { background-position: -224px -96px; }
+.ui-icon-tag { background-position: -240px -96px; }
+.ui-icon-home { background-position: 0 -112px; }
+.ui-icon-flag { background-position: -16px -112px; }
+.ui-icon-calendar { background-position: -32px -112px; }
+.ui-icon-cart { background-position: -48px -112px; }
+.ui-icon-pencil { background-position: -64px -112px; }
+.ui-icon-clock { background-position: -80px -112px; }
+.ui-icon-disk { background-position: -96px -112px; }
+.ui-icon-calculator { background-position: -112px -112px; }
+.ui-icon-zoomin { background-position: -128px -112px; }
+.ui-icon-zoomout { background-position: -144px -112px; }
+.ui-icon-search { background-position: -160px -112px; }
+.ui-icon-wrench { background-position: -176px -112px; }
+.ui-icon-gear { background-position: -192px -112px; }
+.ui-icon-heart { background-position: -208px -112px; }
+.ui-icon-star { background-position: -224px -112px; }
+.ui-icon-link { background-position: -240px -112px; }
+.ui-icon-cancel { background-position: 0 -128px; }
+.ui-icon-plus { background-position: -16px -128px; }
+.ui-icon-plusthick { background-position: -32px -128px; }
+.ui-icon-minus { background-position: -48px -128px; }
+.ui-icon-minusthick { background-position: -64px -128px; }
+.ui-icon-close { background-position: -80px -128px; }
+.ui-icon-closethick { background-position: -96px -128px; }
+.ui-icon-key { background-position: -112px -128px; }
+.ui-icon-lightbulb { background-position: -128px -128px; }
+.ui-icon-scissors { background-position: -144px -128px; }
+.ui-icon-clipboard { background-position: -160px -128px; }
+.ui-icon-copy { background-position: -176px -128px; }