From 3da4620a083281b2367b4ef41c93183d68494cca Mon Sep 17 00:00:00 2001 From: not manx Date: Fri, 22 May 2020 16:36:16 +0000 Subject: [PATCH] The Ballmer fears the Wumpus --- .gitignore | 1 + src/bantflags.asd | 17 +++++++++++ src/config.example.lisp | 6 ++++ src/db.lisp | 44 ++++++++++++++++++++++++++++ src/main.lisp | 63 +++++++++++++++++++++++++++++++++++++++++ src/utils.lisp | 62 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 193 insertions(+) create mode 100644 src/bantflags.asd create mode 100644 src/config.example.lisp create mode 100644 src/db.lisp create mode 100644 src/main.lisp create mode 100644 src/utils.lisp diff --git a/.gitignore b/.gitignore index 7bc0d44..948c48d 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ ## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore appsettings.json +src/config.lisp # User-specific files *.rsuser diff --git a/src/bantflags.asd b/src/bantflags.asd new file mode 100644 index 0000000..26b523b --- /dev/null +++ b/src/bantflags.asd @@ -0,0 +1,17 @@ +(asdf:defsystem #:bantflags + :description "the bantflags server component" + :author "Manx (boku@plum.moe)" + :mailto "boku@plum.moe" + :license "AGPLv3+" + :version "0.0.1" + :serial t + :depends-on (:hunchentoot + :easy-routes + :str + :clsql + :jonathan) + :Components + ((:file "utils") + (:file "db") + (:file "config") + (:file "main"))) diff --git a/src/config.example.lisp b/src/config.example.lisp new file mode 100644 index 0000000..c789480 --- /dev/null +++ b/src/config.example.lisp @@ -0,0 +1,6 @@ +(defvar config + '((boards "bant") + (staging-password "not implemented") + (db-conn "localhost" "bantflags" "flags" "default") + (poolsize 3) + (www-root #p"/path/to/files/"))) diff --git a/src/db.lisp b/src/db.lisp new file mode 100644 index 0000000..5c7f780 --- /dev/null +++ b/src/db.lisp @@ -0,0 +1,44 @@ +;; Comparing strings with both +(defparameter *flags* (make-hash-table :test 'equal)) +(defparameter *boards* (make-hash-table :test 'equal)) +(defparameter *flags-txt* 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';") + +(clsql:file-enable-sql-reader-syntax) + +(defmacro dbfun (name &rest body) + `(defun ,name ,(car body) + (clsql:with-database (db conn :database-type :mysql :pool t) + ,@(cdr body)))) + +(defun flag-id (flag) + (gethash flag *flags*)) + +(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 + (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)))) + :database db))))) + +(dbfun get-posts (posts board) + (let ((result (clsql:query (format nil get-posts-sql posts board :database db))) + (table (make-hash-table))) + (dolist (row result) + (let ((key (car row))) + (unless (gethash key table) + (setf (gethash key table) '()) + (push (cadr row) (gethash key table))))) + (jojo:to-json table))) + +(dbfun get-flags () + (clsql:select [id] [flag] + :from [flags] + :database db)) diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..f1347a4 --- /dev/null +++ b/src/main.lisp @@ -0,0 +1,63 @@ +(defun init () + (set-db-conn) + (dotimes (_ (cconf 'poolsize)) + (clsql:connect conn :database-type :mysql :pool t :if-exists :new)) + (when (eq nil clsql:*default-database*) + (error "fucked up connecting to database")) + (set-boards) + (set-flags) + (defvar +serb+ (make-instance 'hunchentoot:easy-acceptor + :port 4242 + :document-root (cconf 'www-root))) + (hunchentoot:start +serb+)) + +(defun main () + (handler-case (init) + (error (c) + (format t "Init fucked up, exiting ~a" c) + (return-from main))) + + (loop (sleep 43200) (gc :full t))) + +(defmethod hunchentoot:acceptor-status-message (acceptor (http-status-code (eql 404)) &key) + (format nil "")) + +(defmacro handle (method uri params &body body) + `(hunchentoot:define-easy-handler ,uri ,params + (unless (eq ,method (hunchentoot:request-method*)) + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (hunchentoot:abort-request-handler)) + ,@body)) + +(defun host-dir (uri path) + (push + (hunchentoot:create-folder-dispatcher-and-handler uri path) + 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 + (result + (insert-post post_nr board msg) + (format nil "{\"~a\": [~{\"~a\"~^,~}]}~%" post_nr msg)) + (t + (format nil "{\"Error\": \"~a\"}~%" msg)))))) + +(handle :get (api-flags :uri "/flags") + () + (setf (hunchentoot:content-type*) "text/plain") + (format nil "~a~%" *flags-txt*)) + +(handle :post (api-get :uri "/get") + (post_nrs board version) + (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))) + (t (format nil "~a~%" "bad")))) diff --git a/src/utils.lisp b/src/utils.lisp new file mode 100644 index 0000000..d666f25 --- /dev/null +++ b/src/utils.lisp @@ -0,0 +1,62 @@ +(defvar empty-flag '("empty, or there were errors. Re-set your flags.")) + +(defun conf (thing) + (let ((item (cdr (assoc thing config)))) + (if (null item) + (error "no such config item" thing) + item))) + +(defun cconf (thing) + (car (conf thing))) + +(defun set-boards () + (setf *boards* (make-hash-table :test 'equal)) + (mapc (lambda (board) (setf (gethash board *boards*) t)) (conf 'boards))) + +(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)) + (setf *flags-txt* + (cl-ppcre:regex-replace "empty, or there were errors. Re-set your flags\\.\\n" + (format nil "~{~a~^~%~}" (mapcan (lambda (x) (cdr x)) flags)) + "")))) +(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))) + +(defun post-number-p (post_nr) + (if (or (null post_nr) + (null (parse-integer post_nr :junk-allowed t))) + nil + post_nr)) + +(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)))))