(declaim (optimize (debug 3) (speed 0 ) (safety 3)) ) ;;;; lyangulus.lisp (ql:quickload :clack-errors) (in-package #:lyangulus) (defparameter *submissions* nil) (defparameter *by-distinct* (make-hash-table :test #'equalp)) (defparameter *users* (make-hash-table :test #'equalp)) ;;; "lyangulus" goes here. Hacks and glory await! (defun current-date-string () "Returns current date as a string." (multiple-value-bind (sec min hr day mon yr dow dst-p tz) (get-decoded-time) (declare (ignore dow dst-p)) (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d ~2,'0d" yr mon day hr min sec tz))) (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)))) (defclass submission () ((headline :initarg :headline :initform "" :accessor s-headline) (url :initarg :url :initform "" :accessor s-url) (date :initarg :date :initform "" :accessor s-date) (approved :initarg :approved :initform "" :accessor s-approved))) (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)))) (defmethod print-object ((obj submission) s) (print-unreadable-object (obj s :type t :identity t) (with-slots (headline url approved) obj (format s "H: ~s U: ~s A: ~s" headline url approved)))) (defun make-submission (headline url &key (approved "")) (make-instance 'submission :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 alist-submission (alist &key nil-if-exists (modify t)) (let* ((result (make-submission (cdr (assoc :headline alist :test #'string-equal)) (cdr (assoc :url alist :test #'string-equal)) :approved (aif (cdr (assoc :approved alist :test #'string-equal)) it ""))) (key (cons (s-headline result) (s-url result)))) (aif (gethash key *by-distinct*) (progn (when modify (setf (s-url it) (s-url result) (s-headline it) (s-headline result))) (if nil-if-exists nil it)) (progn (setf (gethash key *by-distinct*) result) 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-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)))) (setf (ningle:route *app* "/") (i-lambda (params) (ningle.context:with-context-variables (session) (handler-case (cl-oid-connect.utils:ensure-logged-in (cl-oid-connect.utils:redirect-if-necessary session (render-mustache #p"static/index.mustache.html" `((:links . ,(mapcar #'submission-alist *submissions*)) (:user . ,(user-alist (gethash :app-user session))))))) (cl-oid-connect.utils:user-not-logged-in (c) (render-mustache #p"static/index.mustache.html" `((:links . ,(mapcar #'submission-alist (get-moderated *submissions*)))))))))) (defun submit (params) (awhen (alist-submission params :nil-if-exists t) ;(format t "~s <<<" it) (push it *submissions*))) (defun get-by-key (headline url) (gethash (cons headline url) *by-distinct*)) (setf (ningle:route *app* "/murmuro" :method :POST) (i-lambda (params) (sleep 0.01) (submit params) '(302 (:location "/") ("Done")))) (setf (ningle:route *app* "/curo" :method :POST) (i-lambda (params) (cl-oid-connect.utils:require-login (alet (alist-submission params :modify nil) (let ((approval (string-downcase (cdr (assoc "approved" params :test #'equalp))))) (setf (s-approved it) (if (equal approval "+") "approved" (if (equal approval "-") "rejected")))))) '(302 (:location "/") ("Done")))) (setf (ningle:route *app* "/1" :method :GET) (i-lambda (params) `(200 () (,(format nil "~a" (/ 1 0)))))) (setf (ningle:route *app* "/login" :method :GET) (i-lambda (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"))))))))) (cl-oid-connect:def-route ("/logout" (params) :app *app*) (declare (ignore params)) (ningle:with-context-variables (session) (setf (gethash :userinfo session) nil) '(302 (:location "/")))) (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))))) (setf (ningle:route *app* "/feed" :method :GET) (i-lambda (params) (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://srv2.elangley.org:9090/feed" :description "Locus in quo sunt illi qui murmurant in angulis"))) (loop for submission in (reverse (get-moderated *submissions*)) do (alimenta::add-item-to-feed feed :title (s-headline submission) :link (s-url submission) :date (current-date-string) :next-id #'get-feed-guid :content "")) `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil)))))) (setf (ningle:route *app* "/firehose" :method :GET) (i-lambda (params) (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://srv2.elangley.org:9090/feed" :description "Locus in quo sunt illi qui murmurant in angulis"))) (loop for submission in (reverse *submissions*) do (alimenta::add-item-to-feed feed :title (s-headline submission) :link (s-url submission) :date (current-date-string) :next-id #'get-feed-guid :content "")) `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil)))))) (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 :whitespace) (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)))