The Ballmer fears the Wumpus

.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

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

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

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

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

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