Changes for testing

src/bantflags.asd

@@ -1,16 +1,15 @@
 (asdf:defsystem #:bantflags
-	:description "the bantflags server component"
+  :description "the bantflags server component"
-	:author "Manx (boku@plum.moe)"
+  :author "Manx (boku@plum.moe)"
   :mailto "boku@plum.moe"
-	:license "AGPLv3+"
+  :license "AGPLv3+"
-	:version "0.0.1"
+  :version "0.0.1"
-	:serial t
+  :serial t
-	:depends-on (:hunchentoot
+  :depends-on (:hunchentoot
-               :easy-routes
                :str
                :clsql
                :jonathan)
-	:Components
+  :Components
   ((:file "utils")
    (:file "db")
    (:file "config")

src/db.lisp

@@ -5,8 +5,7 @@
 (defparameter conn nil)
 
 (defvar get-posts-sql "SELECT posts.post_nr, flags.flag from flags left join postflags on (postflags.flag = flags.id) left join posts on (postflags.post_nr = posts.id) where posts.post_nr in (~{'~a'~^,~}) and posts.board = '~a';")
-
+;; (clsql:start-sql-recording)
-(clsql:file-enable-sql-reader-syntax)
 
 (defmacro dbfun (name &rest body)
   `(defun ,name ,(car body)
@@ -19,26 +18,22 @@
 (dbfun insert-post (post_nr board flags)
        (clsql:query (format nil "insert ignore into posts (post_nr, board) values (~a, '~a');" post_nr board))
        (let ((post-id (caar (clsql:query (format nil "select id from posts where post_nr = ~a and board = '~a';" post_nr board)))))
-         (clsql:with-transaction ()
+         (clsql:execute-command
-           (clsql:execute-command
+          (with-output-to-string (s)
-            (with-output-to-string (s)
+            (format s "insert into postflags (post_nr, flag) values")
-              (format s "insert into postflags (post_nr, flag) values")
+            (loop for flag in (butlast flags)
-              (loop for flag in (butlast flags)
+                  do (format s "(~a,~a)," post-id (flag-id flag)))
-                    do (format s "(~a,~a)," post-id (flag-id flag)))
+            (format s "(~a,~a);" post-id (flag-id (car (last flags))))
-              (format s "(~a,~a);" post-id (flag-id (car (last flags))))
+            :database db))))
-              :database db)))))
 
 (dbfun get-posts (posts board)
-       (let ((result (clsql:query (format nil get-posts-sql posts board :database db)))
+       (let ((result (clsql:query (format nil get-posts-sql posts board) :database db))
              (table (make-hash-table)))
-         (dolist (row result)
+         (loop for (post_nr . flag) in result do
-           (let ((key (car row)))
+           (unless (gethash post_nr table)
-             (unless (gethash key table)
+             (setf (gethash post_nr table) '()))
-               (setf (gethash key table) '())
+           (push (car flag) (gethash post_nr table)))
-               (push (cadr row) (gethash key table)))))
          (jojo:to-json table)))
 
 (dbfun get-flags ()
-       (clsql:select [id] [flag]
+       (clsql:query "select flags.id, flags.flag from flags" :database db))
-                     :from [flags]
-                     :database db))

src/main.lisp

@@ -15,8 +15,7 @@
   (handler-case (init)
     (error (c)
       (format t "Init fucked up, exiting ~a" c)
-      (return-from main)))
+      (return-from main)))  
-  
   (loop (sleep 43200) (gc :full t)))
 
 (defmethod hunchentoot:acceptor-status-message (acceptor (http-status-code (eql 404)) &key)
@@ -29,16 +28,9 @@
        (hunchentoot:abort-request-handler))
      ,@body))
 
-(defun host-dir (uri path)
+(handle :post (api-post :uri "/staging/post")
-  (push
+    (post_nr regions board version)
-   (hunchentoot:create-folder-dispatcher-and-handler uri path)
+  (setf (hunchentoot:content-type*) "application/json")
-   hunchentoot:*dispatch-table*))
-
-(host-dir "/flags/" (merge-pathnames #p"flags/" (cconf 'www-root)))
-
-(handle :post (api-post :uri "/post")
-    (post_nr regions board verison)
-  (@json)
   (let ((separator (if (< 1 (get-version version)) "," "||")))
     (multiple-value-bind (result msg) (post-valid-p post_nr regions board separator)
       (cond
@@ -48,16 +40,17 @@
         (t
          (format nil "{\"Error\": \"~a\"}~%" msg))))))
 
-(handle :get (api-flags :uri "/flags")
+(handle :post (api-get :uri "/staging/get")
-    ()
-  (setf (hunchentoot:content-type*) "text/plain")
-  (format nil "~a~%" *flags-txt*))
-
-(handle :post (api-get :uri "/get")
     (post_nrs board version)
+  (@json *reply*)
   (setf post_nrs (str:split "," post_nrs))
   (cond
     ((and (loop for x in post_nrs always (post-number-p x))
           (boardp board))
-     (format nil "~a" (get-posts post_nrs board)))
+     (format nil "~a~%" (get-posts post_nrs board)))
     (t (format nil "~a~%" "bad"))))
+
+(handle :get (api-flags :uri "/staging/flags")
+    ()
+  (@plain tbnl:*reply*)
+  (format nil "~a~%" *flags-txt*))

src/utils.lisp

@@ -26,12 +26,6 @@
 (defun set-db-conn ()
   (setq conn (conf 'db-conn)))
 
-(defun @plain ()
-  (setf (hunchentoot:content-type*) "text/plain"))
-
-(defun @json ()
-  (setf (hunchentoot:content-type*) "application/json"))
-
 (defun get-version (thing)
   (if (null thing) 0
       (or (parse-integer thing :junk-allowed t) 0)))
@@ -60,3 +54,18 @@
              always (gethash flag *flags*))
        (values t flags))
       (t (values t empty-flag)))))
+
+(defun host-dir (uri path)
+  (push
+   (hunchentoot:create-folder-dispatcher-and-handler uri path)
+   hunchentoot:*dispatch-table*))
+
+;; This is uneccessarily complicated, no I'm not sorry
+(defmacro content-type (types)
+  (cons 'progn
+        (mapcar (lambda (type) `(defun ,(car type) (reply)
+                             (setf (tbnl:content-type* reply) ,(cadr type))))
+                types)))
+(content-type
+ ((@json "application/json")
+  (@plain "text/plain")))