collect.lisp 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122
  1. ;;;; collect.lisp
  2. ;;;;
  3. ;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
  4. (in-package #:collect)
  5. ;;; "collect" goes here. Hacks and glory await!
  6. (defmacro define-application (name file &body body-forms)
  7. `(progn
  8. (restas:define-module ,name
  9. (:use :cl
  10. :cl-who
  11. :parenscript
  12. :sqlite
  13. :restas
  14. :iter)
  15. (:import-from #:hunchentoot
  16. #:post-parameter)
  17. (:import-from #:lass
  18. #:compile-and-write))
  19. (in-package ,name)
  20. (defvar *tables*)
  21. (defvar *db*)
  22. (defun start (port)
  23. (setq *db* (connect ,file))
  24. (iter (for (name . query))
  25. (do (execute-non-query *db* query)))
  26. (restas:start ,name :port 8080))
  27. ,@body-forms))
  28. (defun to-sql-type (type)
  29. (cadr (assoc type '((:integer "INTEGER")
  30. (:text "TEXT")
  31. (:real "REAL")
  32. (:blob "BLOB")))))
  33. (defun relation (relationship)
  34. (if (not (null relationship))
  35. (destructuring-bind (table column) relationship
  36. (declare (string table column))
  37. (format nil " REFERENCES ~a (~a)"
  38. table
  39. column))
  40. ""))
  41. (defun col-to-clause (column)
  42. (destructuring-bind (name type &key (nullable t) (primary nil) relationship) column
  43. (declare (string name)
  44. (keyword type)
  45. (ignorable nullable relationship))
  46. (if (null primary)
  47. (if (null nullable)
  48. (format nil "~a ~a~a,"
  49. name
  50. (to-sql-type type)
  51. (relation relationship))
  52. (format nil "~a ~a~a NOT NULL,"
  53. name
  54. (to-sql-type type)
  55. (relation relationship)))
  56. (format nil "~a ~a PRIMARY KEY,"
  57. name
  58. (to-sql-type type)))))
  59. (defmacro define-table (name (&rest cols) &key &allow-other-keys)
  60. (let* ((clauses (map 'list #'col-to-clause cols))
  61. (sql-command (format nil "CREATE TABLE IF NOT EXISTS ~a~%(~%~{~a~%~});"
  62. name
  63. clauses)))
  64. `(push (cons ,name ,sql-command) *tables*)))
  65. (defun make-form-entry (entry)
  66. (destructuring-bind (label column &key (type :text) other-column options) entry
  67. (declare (string label column)
  68. (ignorable other-column options))
  69. (let ((label-name (concatenate 'string "fld_" column))
  70. (the-options (if (null options)
  71. (if (not (null other-column))
  72. `(,(car other-column) ,(cadr other-column))))))
  73. (case type
  74. (:text
  75. `(:tr
  76. (:td ,label)
  77. (:td (:input :type :text
  78. :name ,label-name))))
  79. (:drop-down
  80. `(:tr
  81. (:td ,label)
  82. (:td
  83. (:select :name ,label-name
  84. (loop for option in ,the-options
  85. collect (make-option-drop-down option))))))
  86. (:radio-buttons
  87. `(:tr
  88. (:td ,label)
  89. (:td (loop for option in ,the-options
  90. collect (make-option-radio option ,label-name)))))))))
  91. (defun make-option-drop-down (option)
  92. (let ((name (first option))
  93. (value (second option)))
  94. `(:option :value ,value ,name)))
  95. (defun make-option-radio (option label)
  96. (let ((name (first option))
  97. (value (second option)))
  98. `(:div (:input :type "radio" :name ,label :value ,value)
  99. ,name (:br))))
  100. (defmacro define-form (name table (&rest fields) &key &allow-other-keys)
  101. (let* ((columns (map 'list #'second fields))
  102. (field-names (map 'list #'(lambda (column)
  103. (concatenate 'string "fld_" column))
  104. columns))
  105. (form-entries (map 'list #'make-form-entry fields)))
  106. `(list (list ,@columns)
  107. (list ,@field-names))))