Temporarily took back up on the "collect" project

collect.asd

@@ -11,7 +11,11 @@
                #:cl-who
                #:lass
                #:parenscript
-               #:sqlite)
+               #:sqlite
+               #:parse-number
+               #:esrap)
   :serial t
   :components ((:file "package")
+               (:file "templates")
+               (:file "macros")
                (:file "collect")))

collect.lisp

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

config-parser.lisp

@@ -0,0 +1,86 @@
+;;;; config-parser.lisp
+
+(in-package #:config-parser)
+
+;;; "config-parser" goes here. Hacks and glory await!
+
+(defrule space
+    (+ (or #\Space #\Tab #\Newline))
+  (:constant nil))
+
+(defrule identifier
+    (* (or (alphanumericp character) "_" "-" "."))
+  (:text t)
+  (:lambda (identifier)
+    (intern (string-upcase identifier) "KEYWORD")))
+
+(defun not-doublequote (character)
+  (not (eql #\" character)))
+
+(defrule string-chars
+    (or (not-doublequote character)
+       (and #\\ #\")))
+
+(defrule string
+    (and #\" (* string-chars) #\")
+  (:destructure (sq string eq)
+                (declare (ignore sq eq))
+                (text string)))
+
+(defrule number
+    (and (? (or "-" "+"))
+       (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
+       (? (and "."
+             (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))
+       (? (and (or "e" "E")
+             (? "-")
+             (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")))))
+  (:text t)
+  (:lambda (num-string)
+    (parse-number num-string)))
+
+(defrule block-title
+    (and (? #\Newline) "[" (? space) identifier (? space) "]" (? #\Newline))
+  (:destructure (nl1 lb sp1 ident sp2 rb nl)
+                (declare (ignore nl1 lb sp1 sp2 rb nl))
+                ident))
+
+(defrule ident-path
+    (and identifier (? space) "/" (? space) identifier)
+  (:destructure (identa sp1 sep sp2 identb)
+                (declare (ignore sp1 sep sp2))
+                (list identa identb)))
+
+(defrule variable-expression
+    (and identifier (? space) "=" (? space) (or string number ident-path) (? #\Newline))
+  (:destructure (identifier sp1 eq sp2 value nl)
+                (declare (ignore sp1 eq sp2 nl))
+                (cons identifier value)))
+
+(defrule block-contents
+    (* variable-expression)
+  (:lambda (expressions)
+    (loop for expression in expressions
+       collect expression)))
+
+(defrule block
+    (and block-title block-contents)
+  (:destructure (title contents)
+                (cons title contents)))
+
+(defrule file
+    (* block)
+  (:lambda (blocks)
+    (loop for block in blocks
+       collect block)))
+
+(defun open-configuration-file (filename)
+  (parse 'file
+         (concatenate 'string
+                      (with-open-file (input-file filename)
+                        (loop for char = (read-char input-file nil 'foo)
+                           until (eq char 'foo)
+                           collect char)))))
+
+(defun get-config-drive (section ident config)
+  (cdr (assoc ident (cdr (assoc section config)))))

database.lisp

@@ -0,0 +1,63 @@
+;;;; database.lisp
+;;;;
+;;;; Copyright (c) 2016 Samuel W. Flint <swflint@flintfam.org>
+
+(in-package #:collect)
+
+;;; "collect" goes here.
+
+(defun format-column (column-definition)
+  (if (not (listp column-definition))
+      (string-downcase (format nil "~a" column-definition))
+      (if (eq 'as (first column-definition))
+          (format nil "~a AS ~a"
+                  (format-column (second column-definition))
+                  (format-column (third column-definition)))
+          (string-downcase (format nil "~a.~a"
+                                   (first column-definition)
+                                   (format-table-name (second column-definition)))))))
+
+(defun format-table-name (table-name)
+  (string-downcase (format nil "~a" table-name)))
+
+(defun format-where-clause (where &aux (where-clause (if (listp where) where (list where))))
+  (let* ((operator (first where-clause))
+         (lhs (second where-clause))
+         (rhs (third where-clause)))
+    (case operator
+      (<
+       (format nil "(~a < ~a)" (format-where-clause lhs) (format-where-clause rhs)))
+      (>
+       (format nil "(~a > ~a)" (format-where-clause lhs) (format-where-clause rhs)))
+      (=
+       (format nil "(~a = ~a)" (format-where-clause lhs) (format-where-clause rhs)))
+      (or
+       (format nil "(~a OR ~a)" (format-where-clause lhs) (format-where-clause rhs)))
+      (and
+       (format nil "(~a AND ~a)" (format-where-clause lhs) (format-where-clause rhs)))
+      (t
+       (if (numberp operator)
+           operator
+           (format-table-name where))))))
+
+(defun query-maker (query)
+  (destructuring-bind (nil columns &key from where group order limit) query
+    ;; (list columns from where group order limit)
+    (let ((column-format (map 'list #'format-column columns))
+          (tables (map 'list #'format-table-name from))
+          (where (format-where-clause where)))
+      (format nil "SELECT ~{~a~^, ~} FROM ~{~a~^, ~}~@[ WHERE ~a~]~@[ GROUP BY ~a~]~@[ ORDER BY ~a~]~@[ LIMIT ~a~];"
+              column-format
+              tables
+              where
+              group
+              order
+              limit))))
+
+(defun open-database ())
+
+(defun get-all-forms ())
+
+(defun get-all-queries ())
+
+;;; End collect

macros.lisp

@@ -0,0 +1,17 @@
+;;;; macros.lisp
+;;;;
+;;;; Copyright (c) 2016 Samuel W. Flint <swflint@flintfam.org>
+
+(in-package #:collect)
+
+;;; "collect" goes here.
+
+(defmacro define-table (name columns constraints))
+
+(defmacro define-view (name columns query))
+
+(defmacro define-query (name title query display))
+
+(defmacro define-form (name title table columns display))
+
+;;; End collect

mainpage.httmpl

@@ -0,0 +1,30 @@
+<html>
+  <head>
+    <title><!-- TMPL_VAR title --></title>
+    <link rel='StyleSheet' href='/main.css' />
+    <script src='/main.js'></script>
+  </head>
+  <body>
+    <div class='nav'>
+      <ul>
+        <!-- TMPL_LOOP nav -->
+        <!-- TMPL_IF heading -->
+        <!-- TMPL_IF href -->
+        <h2><a href='<!-- TMPL_VAR href -->'><!-- TMPL_VAR heading --></a></h2>
+        <!-- TMPL_ELSE -->
+        <h2><!-- TMPL_VAR heading --></h2>
+        <!-- /TMPL_IF -->
+        <!-- TMPL_ELSE -->
+        <li><a href='<!-- TMPL_VAR href -->'><!-- TMPL_VAR title --></a></li>
+        <!-- /TMPL_IF -->
+        <!-- /TMPL_LOOP -->
+        <hr />
+        <li><a href='/'>Main</a></li>
+      </ul>
+    </div>
+    <div class='main-content'>
+      <h1><!-- TMPL_VAR title --></h1>
+      <!-- TMPL_VAR content -->
+    </div>
+  </body>
+</html>

package.lisp

@@ -2,6 +2,26 @@
 ;;;;
 ;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
 
-(defpackage #:collect
+(defpackage #:config-parser
+  (:use :esrap
+        :cl)
+  (:import-from #:parse-number
+                #:parse-number)
+  (:export open-configuration-file
+           get-config-drive))
+
+(restas:define-module #:collect
   (:use #:cl
-        #:iterate))
+        ;; #:iterate
+        #:config-parser
+        #:sqlite
+        #:parenscript
+        #:restas)
+  (:import-from #:lass
+                #:compile-and-write)
+  (:import-from #:html-template
+                #:create-template-printer)
+  (:import-from #:hunchentoot
+                #:post-parameter
+                #:start-session
+                #:session-value))

scratch.txt

@@ -0,0 +1,3 @@
+;;; -*- lisp -*-
+
+(select (a b c) :from (a) :where ((< a 3)) :group t :order (b) :limit 3)

templates.lisp

@@ -0,0 +1,127 @@
+;;;; templates.lisp
+;;;;
+;;;; Copyright (c) 2016 Samuel W. Flint <swflint@flintfam.org>
+
+(in-package #:collect)
+
+;;; "collect" goes here.
+
+(defmacro define-html-template (name input &optional docstring)
+  "Generate an HTML template function"
+  (let* ((old-name name)
+         (name (intern (string-upcase old-name)))
+         (docstring (if docstring
+                        docstring
+                        (format nil "Template caller for ~a, as ~a" old-name name)))
+         (input (merge-pathnames input (asdf:system-source-directory '#:collect))))
+    `(defun ,name (&rest args)
+       ,docstring
+       (with-output-to-string (*standard-output*)
+         (funcall (create-template-printer ,input) args)))))
+
+(defmacro generate-static (name filename type script)
+  "Generate a static page"
+  (let* ((name (intern (string-upcase name)))
+         (type (getf (list :js "application/javascript"
+                           :javascript "application/javascript"
+                           :css "text/css")
+                     type)))
+    `(define-route ,name (,filename :content-type ,type)
+       ,script)))
+
+(defmacro define-css-page (name filename &rest body)
+  "Generate a static CSS page"
+  (let* ((name (intern (string-upcase filename)))
+         (css-chunks (map 'list #'compile-and-write body))
+         (css (format nil "~{~a~^~%~%~}" css-chunks)))
+    `(generate-static ,name
+                      ,filename
+                      :css
+                      ,css)))
+
+(defmacro define-js-page (name filename &rest script)
+  (let ((name (intern (string-upcase filename)))
+        (js (ps* script)))
+    `(generate-static ,name
+                      ,filename
+                      :javascript
+                      ,js)))
+
+(setq parenscript:*js-string-delimiter* #\"
+      html-template:*string-modifier* #'cl:identity)
+
+(define-css-page main.css "main.css"
+  (*
+   :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")))
+
+(define-js-page main.js "main.js")
+
+(define-html-template main-page "mainpage.httmpl")
+
+;;; End collect