Changes for testing

dotnetflags
not manx 5 years ago
parent 3da4620a08
commit eaeff37566
Signed by: C-xC-c
GPG Key ID: F52ED472284EF2F4

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

@ -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:file-enable-sql-reader-syntax)
;; (clsql:start-sql-recording)
(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
(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)))))
(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)))
(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)))))
(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 ()
(clsql:select [id] [flag]
:from [flags]
:database db))
(clsql:query "select flags.id, flags.flag from flags" :database db))

@ -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)
(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)
(handle :post (api-post :uri "/staging/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
@ -48,16 +40,17 @@
(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")
(handle :post (api-get :uri "/staging/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*))

@ -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")))

Loading…
Cancel
Save