(declaim (optimize (debug 3) (speed 0 ) (safety 3)) )
;;;; inangulis.lisp
(ql:quickload :clack-errors)
(in-package #:inangulis)
(defparameter *submissions* nil)
(defparameter *by-distinct* (make-hash-table :test #'equalp))
(defparameter *users* (make-hash-table :test #'equalp))
;;; "inangulis" 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)))