(declaim (optimize (debug 3) (speed 0 ) (safety 3)) ) ;;;; inangulis.lisp (in-package #:inangulis) (defparameter *submissions* nil) (defparameter *by-distinct* (make-hash-table :test #'equalp)) (defparameter *users* (make-hash-table :test #'equalp)) (defparameter *persist* t) (defmacro cdr-assoc (&whole lis item alist &key key test test-not) `(cdr (assoc ,@(cdr lis)))) (defun str-assoc (param params &key (test #'equal) key) (cdr-assoc param params :test test :key key)) (defmacro setf1 (&body body) "Make setf a bit nicer" (list* 'setf (apply #'append body))) ;;; "inangulis" goes here. Hacks and glory await! (defun current-date-string () "Returns current date as a string." (local-time:format-timestring nil (local-time:now) :format local-time:+rfc-1123-format+)) (defclass user () ((uid :initarg :uid) (email :initarg :email) (name :initarg :name) (moderator :initarg :moderator :initform nil))) (defun user-alist (user) (with-slots (email name moderator) user `(("name" . ,name) ("email" . ,email) ("moderator" . ,moderator)))) (defmethod print-object ((obj user) s) (print-unreadable-object (obj s :type t :identity t) (with-slots (uid email name moderator) obj (format s "U: ~s E: ~s N: ~s M: ~s" uid email name moderator)))) (defun make-submission (headline url &key (approved "")) (alet 'inangulis.tables:submission (make-instance it :headline headline :url url :approved approved :date (current-date-string)))) (defun submission-alist (submission) `(("headline". ,(s-headline submission)) ("url" . ,(s-url submission)) ("date" . ,(s-url submission)) ("approved" . ,(s-approved submission)))) (defun get-by-key (headline url) (car (postmodern:select-dao 'inangulis.tables::submission (:and (:= 'headline headline) (:= 'url url))))) (defun alist-submission (alist &key nil-if-exists) (let* ((headline (cdr-assoc :headline alist :test #'string-equal)) (url (cdr-assoc :url alist :test #'string-equal)) (approved (or (cdr-assoc :approved alist :test #'string-equal) "")) (result (make-submission headline url :approved approved))) (with-slots ((headline inangulis.tables:headline) (url inangulis.tables:url)) result (aif (get-by-key headline url) (unless nil-if-exists it) result)))) (defun get-moderated (feeds) (remove-if (lambda (x) (not (equal x "approved"))) feeds :key #'s-approved)) (defparameter *app* (make-instance 'ningle:<app>)) (defmacro i-defun (name (&rest args) &body body) `(defun ,name (,@args) (declare (ignorable ,@(loop for x in args if (not (char= (elt (symbol-name x) 0) #\&)) collect x))) ,@body)) (defmacro i-lambda ((&rest args) &body body) `(lambda (,@args) (declare (ignorable ,@args)) ,@body)) (defun render-mustache (fn data) (with-open-file (s (truename fn)) (let ((template (make-string (file-length s)))) (read-sequence template s) (mustache:render* template data)))) (defmacro with-db (&body b) `(postmodern:with-connection (ubiquitous:value 'db) ,@b)) (defmacro with-submissions (&body b) `(with-db (let ((*submissions* (postmodern:select-dao 'inangulis.tables::submission t "date desc"))) ,@b))) (setf (ningle:route *app* "/") (flet ((render-index (&optional user) (render-mustache #p"static/index.mustache.html" (cons `(:links . ,(mapcar #'submission-alist *submissions*)) (when user (list `(:user . ,(user-alist user)))))))) (i-lambda (params) (with-submissions (ningle.context:with-context-variables (session) (handler-case (cl-oid-connect.utils:ensure-logged-in (cl-oid-connect.utils:redirect-if-necessary session (render-index (gethash :app-user session)))) (cl-oid-connect.utils:user-not-logged-in (c) (render-index)))))))) (defun submit (params) (with-db (awhen (alist-submission params :nil-if-exists t) (postmodern:insert-dao it) (push it *submissions*)))) (defun get-feed-guid (item) (with-slots (alimenta:title alimenta:link) item (let ((hasher (ironclad:make-digest 'ironclad:sha256))) (ironclad:update-digest hasher (ironclad:ascii-string-to-byte-array alimenta:title)) (ironclad:update-digest hasher (ironclad:ascii-string-to-byte-array alimenta:link)) (ironclad:byte-array-to-hex-string (ironclad:produce-digest hasher))))) ;; View Controllers (i-defun murmur (params) (sleep 0.01) (submit params) '(302 (:location "/") ("Done"))) (i-defun curate (params) (with-db (let ((*submissions* (postmodern:select-dao 'inangulis.tables::submission t "date desc"))) (cl-oid-connect.utils:require-login (alet (alist-submission params) (let ((approval (string-downcase (str-assoc "approved" params :test #'equalp)))) (setf (s-approved it) (if (equal approval "+") "approved" (if (equal approval "-") "rejected"))) (when *persist* (postmodern:update-dao it))))))) '(302 (:location "/") ("Done"))) (i-defun login-page (params) `(200 () (,(cl-who:with-html-output-to-string (s) (:html (:head (:title "Login") (:link :rel "stylesheet" :href "/static/css/login.css")) (:body (:h1 "In Angulis") (:div :class "login-buttons" (:a :class "facebook" :href "/login/facebook" "Login With Facebook")))))))) (i-defun logout (params) (ningle:with-context-variables (session) (setf (gethash :userinfo session) nil) '(302 (:location "/")))) (i-defun get-feed (params &key moderated) (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://in-angulis.com/feed" :description "Locus in quo sunt illi qui murmurant in angulis"))) (with-db (pomo:do-select-dao (('inangulis.tables::submission submission) (:raw (if moderated (pomo:sql (:= 'approved "approved")) "'t'")) (:desc 'date)) (alimenta::add-item-to-feed feed :title (s-headline submission) :link (s-url submission) :date (s-date submission) :next-id #'get-feed-guid :content ""))) `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil))))) (setf1 ((ningle:route *app* "/feed" :method :GET) (lambda (params) (get-feed params :moderated t))) ((ningle:route *app* "/firehose" :method :GET) #'get-feed) ((ningle:route *app* "/login" :method :GET) #'login-page) ((ningle:route *app* "/curo" :method :POST) #'curate) ((ningle:route *app* "/murmuro" :method :POST) #'murmur) ((ningle:route *app* "/logout" :method :POST) #'logout)) (cl-oid-connect::setup-oid-connect *app* (userinfo &rest args) (declare (ignore args)) (let ((id (cdr (assoc :id userinfo)))) (unless (gethash id *users*) (setf (gethash id *users*) (alet (make-instance 'user) (with-slots (uid name email) it (prog1 it (setf uid id name (cdr (assoc :name userinfo)) email (cdr (assoc :email userinfo)))))))) (gethash id *users*))) (let ((handler nil)) (ubiquitous:restore :inangulis) (defun stop () (clack:stop (pop handler))) (defun start (&optional tmp) (cl-oid-connect:initialize-oid-connect (ubiquitous:value 'facebook 'secrets) (ubiquitous:value 'google 'secrets)) (let ((server (if (> (length tmp) 1) (intern (string-upcase (elt tmp 1)) 'keyword) :hunchentoot))) (push (clack:clackup (funcall clack-errors:*clack-error-middleware* (lack.builder:builder :session (:static :path "/static/" :root #p"./static/") :backtrace *app* )) :port 9090 :server server) handler))) (defun restart-clack () (do () ((null handler)) (stop)) (start)))