(in-package :cl-user) (ql:quickload :clack-middleware-postmodern) (ql:quickload '(:fwoar.lisputils :araneus :cl-markup :colors :lquery :plump :postmodern :sxql :clack-middleware-postmodern :dexador :spinneret :ubiquitous :iterate :jonathan :cl-actors :simple-tasks :cl-oid-connect :fwoar.lisputils :serapeum)) (declaim (optimize (speed 0) (safety 3) (debug 2))) (define-modify-macro aconsf (key value) (lambda (place k v) (acons k v place))) (aconsf drakma:*text-content-types* "application" "rdf+xml") (aconsf drakma:*text-content-types* "application" "rss+xml") (aconsf drakma:*text-content-types* "text" "rss+xml") ;(load "utils.lisp") (load "package.lisp") (load "rss.lisp") (in-package plump-dom) (defmethod serialize-object :around ((node element)) (when (string= (tag-name node) "iframe") (make-text-node node)) (call-next-method)) (in-package :whitespace) (use-package :fwoar.lisputils) (use-package :araneus) (ubiquitous:restore :whitespace) (defparameter *app* (make-instance 'ningle:)) (handler-bind ((warning #'sb-ext::muffle-warning)) (let* ((feed-urls (ubiquitous:value 'feed 'urls)) (plump-parser:*tag-dispatchers* plump:*xml-tags*) (docs (map 'vector (lambda (x) (plump:parse (drakma:http-request x))) feed-urls))) (defparameter *feeds* (map 'vector (lambda (x) (make-rss-feed x)) docs)))) (defparameter *db-connection-info* (ubiquitous:value 'db)) (defmacro with-whitespace-db (&body body) `(postmodern:with-connection *db-connection-info* ,@body)) (defmacro wc (&body body) "Utility function for the REPL" `(with-whitespace-db ,@body)) (defmacro with-xml-tags (&body body) `(let ((plump:*tag-dispatchers* plump:*xml-tags*)) ,@body)) (load "base-template.lisp") (defmacro defun-from-value (name value) `(setf (symbol-function ',name) ,value)) (defun-from-value jsonapi-encoder (jonathan.helper:compile-encoder () (success result) (list :|success| success :|result| result))) ; ; ; Ultimately, this will only serialize the feed if the client (cl-oid-connect:def-route ("/feeds/add" (params) :method :post :app *app*) (ningle.context:with-context-variables (session) (let ((user-info (gethash :app-user session)) (result '(302 (:location "/"))) (api (string= (cl-oid-connect:assoc-cdr "api" params 'string=) "yes")) (url (cl-oid-connect:assoc-cdr "url" params 'string=)) (plump-parser:*tag-dispatchers* plump-parser:*xml-tags*)) (cl-oid-connect:require-login (when (neither-null params user-info) (handler-case (let* ((doc (plump:parse (drakma:http-request url))) (uid (slot-value user-info 'id))) (multiple-value-bind (added-feed dao-feed) (store-feed doc) (subscribe-to-feed uid (slot-value dao-feed 'id)) (when api (setf result `(200 (:Content-Type "application/json") (,(jsonapi-encoder t added-feed))))))) (cl-postgres-error:unique-violation () (when api (setf result `(400 () (,(jsonapi-encoder nil "Feed already saved"))))))))) result))) ;;; TODO: add needs to return the new content, so that angular can append it (defparameter *userasdfs* nil) #|(cl-oid-connect:require-login ))|# ;;; this will be bound by calls to with-palette ;;; probably should be refactored out (defparameter *palette* nil) (defparameter *colorscheme* (make-instance 'colors:colorscheme)) (defun get-theme-css () (colors:with-palette (*palette*) (flet ((combine-unit-q (quant unit) (format nil "~d~a" quant unit))) (let* ((header-height 9) (main-right-margin (* 0.618 (- 100 header-height))) (height-units "vh") (ss (lass:compile-and-write `(* :color ,(colors:colorscheme-fg *colorscheme*)) `(body :background-color ,(colors:colorscheme-bg *colorscheme*)) `((:or h1 h2 h3) :color ,(colors:colorscheme-fg-highlight *colorscheme*)) `(.feed-header :background-color ,(colors:colorscheme-bg-highlight *colorscheme*)) `((:or h4 h5 h6) :color ,(colors:colorscheme-fg-highlight *colorscheme*)) `(header :border-bottom "thin" "solid" ,(colors:colorscheme-accent *colorscheme*) :height ,(combine-unit-q header-height height-units) :font-size ,(combine-unit-q (* 0.75 header-height) height-units) :line-height ,(combine-unit-q header-height height-units) (.flip-button :background-color ,(colors:colorscheme-fg *colorscheme*) :color ,(colors:colorscheme-bg *colorscheme*)) ((:and .flip-button :focus) :outline none) ((:and .flip-button :hover) :font-size ,(combine-unit-q (* 0.25 header-height) height-units))) `(main :border-left medium solid ,(colors:colorscheme-accent *colorscheme*) :height ,(combine-unit-q (- 100 header-height) height-units) ("#add-form" :box-shadow "0em" "0em" "0.2em" "0.2em" ,(colors:colorscheme-accent *colorscheme*) ((:or input button) :background-color ,(colors:colorscheme-bg *colorscheme*) :color ,(colors:colorscheme-fg *colorscheme*)) ) ) `((:or a (:and a :visited) (:and a :active) code.url) :color ,(colors:colorscheme-fg-highlight *colorscheme*)) `(section#sidebar :transition opacity "0.5s" ease (ul.menu ((li + li) :border-top "thin" "solid" ,(colors:colorscheme-fg-highlight *colorscheme*)) ((:and li :hover) :background-color ,(colors:colorscheme-hover-highlight *colorscheme*) :color ,(colors:colorscheme-fg-highlight *colorscheme*)))) `(.feed :border-bottom thick solid ,(colors:colorscheme-accent *colorscheme*) :border-left none) `(.link-header :background-color ,(colors:colorscheme-bg-highlight *colorscheme*)) `(.link :border-top thin solid ,(colors:colorscheme-fg *colorscheme*) :border-bottom none (.link-info :color ,(colors:colorscheme-fg-deemph *colorscheme*) :border-bottom "thin" "solid" ,(colors:colorscheme-fg *colorscheme*) ((:or a span) :color inherit) ((:and a :hover) :color ,(colors:colorscheme-fg *colorscheme*)) )) `((:and .feed-header :hover) :background-color ,(colors:colorscheme-hover-highlight *colorscheme*)) `((.link.closed .link-header) :background-color ,(colors:colorscheme-bg *colorscheme*)) `((:or (:and .link-header :hover) (.link.closed (:and .link-header :hover))) :background-color ,(colors:colorscheme-hover-highlight *colorscheme*))))) (declare (ignorable main-right-margin)) ; TODO: use this!!! `(200 (:content-type "text/css") (,ss)))))) (load "route-atoms.lisp") (define-view json-feed (the-feeds) `(200 (:content-type "application/json" :cache-control "private, max-age=300") (,(jsonapi-encoder t the-feeds)))) (define-controller json-feed (params) (ningle.context:with-context-variables (session) (let* ((user-info (gethash :app-user session)) (*feeds* (if user-info (deserialize user-info) *feeds*))) (setf *userasdfs* user-info) *feeds*)) ) (cl-oid-connect:def-route ("/demo" (params) :app *app*) (base-template-f t)) (defroutes *app* (("/feeds/json") (araneus:as-route 'json-feed)) (("/theme/:scheme.css") (araneus::compose-route (css) css)) (("/userinfo.json") (araneus::compose-route (id) userinfo)) (("/login") (araneus::compose-route (id) login)) (("/logout") (araneus::compose-route (logout) redirect)) (("/") (araneus:as-route 'root))) (defun assoc-cdr-alternatives (alist alt1 alt2 &optional (test #'eql)) (aif (cl-oid-connect:assoc-cdr alt1 alist test) it (cl-oid-connect:assoc-cdr alt2 alist test))) (cl-oid-connect::setup-oid-connect *app* (userinfo &rest args) (declare (ignore args) (optimize (speed 0) (safety 3) (debug 3))) (flet ((get-received-id (userinfo) (assoc-cdr-alternatives userinfo :id :sub)) (get-db-user (received-id) (car (postmodern:select-dao 'reader_user (:= :foreign-id received-id)))) (get-first-name (userinfo) (assoc-cdr-alternatives userinfo :first--name :given--name)) (get-last-name (userinfo) (assoc-cdr-alternatives userinfo :last--name :family--name)) (get-link (userinfo) (assoc-cdr-alternatives userinfo :link :profile))) (postmodern:with-transaction () (let ((received-id (get-received-id userinfo))) (aif (get-db-user received-id) it (postmodern:make-dao 'reader_user :foreign-id received-id :first-name (get-first-name userinfo) :last-name (get-last-name userinfo) :name (cl-oid-connect:assoc-cdr :name userinfo) :email (cl-oid-connect:assoc-cdr :email userinfo) :gender (cl-oid-connect:assoc-cdr :gender userinfo) :link (get-link userinfo) :locale (cl-oid-connect:assoc-cdr :locale userinfo))))))) (defun update-feed (url) (with-whitespace-db (postmodern:with-transaction () (upsert-feed (make-rss-feed (with-xml-tags (plump:parse (drakma:http-request url)))))))) (defmacro amapcar-with-body (list &body forms) (alexandria:once-only (list) `(mapcar (lambda (it) ,@forms) ,list))) (defun update-all-feeds () (with-whitespace-db (let ((urls (postmodern:query (:select 'fetch-url :from 'rss-feed-store)))) (amapcar-with-body urls (restart-case (apply #'update-feed it) (continue-updates () (warn (format nil "Skipping feed with fetch-url: ~s" it))) (use-value (v) (update-feed v))))))) (defun minutes (minutes) (* minutes 60)) (defun continue-updates (e) (declare (ignore e)) (let ((restart (find-restart 'continue-updates))) (when restart (format t "continuing") (invoke-restart restart)))) (let (update-thread stop) (defun start-update-thread () (setf update-thread (bordeaux-threads:make-thread (lambda () (loop (handler-bind ((drakma:parameter-error #'continue-updates)) (update-all-feeds)) (sleep (ubiquitous:value 'update-frequency)) (when stop (return-from nil nil)))) :name "Whitespace Update Thread"))) (defun stop-update-thread () (setf stop t) (setf update-thread nil))) (let ((handler nil)) (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 (lack.builder:builder :backtrace :session ;:csrf (lambda (app) (lambda (env) (postmodern:with-connection *db-connection-info* (funcall app env)))) (:static :path "/static/" :root #p"./static/") *app*) :port 9090 :server server) handler))) (defun restart-clack () (do () ((null handler)) (stop)) (start)))