(in-package :cl-user)
(ql:quickload :cl-oid-connect)
(ql:quickload :plump)
(ql:quickload :cl-markup)
(push (cons "application" "rdf+xml") drakma:*text-content-types*)
(push (cons "text" "rss+xml") drakma:*text-content-types*)
(defparameter *app* (make-instance 'ningle:<app>))
(defclass rss-feed ()
((feed :accessor rss-feed-feed
:initarg :feed)
(channel :accessor rss-feed-channel)
(title :accessor rss-feed-title)
(link :accessor rss-feed-link)
(description :accessor rss-feed-description)
(items :accessor rss-feed-items)))
(defclass rss-item ()
((item :accessor rss-item-item :initarg :item)
(title :accessor rss-item-title)
(link :accessor rss-item-link)
(description-raw :accessor rss-item-description-raw)
(description :accessor rss-item-description)
(category :accessor rss-item-category)
(comments :accessor rss-item-comments)
(enclosure :accessor rss-item-enclosure)
(guid :accessor rss-item-guid)
(pub-date :accessor rss-item-pub-date)
(source :accessor rss-item-source)))
(defmacro get-elements (feed &optional (filter nil))
(let ((feed-sym (gensym))
(filter-lis `(lambda (x) (and (plump-dom:element-p x) ,@(loop for x in filter
collect `(funcall ,x x))))))
`(let ((,feed-sym ,feed))
(remove-if-not ,filter-lis (plump:children ,feed-sym)))))
(defmacro get-elements-by-tagname (feed tagname)
`(get-elements ,feed ((lambda (x) (string= ,tagname (plump:tag-name x))))))
(defmacro extract-text (selector &optional (default ""))
(alexandria:with-gensyms (selector-s)
`(let ((,selector-s ,selector))
(if (not (equalp #() (lquery:$ ,selector-s)))
(lquery:$ ,selector-s (text) (node))
,default))))
(defun make-rss-item (item)
(lquery:initialize item)
(flet ((dehtml (h) (plump:text (plump:parse h)))
(get-category-names (it) ;;; TODO: simplify this---Ask Shinmera on IRC
(if (not (equalp #() it))
(map 'vector
(lambda (x) (plump:text (elt (plump:children x) 0)))
it)
#())))
(let* ((result (make-instance 'rss-item :item item))
(title (extract-text "title"))
(link (extract-text "link"))
(description-raw (let ((plump:*html-tags*)
(ss (make-string-output-stream)))
(plump:serialize
(plump:parse (extract-text "description"))
ss)
(get-output-stream-string ss)))
(description-munged (dehtml (extract-text "description")))
(category (get-category-names (lquery:$ "category")))
;(comments)
;(enclosure)
(guid (extract-text "aaguid"))
(pub-date (extract-text "pubDate"))
(source (extract-text "source")))
(setf (rss-item-title result) title)
(setf (rss-item-link result) link)
(setf (rss-item-description-raw result) description-raw)
(setf (rss-item-description result) description-munged)
(setf (rss-item-category result) category)
;(setf (rss-item-comments result) comment)
;(setf (rss-item-enclosure result) enclosur)
(setf (rss-item-guid result) guid)
(setf (rss-item-pub-date result) pub-date)
(setf (rss-item-source result) source)
result)))
(defun make-rss-feed (feed)
(lquery:initialize feed)
(let* ((result (make-instance 'rss-feed :feed feed))
(channel (lquery:$ "channel" (text) (node)))
(title (lquery:$ "title" (text) (node)))
(link (lquery:$ "link" (text) (node)))
(description (lquery:$ "description" (text) (node)))
(items (lquery:$ "item")))
(setf (rss-feed-channel result) channel)
(setf (rss-feed-title result) title)
(setf (rss-feed-link result) link)
(setf (rss-feed-description result) description)
(setf (rss-feed-items result)
(loop for it across items
collect (make-rss-item it)))
result))
(cl-oid-connect:def-route ("/login" (params) :app *app*)
(cl-who:with-html-output-to-string (s)
(:html
(:head (:title "Login"))
(:body
(:div
:class "login-button facebook"
(:a :href "/login/facebook" "Facebook"))
(:div
:class "login-button google"
(:a :href "/login/google" "Google"))))))
(defparameter *feed-urls*
#(
"http://www.reddit.com/r/lisp.rss"
"http://www.reddit.com/r/scheme.rss"
"http://www.reddit.com/r/prolog.rss"
"http://www.reddit.com/r/haskell.rss"
"http://www.reddit.com/r/roguelikedev.rss"
"http://www.reddit.com/r/roguelikes.rss"
"http://www.reddit.com/r/talesfromtechsupport.rss"
"https://thomism.wordpress.com/feed/rss"
))
(let
((plump-parser:*tag-dispatchers* plump-parser:*xml-tags*))
(defparameter *docs* (map 'vector
(lambda (x)
(format t "~a~%" x)
(unwind-protect (plump-parser:parse
(drakma:http-request x))))
*feed-urls*)))
(defparameter *feeds* (map 'vector (lambda (x) (unwind-protect (make-rss-feed x))) *docs*))
(defclass palette () ; soloarized http://ethanschoonover.com/solarized
((base03 :accessor palette-base03 :initform "#002b36")
(base02 :accessor palette-base02 :initform "#073642")
(base01 :accessor palette-base01 :initform "#586e75")
(base00 :accessor palette-base00 :initform "#657b83")
(base0 :accessor palette-base0 :initform "#839496")
(base1 :accessor palette-base1 :initform "#93a1a1")
(base2 :accessor palette-base2 :initform "#eee8d5")
(base3 :accessor palette-base3 :initform "#fdf6e3")
(yellow :accessor palette-yellow :initform "#b58900")
(orange :accessor palette-orange :initform "#cb4b16")
(red :accessor palette-red :initform "#dc322f")
(magenta :accessor palette-magenta :initform "#d33682")
(violet :accessor palette-violet :initform "#6c71c4")
(blue :accessor palette-blue :initform "#268bd2")
(cyan :accessor palette-cyan :initform "#2aa198")
(green :accessor palette-green :initform "#859900")))
(defparameter *palette* (make-instance 'palette))
(defgeneric invert-palette (palette))
(defmacro initialize-to (obj1-v obj2-v &body slot-swaps)
(alexandria:with-gensyms (obj1 obj2)
`(let* ((,obj1 ,obj1-v)
(,obj2 ,obj2-v))
,@(loop for (to from) in slot-swaps
collect `(setf (,to ,obj1) (,from ,obj2))))))
(defmethod invert-palette ((palette palette))
(let ((result (make-instance 'palette)))
(initialize-to result palette
(palette-base03 palette-base3)
(palette-base02 palette-base2)
(palette-base01 palette-base1)
(palette-base00 palette-base0)
(palette-base0 palette-base00)
(palette-base1 palette-base01)
(palette-base2 palette-base02)
(palette-base3 palette-base03))
result))
(setf *palette* (invert-palette *palette*))
(defclass colorscheme ()
((bg :accessor -colorscheme-bg :initform 'base03)
(bg-highlight :accessor -colorscheme-bg-highlight :initform 'base02)
(fg-deemph :accessor -colorscheme-fg-deemph :initform 'base01)
(fg :accessor -colorscheme-fg :initform 'base0 )
(fg-highlight :accessor -colorscheme-fg-highlight :initform 'base1 )
(accent :accessor -colorscheme-accent :initform 'violet)))
(defgeneric accentize (colorscheme accent))
(defmethod accentize ((colorscheme colorscheme) accent)
(setf (colorscheme-accent colorscheme) (funcall accent colorscheme)))
(defmacro def-palette-accessor (scheme-slot scheme palette )
`(progn
(defgeneric ,scheme-slot (,scheme))
(defmethod ,scheme-slot ((,scheme colorscheme))
(slot-value ,palette (,(intern (concatenate 'string "-" (symbol-name scheme-slot))) ,scheme)))))
(def-palette-accessor colorscheme-bg scheme *palette*)
(def-palette-accessor colorscheme-bg-highlight scheme *palette*)
(def-palette-accessor colorscheme-fg-deemph scheme *palette*)
(def-palette-accessor colorscheme-fg scheme *palette*)
(def-palette-accessor colorscheme-fg-highlight scheme *palette*)
(def-palette-accessor colorscheme-accent scheme *palette*)
(defgeneric rebase (colorscheme))
(defmethod rebase ((colorscheme colorscheme))
(macrolet
((swap-color (obj slot color1 color2)
`(setf (,slot ,obj)
(if (string= (,slot ,obj) (,color1 ,obj))
(,color2 ,obj)
(,color1 ,obj)))))
; Note that swap-color doesn't use gensyms: so don't run functions in invocation
(swap-color colorscheme colorscheme-accent colorscheme-base1 colorscheme-base01)
(swap-color colorscheme colorscheme-bg colorscheme-base3 colorscheme-base03)
(swap-color colorscheme colorscheme-bg-highlight colorscheme-base3 colorscheme-base03)
(swap-color colorscheme colorscheme-deemph colorscheme-base0 colorscheme-base0)
(swap-color colorscheme colorscheme-fg colorscheme-base0 colorscheme-base0)
(swap-color colorscheme colorscheme-fg-highlight colorscheme-base0 colorscheme-base0)
colorscheme))
(defparameter *colorscheme* (make-instance 'colorscheme))
(rebase *colorscheme*)
(accentize *colorscheme* #'colorscheme-blue)
;rebase $base3, $base2, $base1, $base0,$base00,$base01,$base02,$base03
;rebase $base03,$base02,$base01,$base00 ,$base0 ,$base1 ,$base2 ,$base3
(cl-oid-connect:def-route ("/theme.css" (params) :app *app*)
(flet ((combine-unit-q (quant unit) (format nil "~d~a" quant unit)))
(let* ((header-height 13)
(height-units "vh")
(ss (lass:compile-and-write
`(* :color ,(colorscheme-fg *colorscheme*))
`(body :background-color ,(colorscheme-bg *colorscheme*))
`((:or h1 h2 h3)
:color ,(colorscheme-fg-highlight *colorscheme*))
`(.feed-header
:background-color ,(colorscheme-bg-highlight *colorscheme*))
`((:or h4 h5 h6) :color ,(colorscheme-fg-highlight *colorscheme*))
`(header
:border-bottom "thin" "solid" ,(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))
`(main
:height ,(combine-unit-q (- 100 header-height) height-units))
`((:or a (:and a :visited) (:and a :active) code.url)
:color ,(colorscheme-fg-highlight *colorscheme*))
`(section#sidebar
(ul.menu
((li + li)
:border-top "thin" "solid" ,(colorscheme-fg-highlight *colorscheme*))
((:and li :hover)
:background-color ,(colorscheme-bg-highlight *colorscheme*)
:color ,(colorscheme-fg-highlight *colorscheme*))))
`(.feed :border thin solid ,(colorscheme-fg *colorscheme*))
`(.link
:border-top thin solid ,(colorscheme-fg *colorscheme*)
:border-bottom none
(.link-header :background-color ,(colorscheme-bg-highlight *colorscheme*))
(.link-info
:color ,(colorscheme-fg-deemph *colorscheme*)
:border-bottom "thin" "solid" ,(colorscheme-fg *colorscheme*)
((:or a span)
:color inherit)
((:and a :hover)
:color ,(colorscheme-fg *colorscheme*))
))
`((:and .feed-header :hover)
:background-color ,(colorscheme-bg *colorscheme*))
`(.link.closed
(.link-header
:background-color ,(colorscheme-bg *colorscheme*))
((:and .link-header :hover)
:background-color ,(colorscheme-bg-highlight *colorscheme*)))
)))
`(200 (:content-type "text/css") ,ss))))
(defmacro item-markup (item)
(alexandria:with-gensyms (item-s)
`(let ((,item-s ,item))
(cl-markup:markup
(:li :class "link closed"
(:section :class "link-header"
(:h4 (rss-item-title ,item-s))
(:p :class "link-info"
(:a :target "_blank" :href (rss-item-link ,item-s)
(:span :class "link-url" (rss-item-link ,item-s)))
(:span :class "link-date") (rss-item-pub-date ,item-s)))
(:section :class "link-content"
(:div
(cl-markup:raw (rss-item-description-raw ,item-s)))))))))
(defmacro feed-markup (feed-v fc-v)
(alexandria:with-gensyms (feed fc)
`(let ((,feed ,feed-v)
(,fc ,fc-v))
(cl-markup:markup
(:section :class "feed closed" :id (format nil "feed-~a" ,fc)
(:section :class "feed-header"
(:h2 (rss-feed-title ,feed))
(:h3 (rss-feed-description ,feed)))
(:ul :class "post-list"
(loop for item in (rss-feed-items ,feed)
collect (item-markup item))))))))
(defmacro feedlist-markup (feedlist-v)
(alexandria:with-gensyms (feedlist)
`(let ((,feedlist ,feedlist-v))
(cl-markup:markup*
`(:ul :class "menu"
,@(loop for feed across ,feedlist
count feed into feed-count
collect
(list :li
(list :a
:href (format nil "#feed-~a" feed-count)
(rss-feed-title feed)))))))))
(defmacro base-template ()
`(cl-markup:html5
(:head
(:title "My Feeds")
(:script :src "https://code.jquery.com/jquery-2.1.4.min.js" :type "text/javascript" "")
(:script :src "/static/js/fold.js" :type "text/javascript" "")
(:link :rel "stylesheet" :href "/static/css/main.css")
(:link :rel "stylesheet" :href "/static/css/content.css")
(:link :rel "stylesheet" :href "/theme.css"))
(:body
(:header
(:h1 "Worricow"))
(:section :id "content"
(:section :id "sidebar"
(cl-markup:raw (feedlist-markup *feeds*)))
(:main
(loop for feed across *feeds*
count feed into feed-count
collect
(feed-markup feed feed-count))))
(:footer))))
(defun base-template-f () (base-template))
;(cl-oid-connect:def-route ("/" (params) :app *app*)
; (ningle:with-context-variables (session)
; (cl-oid-connect:redirect-if-necessary session
; (cl-oid-connect:require-login
; (anaphora:sunless (gethash :counter session) (setf anaphora:it 0))
; (incf (gethash :counter session))
; (format nil "~Ath visit<br/>~a<br/><br/>"
; (gethash :counter session))))))
(cl-oid-connect:def-route ("/reflect" (params) :app *app* :method :post)
(format nil "~s<hr/>" (jonathan.encode:to-json (jonathan:parse (car (elt params 0))))))
(cl-oid-connect:def-route ("/feeds/:feeds/html" (params) :app *app*)
(ningle.context:with-context-variables (session)
(cl-oid-connect:require-login
(let* ((feedlist-s (cdr (assoc :feeds params)))
(feedlist (mapcar #'parse-integer (split-sequence:split-sequence #\SPACE feedlist-s)))
(*feeds* (gethash :feeds session *feeds*))
(*feeds* (make-array (list (length feedlist))
:initial-contents (loop for x in feedlist
collect (elt *feeds* x)))))
(base-template-f)))))
(cl-oid-connect:def-route ("/" (params) :app *app*)
(ningle.context:with-context-variables (session)
(cl-oid-connect:require-login
(cl-oid-connect:require-login
(let ((*feeds* (gethash :feeds session *feeds*)))
(base-template-f))))))
(defvar *handler* nil)
(defun stop ()
(clack:stop (pop *handler*)))
(defun start (&optional tmp)
(let ((server (if (> (length tmp) 1)
(intern (string-upcase (elt tmp 1)) 'keyword)
:hunchentoot)))
(push (clack:clackup
(lack.builder:builder
:backtrace
:session
;:csrf
(:static :path "/static/" :root #p"./static/")
(funcall
(cl-oid-connect:oauth2-login-middleware
:facebook-info (truename "~/github_repos/cl-oid-connect/facebook-secrets.json")
:google-info (truename "~/github_repos/cl-oid-connect/google-secrets.json"))
*app*)) :port 9090 :server server)
*handler*)))