|
@@ -6,217 +6,24 @@
|
|
|
|
|
|
;;; "collect" goes here. Hacks and glory await!
|
|
|
|
|
|
-(defmacro define-application (name file &body body-forms)
|
|
|
- `(progn
|
|
|
- (restas:define-module ,name
|
|
|
- (:use :cl
|
|
|
- :cl-who
|
|
|
- :parenscript
|
|
|
- :sqlite
|
|
|
- :restas
|
|
|
- :iter)
|
|
|
- (:import-from #:hunchentoot
|
|
|
- #:post-parameter)
|
|
|
- (:import-from #:lass
|
|
|
- #:compile-and-write))
|
|
|
+(defvar *configuration* nil)
|
|
|
|
|
|
- (in-package ,name)
|
|
|
+(defvar *forms* nil)
|
|
|
|
|
|
- (defvar *tables*)
|
|
|
- (defvar *db*)
|
|
|
+(defvar *queries* nil)
|
|
|
|
|
|
- (defun start (port)
|
|
|
- (setq *db* (connect ,file))
|
|
|
- (iter (for (name . query))
|
|
|
- (do (execute-non-query *db* query)))
|
|
|
- (restas:start ,name :port 8080))
|
|
|
+(defvar *tables* nil)
|
|
|
|
|
|
- (define-route main-css ("main.css" :type "text/css")
|
|
|
- (compile-and-write
|
|
|
- (*
|
|
|
- :margin 0
|
|
|
- :padding 0
|
|
|
- :font-family "Georgia, Palantino, Times, 'Times New Roman', sans-serif")
|
|
|
- (body
|
|
|
- :backgroud "#fff")
|
|
|
- (a
|
|
|
- :text-decoration "none")
|
|
|
- ("a:link, a:visited"
|
|
|
- :color "#f30")
|
|
|
- ("a:hover"
|
|
|
- :color "#f90")
|
|
|
- (div.main-content
|
|
|
- :position "absolute"
|
|
|
- :top "40px"
|
|
|
- :left "280px"
|
|
|
- :width "500px"
|
|
|
- (h1
|
|
|
- :font-size "40px"
|
|
|
- :font-weight "normal"
|
|
|
- :line-height "43px"
|
|
|
- :letter-spacing "-1px")
|
|
|
- (div.results
|
|
|
- :margin-top "20px"
|
|
|
- (ul
|
|
|
- :list-style-type "none")
|
|
|
- (li
|
|
|
- :font-size "18px"
|
|
|
- :line-height "24px"
|
|
|
- :margin-left "70px"))
|
|
|
- (div.page-list
|
|
|
- :text-align "center"
|
|
|
- :float "bottom")
|
|
|
- (dl
|
|
|
- :margin-top "10px")
|
|
|
- (dt
|
|
|
- :font-size "18px"
|
|
|
- :font-weight "bold")
|
|
|
- (dd
|
|
|
- :margin-left "20px"
|
|
|
- :margin-bottom "15px"))
|
|
|
- (div.nav
|
|
|
- :position absolute
|
|
|
- :top "40px"
|
|
|
- :left "20px"
|
|
|
- :width "200px"
|
|
|
- :padding "20px 20px 0 0"
|
|
|
- :border-right "1px solid #ccc"
|
|
|
- :text-align "right"
|
|
|
- (h2
|
|
|
- :text-transform "uppercase"
|
|
|
- :font-size "13px"
|
|
|
- :color "#333"
|
|
|
- :letter-spacing "1px"
|
|
|
- :line-height "20px"
|
|
|
- (a
|
|
|
- :color "#333"))
|
|
|
- (ul
|
|
|
- :list-style-type "none"
|
|
|
- :margin "20px 0")
|
|
|
- (li
|
|
|
- :font-size "14px"
|
|
|
- :line-height "20 px")
|
|
|
- (hr
|
|
|
- :height "1px"
|
|
|
- :color "#ccc"
|
|
|
- :margin-top "5px"
|
|
|
- :margin-bottom "5px"))))
|
|
|
+(defvar *forms* nil)
|
|
|
|
|
|
- ,@body-forms))
|
|
|
+(defun get-config (section key)
|
|
|
+ (get-config-drive ))
|
|
|
|
|
|
-(defun to-sql-type (type)
|
|
|
- (cadr (assoc type '((:integer "INTEGER")
|
|
|
- (:text "TEXT")
|
|
|
- (:real "REAL")
|
|
|
- (:blob "BLOB")))))
|
|
|
+(defun main ()
|
|
|
+ (setq *configuration* (open-configuration-file (second *posix-argv*)))
|
|
|
+ (open-database)
|
|
|
+ (get-all-forms)
|
|
|
+ (get-all-queries))
|
|
|
|
|
|
-(defun relation (relationship)
|
|
|
- (if (not (null relationship))
|
|
|
- (destructuring-bind (table column) relationship
|
|
|
- (declare (string table column))
|
|
|
- (format nil " REFERENCES ~a (~a)"
|
|
|
- table
|
|
|
- column))
|
|
|
- ""))
|
|
|
-
|
|
|
-(defun col-to-clause (column)
|
|
|
- (destructuring-bind (name type &key (nullable t) (primary nil) relationship) column
|
|
|
- (declare (string name)
|
|
|
- (keyword type)
|
|
|
- (ignorable nullable relationship))
|
|
|
- (if (null primary)
|
|
|
- (if (null nullable)
|
|
|
- (format nil "~a ~a~a,"
|
|
|
- name
|
|
|
- (to-sql-type type)
|
|
|
- (relation relationship))
|
|
|
- (format nil "~a ~a~a NOT NULL,"
|
|
|
- name
|
|
|
- (to-sql-type type)
|
|
|
- (relation relationship)))
|
|
|
- (format nil "~a ~a PRIMARY KEY,"
|
|
|
- name
|
|
|
- (to-sql-type type)))))
|
|
|
-
|
|
|
-(defmacro define-table (name (&rest cols) &key &allow-other-keys)
|
|
|
- (let* ((clauses (map 'list #'col-to-clause cols))
|
|
|
- (sql-command (format nil "CREATE TABLE IF NOT EXISTS ~a~%(~%~{~a~%~});"
|
|
|
- name
|
|
|
- clauses)))
|
|
|
- `(push (cons ,name ,sql-command) *tables*)))
|
|
|
-
|
|
|
-(defun make-form-entry (entry)
|
|
|
- (destructuring-bind (label column &key (type :text) other-column options) entry
|
|
|
- (declare (string label column)
|
|
|
- (ignorable other-column options))
|
|
|
- (let ((label-name (concatenate 'string "fld_" column))
|
|
|
- (the-options (if (null options)
|
|
|
- (if (not (null other-column))
|
|
|
- `(,(car other-column) ,(cadr other-column))))))
|
|
|
- (case type
|
|
|
- (:text
|
|
|
- `(:tr
|
|
|
- (:td ,label)
|
|
|
- (:td (:input :type :text
|
|
|
- :name ,label-name))))
|
|
|
- (:drop-down
|
|
|
- `(:tr
|
|
|
- (:td ,label)
|
|
|
- (:td
|
|
|
- (:select :name ,label-name
|
|
|
- (loop for option in ,the-options
|
|
|
- collect (make-option-drop-down option))))))
|
|
|
- (:radio-buttons
|
|
|
- `(:tr
|
|
|
- (:td ,label)
|
|
|
- (:td (loop for option in ,the-options
|
|
|
- collect (make-option-radio option ,label-name)))))))))
|
|
|
-
|
|
|
-(defun make-option-drop-down (option)
|
|
|
- (let ((name (first option))
|
|
|
- (value (second option)))
|
|
|
- `(:option :value ,value ,name)))
|
|
|
-
|
|
|
-(defun make-option-radio (option label)
|
|
|
- (let ((name (first option))
|
|
|
- (value (second option)))
|
|
|
- `(:div (:input :type "radio" :name ,label :value ,value)
|
|
|
- ,name (:br))))
|
|
|
-
|
|
|
-(defun make-update-query (table columns fields)
|
|
|
- (let ((actual-query (format nil "INSERT INTO ~a (~{~a~^, ~}) values (~{~a~^, ~})"
|
|
|
- table
|
|
|
- columns
|
|
|
- (iter (for i in columns)
|
|
|
- (collect "?"))))
|
|
|
- (fields (iter (for field in fields)
|
|
|
- (collect `(post-parameter ,field)))))
|
|
|
- `(execute-non-query *db* ,actual-query ,@fields)))
|
|
|
-
|
|
|
-(defmacro define-form (name table (&rest fields) &key (title name) (description title) &allow-other-keys)
|
|
|
- (let* ((columns (map 'list #'second fields))
|
|
|
- (field-names (map 'list #'(lambda (column)
|
|
|
- (concatenate 'string "fld_" column))
|
|
|
- columns))
|
|
|
- (form-entries (map 'list #'make-form-entry fields))
|
|
|
- (update-query (make-update-query table columns field-names))
|
|
|
- (route-name (intern (string-upcase name)))
|
|
|
- (route-name-post (intern (string-upcase (concatenate 'string name "-post")))))
|
|
|
- `(progn
|
|
|
- (define-route ,route-name (,name)
|
|
|
- (with-html-output-to-string (out)
|
|
|
- (:html
|
|
|
- (:head (:title ,title)
|
|
|
- (:link :rel "style_sheet" :href (genurl 'main-css)))
|
|
|
- (:body (:div :class "nav")
|
|
|
- (:div :class "main-content"
|
|
|
- (:h1 ,title)
|
|
|
- (:p ,description)
|
|
|
- (:form :action (genurl ',route-name-post)
|
|
|
- :method :post
|
|
|
- (:table ,@form-entries
|
|
|
- (:tr (:td)
|
|
|
- (:td (:input :type :submit :value "Submit"))))))))))
|
|
|
- (define-route ,route-name-post (,name :method :post)
|
|
|
- ,update-query
|
|
|
- (redirect ',route-name)))))
|
|
|
+(define-route main ("")
|
|
|
+ (main-page :title "Collect"))
|