data-collector/collect.lisp

;;;; collect.lisp
;;;;
;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>

(in-package #:collect)

;;; "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))

     (in-package ,name)

     (defvar *tables*)
     (defvar *db*)

     (defun start (port)
       (setq *db* (connect ,file))
       (iter (for (name . query))
             (do (execute-non-query *db* query)))
       (restas:start ,name :port 8080))

     (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"))))

     ,@body-forms))

(defun to-sql-type (type)
  (cadr (assoc type '((:integer "INTEGER")
                      (:text "TEXT")
                      (:real "REAL")
                      (:blob "BLOB")))))

(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)))))