Compare commits
1 Commits
ご主人様
...
dotnetflag
| Author | SHA1 | Date |
|---|---|---|
not manx
|
7129d0375c
|
4 years ago |
@ -1,16 +0,0 @@
|
||||
(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
|
||||
:str
|
||||
:cl-dbi
|
||||
:jonathan)
|
||||
:Components
|
||||
((:file "utils")
|
||||
(:file "db")
|
||||
(:file "config")
|
||||
(:file "main")))
|
||||
@ -1,6 +0,0 @@
|
||||
(defvar config
|
||||
'((boards "bant")
|
||||
(staging-password "not implemented")
|
||||
(db-conn "bantflags" "flags" "default")
|
||||
(poolsize 3)
|
||||
(www-root #p"/path/to/files/")))
|
||||
@ -1,59 +0,0 @@
|
||||
;; Databases in common lisp are the fucking worst.
|
||||
;; Don't even bother.
|
||||
|
||||
;; Comparing strings with both
|
||||
(defparameter *flags* (make-hash-table :test 'equal))
|
||||
(defparameter *boards* (make-hash-table :test 'equal))
|
||||
(defparameter *flags-txt* nil)
|
||||
(defparameter conn-str 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
|
||||
,@(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))))))))
|
||||
|
||||
(dbfun get-posts (posts board)
|
||||
(let ((result (fuck-you-fukamachi conn (format nil get-posts-sql posts board)))
|
||||
(table (make-hash-table)))
|
||||
(loop for (post_nr . flag) in 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"))
|
||||
@ -1,58 +0,0 @@
|
||||
(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
|
||||
(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))
|
||||
|
||||
(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))))))
|
||||
|
||||
(handle :post (api-get :uri "/api/get")
|
||||
(post_nrs board version)
|
||||
(@json tbnl:*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)))
|
||||
(t (format nil "~a~%" "bad"))))
|
||||
|
||||
(handle :get (api-flags :uri "/api/flags")
|
||||
()
|
||||
(@plain tbnl:*reply*)
|
||||
(format nil "~a~%" *flags-txt*))
|
||||
@ -1,71 +0,0 @@
|
||||
(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-str (conf 'db-conn)))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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")))
|
||||
Loading…
Reference in new issue