Move back to clsql

There is no good mysql driver for Common Lisp, especially one that
supports Mariadb ootb. The horrific format used by cl-dbi for table
columns is franky unusable and though clsql is a pain to set up and
its ffi is arcane bullshittery it still does a better job.
Never doing databases in cl again.

.gitignore

@@ -1 +1 @@
-src/config.lisp
+src/config.lisp

src/bantflags.asd

@@ -6,8 +6,8 @@
   :version "0.0.1"
   :serial t
   :depends-on (:hunchentoot
-               :str
-               :cl-dbi
+               :cl-ppcre
+               :clsql
                :jonathan)
   :Components
   ((:file "utils")

src/config.example.lisp

@@ -1,6 +1,6 @@
 (defvar config
   '((boards "bant")
     (staging-password "not implemented")
-    (db-conn "bantflags" "flags" "default")
+    (db-conn "localhost" "bantflags" "flags" "default")
     (poolsize 3)
     (www-root #p"/path/to/files/")))

src/db.lisp

@@ -5,55 +5,36 @@
 (defparameter *flags* (make-hash-table :test 'equal))
 (defparameter *boards* (make-hash-table :test 'equal))
 (defparameter *flags-txt* nil)
-(defparameter conn-str nil)
+(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';")
 
-(defun fuck-you-fukamachi (conn |;_;|)
-  "What the fuck is going on with what dbi:fetch returns? why is it a
-fucking list with the database columns as a symbols with pipes around
-them? How in the dicking shit am I supposed to use :|post_nr| 1234 in
-any useful or practical way? Why does this fucking Wumpus of a human
-being Fukamachi feel the need to duplicate so much data? Don't get me
-wrong, clsql is easily worse to work with, but at least it was fucking
-smart enough to make the database fields into (values rows columns)"
-  (mapcar (lambda (x) (list (nth 1 x) (nth 3 x)))
-          (dbi:fetch-all (dbi:execute (dbi:prepare conn |;_;|)))))
-
 (defmacro dbfun (name &rest body)
   `(defun ,name ,(car body)
-     (dbi:with-connection  (conn :mysql
-                                 :database-name (car conn-str)
-                                 :username (nth 1 conn-str)
-                                 :password (nth 2 conn-str))
-       (dbi:do-sql conn "set names 'utf8';") ;; I fucking hate computers
+     (clsql:with-database (db conn :database-type :mysql :pool t)
        ,@(cdr body))))
 
 (defun flag-id (flag)
   (gethash flag *flags*))
 
-(dbfun ping ()
-       (dbi:ping conn))
-
 (dbfun insert-post (post_nr board flags)
-       (dbi:do-sql conn
-         (format nil "insert ignore into posts (post_nr, board) values (~a, '~a');" post_nr board))
-       (let ((post-id (cadr (dbi:fetch (dbi:execute (dbi:prepare conn (format nil "select id from posts where post_nr = ~a and board = '~a';" post_nr board)))))))
-         (dbi:do-sql conn
-             (with-output-to-string (s)
-               (format s "insert into postflags (post_nr, flag) values")
-               (loop for flag in (butlast flags)
-                     do (format s "(~a,~a)," post-id (flag-id flag)))
-               (format s "(~a,~a);" post-id (flag-id (car (last flags))))))))
+       (clsql:execute-command (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:execute-command
+          (with-output-to-string (s)
+            (format s "insert into postflags (post_nr, flag) values")
+            (loop for flag in (butlast flags)
+                  do (format s "(~a,~a)," post-id (flag-id flag)))
+            (format s "(~a,~a);" post-id (flag-id (car (last flags))))))))
 
 (dbfun get-posts (posts board)
-       (let ((result (fuck-you-fukamachi conn (format nil get-posts-sql posts board)))
+       (let ((result (clsql:query (format nil get-posts-sql posts board)))
              (table (make-hash-table)))
-         (loop for (post_nr . flag) in result do
+         (loop for (post_nr . flag) in (reverse result) do
            (unless (gethash post_nr table)
              (setf (gethash post_nr table) '()))
            (push (car flag) (gethash post_nr table)))
          (jojo:to-json table)))
 
 (dbfun get-flags ()
-       (fuck-you-fukamachi conn "select flags.id, flags.flag from flags"))
+       (clsql:query "select flags.id, flags.flag from flags"))

src/main.lisp

@@ -1,11 +1,7 @@
 (defun init ()
   (set-db-conn)
   (dotimes (_ (cconf 'poolsize))
-    (dbi:connect-cached :mysql
-                        :database-name (car conn-str)
-                        :username (nth 1 conn-str)
-                        :password (nth 2 conn-str)))
-  (ping) ;; test db conn  
+    (clsql:connect conn :database-type :mysql :pool t :if-exists :new))
   (set-boards)
   (set-flags)
   (defvar +serb+ (make-instance 'hunchentoot:easy-acceptor
@@ -32,25 +28,25 @@
 
 (handle :post (api-post :uri "/api/post")
     (post_nr regions board version)
-  (setf (hunchentoot:content-type*) "application/json")
-  (let ((separator (if (< 1 (get-version version)) "," "||")))
-    (multiple-value-bind (result msg) (post-valid-p post_nr regions board separator)
-      (cond
-        (result
-         (insert-post post_nr board msg)
-         (format nil "{\"~a\": [~{\"~a\"~^,~}]}~%" post_nr msg))
-        (t
-         (format nil "{\"Error\": \"~a\"}~%" msg))))))
+  (@json tbnl:*reply*)
+  (setf regions (cl-ppcre:split "," regions))
+  (multiple-value-bind (result msg) (post-valid-p post_nr regions board)
+    (cond
+      (result
+       (insert-post post_nr board msg)
+       (format nil "{\"~a\": [~{\"~a\"~^,~}]}~%" post_nr msg))
+      (t (format nil "{\"Error\": \"~a\"}~%" msg)))))
 
 (handle :post (api-get :uri "/api/get")
     (post_nrs board version)
   (@json tbnl:*reply*)
-  (setf post_nrs (str:split "," post_nrs))
+  (setf post_nrs (cl-ppcre:split "," post_nrs))
   (cond
-    ((and (loop for x in post_nrs always (post-number-p x))
+    ((and (not (null post_nrs))
+          (every #'post-number-p post_nrs)
           (boardp board))
      (format nil "~a~%" (get-posts post_nrs board)))
-    (t (format nil "~a~%" "bad"))))
+    (t (format nil "{[\"~a\"]}~%" "bad"))))
 
 (handle :get (api-flags :uri "/api/flags")
     ()

src/utils.lisp

@@ -15,7 +15,6 @@
 
 (defun set-flags ()
   (setf *flags* (make-hash-table :test 'equal))
-
   (let ((flags (get-flags)))
     (loop for (id . flag) in flags
           do (setf (gethash (car flag) *flags*) id))
@@ -24,11 +23,7 @@
                                   (format nil "~{~a~^~%~}" (mapcan (lambda (x) (cdr x)) flags))
                                   ""))))
 (defun set-db-conn ()
-  (setq conn-str (conf 'db-conn)))
-
-(defun get-version (thing)
-  (if (null thing) 0
-      (or (parse-integer thing :junk-allowed t) 0)))
+  (setq conn (conf 'db-conn)))
 
 (defun post-number-p (post_nr)
   (if (or (null post_nr)
@@ -39,22 +34,21 @@
 (defun boardp (board)
   (gethash board *boards*))
 
-(defun post-valid-p (post_nr regions board separator)
-  (let ((flags (str:split separator regions)))
-    (cond
-      ((not (post-number-p post_nr))
-       (values nil "Invalid post number"))
-      ((not (boardp board))
-       (values nil "Invalid board parameter."))
-      ((null regions)
-       (values t empty-flag))
-      ((< 30 (length flags))
-       (values nil "Too many flags."))
-      ((loop for flag in flags
-             always (gethash flag *flags*))
-       (values t flags))
-      (t (values t empty-flag)))))
+(defun post-valid-p (post_nr regions board)
+  (cond
+    ((not (post-number-p post_nr))
+     (values nil "Invalid post number."))
+    ((not (boardp board))
+     (values nil "Invalid board parameter."))
+    ((null regions)
+     (values t empty-flag))
+    ((< 30 (length regions))
+     (values nil "Too many flags."))
+    ((every (lambda (flag) (gethash flag *flags*)) regions)
+     (values t regions))
+    (t (values t empty-flag))))
 
+;; Unused, should be in utils
 (defun host-dir (uri path)
   (push
    (hunchentoot:create-folder-dispatcher-and-handler uri path)