From e8198bd1e433894a87de265c2bb4502c1685c7be Mon Sep 17 00:00:00 2001 From: not manx Date: Sat, 23 May 2020 16:36:29 +0000 Subject: [PATCH] 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 | 2 +- src/bantflags.asd | 4 ++-- src/config.example.lisp | 2 +- src/db.lisp | 45 ++++++++++++----------------------------- src/main.lisp | 30 ++++++++++++--------------- src/utils.lisp | 36 ++++++++++++++------------------- 6 files changed, 45 insertions(+), 74 deletions(-) diff --git a/.gitignore b/.gitignore index d2d9315..20a11db 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1 @@ -src/config.lisp \ No newline at end of file +src/config.lisp diff --git a/src/bantflags.asd b/src/bantflags.asd index 343a6ef..897eb63 100644 --- a/src/bantflags.asd +++ b/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") diff --git a/src/config.example.lisp b/src/config.example.lisp index bb053bf..c789480 100644 --- a/src/config.example.lisp +++ b/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/"))) diff --git a/src/db.lisp b/src/db.lisp index c518e08..8e3627e 100644 --- a/src/db.lisp +++ b/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")) diff --git a/src/main.lisp b/src/main.lisp index 475db99..14cd5f9 100644 --- a/src/main.lisp +++ b/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") () diff --git a/src/utils.lisp b/src/utils.lisp index 907607c..fccf7aa 100644 --- a/src/utils.lisp +++ b/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)