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

     ,@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 &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)))
    ))