(in-package :kira)
(define-persistent-class content-mixin ()
((author :initform nil :accessor author :initarg :author)
(title :initform nil :accessor title :initarg :title)
(body :initform nil :accessor body :initarg :body))
(:default-initargs
:author (parameter 'author)
:title (parameter 'title)
:body (parameter 'body)))
(define-persistent-class message (input-mixin content-mixin)
((posted-time :reader posted-time :initform *response-time*)))
(define-persistent-class post (input-mixin content-mixin)
((canonical-name :initform nil :accessor canonical-name)
(canonical-path :allocation :instance :reader canonical-path)
(posted-time :initform *response-time* :reader posted-time)
(edited-time :initarg :edited-time :accessor edited-time)
(history :initform nil :accessor history)))
(defmethod slot-unbound ((class t) (post post) (slot-name (eql 'canonical-path)))
(symbol-macrolet ((path-segment (or (canonical-name post) (object-id post))))
(setf (slot-value post 'canonical-path) (format nil "/~A" path-segment))))
(defmethod (setf canonical-name) :around (canonical-name (post post))
(unless (or (some #'alpha-char-p canonical-name) (not canonical-name))
(error "Canonical name for ~S not valid: ~S." post canonical-name))
(whereas ((object (and canonical-name (find-object canonical-name))))
(when (and (typep object 'post) (not (eq object post)))
(when (equalp (canonical-name object) canonical-name)
(setf (canonical-name object) nil))))
(symbol-macrolet ((pages (get-root 'pages)))
(when (setq canonical-name (call-next-method))
(setf (get-term canonical-name pages) post))
(slot-makunbound post 'canonical-path)
canonical-name))
(defgeneric render-content (object)
(:method :around ((object-wrapped-in-box t))
(html ((:div :class "box") (call-next-method))))
(:method ((no-view t)) (respond-with :not-found))
(:method :around ((session session))
(let ((session-log (session-log session)))
(cond (session-log (render-log session-log))
(t (html ((:div :class "box")
(:let ((expiration-time (expiration-time session)))
(:pl (:pr :ip-address (:ip-address (ip-address session)))
(:pr :expiration-time (render-local-time expiration-time))
(:let ((authorization-time (authorization-time session)))
(:pr :authorization-time (:if authorization-time
(render-local-time authorization-time)
(:em "session not authorized")))))))))))))
(define-html-macro :with-header (logo-element-content . menu-items)
(let ((home-page-link `((:a :href "/") ,logo-element-content)))
`((:div :id "header") (:div ((:h1 :id "logo") ,home-page-link)
((:div :id "menu") ,@menu-items)))))
(define-html-macro :powered-by (&rest link-specifier)
`(:let* ((elapsed-time (- (get-internal-real-time) page-time))
(elapsed-sec (/ elapsed-time internal-time-units-per-second))
(elapsed-msec (* 1000.0 elapsed-sec)))
(format *html-output* "~,3F milliseconds." elapsed-msec)
#\Space "Powered by " (render-link ,@link-specifier)))
(defun system-request-p (request &aux (uri (request-uri request)))
(or (uri-query uri) (equal (cadr (uri-segments uri)) "system")))
(defun render-page (object)
(let ((page-time (get-internal-real-time)))
(html ((:html-page :lang "en-US")
((:progn ((:meta :charset :utf-8)) ((:link :rel "shortcut icon" :href "/favicon.ico")))
((:link :rel "stylesheet" :href (:princ (versioned-uri "kira:www;static;style.css"))))
((:link :rel "alternate" :href "/rss.xml" :title "RSS" :type "application/rss+xml"))
(:when (system-request-p *request*) ((:meta :name "robots" :content "noindex")))
((:meta :name "viewport" :content "width=device-width, initial-scale=1"))
(:title (render-title object) (:unless (eq object 'home) " | CL-PDX")))
(:if (typep object 'pathname)
((:body :class "code")
(:pre (hilite object)))
(:body ((:div :id "frame")
(:with-header (:b ((:span :id "site-title") "CL-PDX"))
(render-link 'post) " | " (render-link 'contact))
((:div :id "content") (render-content object))
((:div :id "footer") (:div (:powered-by 'kira))))))))))
(define-html-macro :pacific-time-zone (&optional (local-time '(get-local-time)))
`(:let ((hours-west (- (/ (local-time-zone (get-localized-time ,local-time)) 3600))))
(:format "Pacific ~:[Standard~;Daylight~] Time (UTC−0~D:00)" (eql hours-west 7)
hours-west)))
(define-html-macro :sent-at (message)
`(:let ((message-time (posted-time ,message)))
(:mark (render-local-time message-time))))
(defmethod render-content ((handler (eql 'contact)))
(let ((message (parameter 'message nil #'find-object)))
(html (:table-form (:tr (:th "Mail/To") (:td (link "mailto:info@cl-pdx.com")))
(:tr (:th "BTC/Addr") (:td (link "bitcoin:368YNSt3gLLT7KWBmSrwzkrGUVunLFKqwD")))
(:tr (:th "LTC/Addr") (:td (link "litecoin:MByZxhY1nn3MhADTru1TTBifCvygAmNkGa")))
(:tr (:th "LT/Zone") (:td (:pacific-time-zone *response-time*)))
(:when message (:tr (:th "Sent/At") (:td (:sent-at message))))
(:tr ((:td :colspan 2) ((:textarea :name 'body :rows 10 :cols 80))))
(:tr ((:td :colspan 2) ((:input :type :submit :value "Send Message"))))))))
(defmethod handle ((handler (eql 'contact)))
(redirect 'contact :message (when (parameter 'body)
(let ((message (make-instance 'message)))
(prog1 message (push-to-inbox message))))))
(defmethod canonical-path ((pathname pathname))
(let ((kira-source-files (system-value 'kira-source-files)))
(if (member pathname kira-source-files :test #'equal)
(format nil "/kira/~A" (file-namestring pathname))
(call-next-method))))
(defmacro print-code-extent (&optional safe)
(let ((extent-arguments '(:start start :end lexer-position)))
`(,(if safe 'write-string 'escape-html) lexer-string
,(if safe 'html-output nil) ,@extent-arguments)))
(defmacro %read-token (buffer)
(with-gensyms (char package multiple-escape-p)
`(loop with ,package = (if (lexer-match #\:) keyword-package kira-package)
with ,char and ,multiple-escape-p initially (reset-buffer ,buffer)
if (lexer-match #\|) do (setq ,multiple-escape-p (not ,multiple-escape-p))
else do (unless (setq ,char (and (or (lexer-match #\\) ,multiple-escape-p) (lexer-match t)))
(lexer-case (c) ((or alphanumeric ":$%&*_-=@+<>.!/?~") (setq ,char (char-upcase c)))))
(vector-push-extend (or ,char (return (if (> lexer-position start) ,package))) ,buffer))))
(defun symbol-id (symbol)
(orf (get symbol 'id)
(with-output-to-string (stream)
(write-string "kira." stream)
(with-lexer ((prin1-to-string symbol))
(loop (lexer-case (char (return))
((or #\- #\_ #\. digit) (write-char char stream))
(alpha (write-char (char-downcase char) stream))
(t (format stream ".~2,'0X" (char-code char)))))))))
(defun source-note-pathname (source-note)
(symbol-macrolet ((files (system-value 'kira-source-files)))
(let ((key (pathname-name (source-note-filename source-note))))
(find key files :key #'pathname-name :test #'string-equal))))
(defun symbol-uri (symbol)
(orf (get symbol 'uri)
(whereas ((source-note (cadar (find-definition-sources symbol))))
(whereas ((source-note-pathname (source-note-pathname source-note)))
(uri-string (make-uri :path (canonical-path source-note-pathname)
:fragment (symbol-id symbol)))))))
(defun global-definer-p (symbol)
(case symbol ((define-persistent-class defclass :accessor :reader
defvar defparameter defconstant defsetf define-setf-expander
defstruct deftype defmacro defun defgeneric defpackage
define-symbol-macro define-modify-macro defstaticvar
defstatic) t)))
(define-html-macro :kira (class symbol-id symbol-uri)
`(:if (or ,symbol-id (not (setq ,symbol-uri (symbol-uri symbol))))
((:span :class ,class :if* ,symbol-id :id ,symbol-id) (print-code-extent))
((:a :class ,class :href (:string ,symbol-uri)) (print-code-extent))))
(defun hilite (pathname)
(with-lexer ((file-string pathname))
(loop with html-output = *html-output*
with token-buffer = (make-buffer 40 'character)
with kira-package = (load-time-package :kira)
with keyword-package = (load-time-package :keyword)
with pending-definition-p and symbol-uri and package
for start of-type array-index = lexer-position
for symbol-id = nil
do (cond ((setq package (%read-token token-buffer))
(multiple-value-bind (symbol status)
(find-symbol token-buffer package)
(cond (pending-definition-p
(setq pending-definition-p nil symbol-id (symbol-id symbol)))
((global-definer-p symbol) (setq pending-definition-p t)))
(cond ((not status) (html ((:span :class "low-level") (print-code-extent))))
((keywordp symbol) (html (:kira "keyword" symbol-id symbol-uri)))
((eq (symbol-package symbol) (load-time-package :common-lisp))
(html ((:span :class "cl") (print-code-extent))))
((eq (symbol-package symbol) kira-package)
(case (schar lexer-string start)
(#\% (html (:kira "low-level" symbol-id symbol-uri)))
(otherwise (html (:kira "kira" symbol-id symbol-uri)))))
((html ((:span :class "ccl") (print-code-extent)))))))
((when (lexer-match #\;) (lexer-skip (not #\Newline)))
(html ((:span :class "comment") (print-code-extent))))
((whereas ((macro-char (lexer-match #\# "\\_$&>")))
(progn (decf lexer-position) (%read-token token-buffer))
(let ((class (case macro-char (#\\ "character") (t "c"))))
(html ((:span :class (:string class)) (print-code-extent))))))
((or (lexer-match #\# #\") (lexer-match #\"))
(loop while (lexer-case (c) (#\\ (lexer-match t)) (#\") (t t))
finally (html ((:span :class "string") (print-code-extent)))))
((html (lexer-skip "'`,.@")
(lexer-advance-if
(lexer-match #\#)
(lexer-skip digit)
(lexer-match (not "()[]{}<>&")))
(:if (> lexer-position start)
((:span :class "quote") (print-code-extent t))
(progn (when (or (lexer-match t) (loop-finish))
(lexer-skip (or whitespace "()[]{}")))
(print-code-extent t)))))))))
(defmethod render-content ((handler (eql 'kira)))
(loop for (pathname . more) on (system-value 'kira-source-files)
do (html (render-link pathname) (:when more (:br)))))
(define-persistent-class file (input-mixin)
((pathname :initform nil :accessor file-name :initarg :pathname)
(canonical-path :allocation :instance :initarg :canonical-path :accessor canonical-path)
(upload-time :initform *response-time* :accessor upload-time :accessor posted-time)))
(defmethod slot-unbound ((class t) (file file) (slot-name (eql 'canonical-path)))
(setf (canonical-path file) (uri-path (pathname-uri (file-name file)))))
(defun render-title (object &aux (title (title object)))
(when title (return-from render-title (html (:attribute title))))
(let ((object-id (when (typep object 'object) (object-id object))))
(format *html-output* "~(~A~)~@[:~D~]" (type-of object) object-id)))
(defgeneric title (object)
(:method ((symbol symbol))
(with-accessors ((capitalized-name string-capitalize)) symbol
(orf (get symbol 'title) (substitute #\Space #\- capitalized-name))))
(:method (object) (unless (typep object 'object) object))
(:method ((pathname pathname)) (file-namestring pathname))
(:method ((file file)) (file-namestring (file-name file))))
(defun render-link (object &rest parameters)
(let ((canonical-uri (apply #'uri-to object parameters)))
(with-accessors ((request-uri request-uri)) *request*
(html (:if (uri= request-uri canonical-uri)
((:span :class "non-link") (render-title object))
((:a :href canonical-uri) (render-title object)))))))
(defgeneric get-inferior-object (name superior-object)
(:method ((no-object-found t) (object t)) nil)
(:method (segment (superior-object (eql 'home)) &aux potential-object-id)
(cond ((setq potential-object-id (ignore-errors (parse-integer segment)))
(when (plusp potential-object-id) (get-object potential-object-id)))
((find segment '(kira system contact) :test #'string-equal))
((get-term segment (get-root 'pages))))))
(defmethod get-inferior-object (handler-name (dispatcher (eql 'system)))
(find-symbol (string-upcase handler-name) (load-time-package :kira)))
(defmethod get-inferior-object (segment (parent (eql 'kira)))
(let ((pathname (pathname (format nil "kira:code;~(~A~)" segment))))
(find pathname (system-value 'kira-source-files) :test #'equal)))
(defun render-local-time (local-time &aux (localized-time (get-localized-time local-time)))
(html ((:time :datetime localized-time) (print-local-time localized-time *html-output*))))
(defmethod render-content ((handler (eql 'home)))
(html (:standard-form (:p ((:input :type 'file :name "uploaded-file")))
(:p ((:input :type :submit :value "Upload"))))))
(defun render-log-entry (object)
(html ((:div :class "box")
(:let ((action (if (typep object 'file) "uploaded" "posted")))
(render-link object) (:br) (render-local-time (posted-time object)) (:br)
((:small :class "by") (:string action) " by " (render-link (session object)))))))
(defun render-log (log-entries &optional (limit 10))
(let ((start (or (parameter :start nil #'parse-integer) 0)))
(loop with selected-log-entries = (nthcdr start log-entries)
for object in selected-log-entries repeat limit
do (render-log-entry object)
finally (when (nthcdr limit selected-log-entries)
(let ((more-uri (uri-to t :start (+ start limit))))
(html (:p ((:a :href more-uri) "more >>"))))))))
(defmethod render-content :around ((handler (eql 'home)))
(html (call-next-method) (render-log (get-root 'log))))
(defun authorize-if-not (allowed-test)
(when allowed-test (return-from authorize-if-not))
(when (eq (request-method *request*) :post)
(respond-with :authorized-personnel-only))
(with-accessors ((return-to request-uri)) *request*
(let ((uri (uri-to 'authorize :return-to return-to)))
(html ((:div :class "box" :id "authorize")
((:standard-form :action uri)
(:p (:strong "*** PASSWORD REQUIRED ***"))
(:p ((:input :type :password :name :password :size 20))
" " ((:input :type :submit :value "Authorize")))))))))
(defmethod handle ((handler (eql 'authorize)))
(let ((return-to (or (parameter :return-to nil #'resolve-uri) *base-uri*)))
(when (eql (parameter "password" nil #'digest) (system-value 'password-digest))
(setf (authorization-time *session*) *response-time*))
(redirect return-to)))
(defun push-to-log (object)
(with-accessors ((session-log session-log)) (session object)
(progn (push object (get-root 'log)) (push object session-log))))
(defun log-entry-of-type (type-specifier)
(loop for object in (get-root 'log)
when (typep object type-specifier)
return object))
(defun duplicate-upload-p (filename temporary-name)
(whereas ((existing-file (log-entry-of-type 'file) file))
(and (equal filename (file-namestring (file-name existing-file)))
(files-equal temporary-name (file-name existing-file)))))
(defun push-to-inbox (object)
(push object (get-root 'inbox)))
(defmethod handle ((handler (eql 'home)))
(whereas ((uploaded-file (parameter "uploaded-file")))
(destructuring-bind (filename . temporary-name) uploaded-file
(when (duplicate-upload-p filename temporary-name) (return-from handle))
(let* ((namestring (concatenate 'simple-string "kira:www;static;" filename))
(uploaded-file (make-instance 'file :pathname (pathname namestring)))
(file-type (pathname-type filename)))
(with-accessors ((uploaded-file-id object-id)) uploaded-file
(unless (and file-type (rename-file temporary-name namestring :if-exists nil))
(setq namestring (format nil "kira:www;static;~D;~A" uploaded-file-id filename))
(ensure-directories-exist (setf (file-name uploaded-file) (pathname namestring)))
(rename-file temporary-name (typed-pathname namestring) :if-exists :supersede))
(push-to-log uploaded-file)
(push-to-inbox uploaded-file))))))
(defun can-edit-p (object &optional (session *session*))
(unless (typep object 'post) (return-from can-edit-p))
(with-accessors ((authorization-time authorization-time)) session
(and session (or (eq (session object) session) authorization-time))))
(define-html-macro :text-field (value can-edit-p name &rest attributes)
`((:input :type :text :name ,name :if* ,value :value ,value ,@attributes
:if* (not ,can-edit-p) :readonly :||)))
(defun render-textarea (text-designator &key (name 'body) (rows 10) (cols 80) can-edit-p)
(html ((:textarea :name name :rows rows :cols cols :if* (not can-edit-p) :readonly :||)
(:when text-designator (:princ text-designator)))))
(defmethod render-content ((handler (eql 'post)))
(html (:table-form (:tr (:th "Author") (:td (:text-field nil t 'author)))
(:tr (:th "Title") (:td (:text-field nil t 'title)))
(:tr ((:td :colspan 2) (render-textarea nil :can-edit-p t)))
(:tr ((:td :colspan 2) ((:input :type :submit :value "Post")))))))
(defun duplicate-content-p (content)
(and (equal (parameter 'author) (author content))
(equal (parameter 'title) (title content))
(equal (parameter 'body) (body content))))
(defmethod handle ((handler (eql 'post)))
(redirect (or (whereas ((post (log-entry-of-type 'post)))
(when (duplicate-content-p post) post))
(first (push-to-log (write-post))))))
(define-persistent-class revision (input-mixin content-mixin)
((edited-time :accessor edited-time :initform *response-time*)))
(defun write-post (&optional post)
(let ((new-post-p (eq post nil)))
(prog1 (orf post (make-instance 'post))
(with-accessors ((edited-time edited-time)) post
(whereas ((author (parameter 'author)) (session *session*))
(with-accessors ((session-name session-name)) session
(unless (and (equal author (author post)) session-name)
(setq session-name author))))
(unless new-post-p
(let ((revision (make-instance 'revision)))
(dolist (slot-name (object-slots revision))
(rotatef (persistent-slot-value revision slot-name)
(persistent-slot-value post slot-name)))
(push revision (history post))
(update-canonical-name post)))
(setq edited-time *response-time*)))))
(defun update-canonical-name (post &aux (title (title post)))
(let ((canonical-name (nstring-downcase (collapse (or title "")))))
(setf (canonical-name post) (when (some #'alpha-char-p canonical-name)
(let* ((object (find-object canonical-name))
(object-name (when (typep object 'post)
(canonical-name object))))
(let ((name-taken-p (equalp object-name canonical-name)))
(when (or (not name-taken-p) (eq object post))
canonical-name)))))))
(define-html-macro :save-button (&rest attributes &key (can-edit-p nil) &allow-other-keys)
`((:input :type :submit :if* (not ,can-edit-p) :disabled :|| ,@(sans attributes :can-edit-p))))
(defmethod render-content :around ((handler (eql 'edit)))
(let (can-edit-p (post (parameter 'post t #'find-object)))
(authorize-if-not (setq can-edit-p (can-edit-p post)))
(unless (typep post 'post) (respond-with :not-found))
(with-accessors ((title title) (name author)) post
(html ((:div :class "box")
(:table-form (:tr (:th "Author") (:td (:text-field name can-edit-p 'author)))
(:tr (:th "Title") (:td (:text-field title can-edit-p 'title)))
(:tr ((:td :colspan 2) (render-textarea (body post) :can-edit-p can-edit-p)))
(:tr ((:td :colspan 2) (:save-button :value "Save" :can-edit-p can-edit-p)))))))))
(defmethod handle ((handler (eql 'edit)))
(let ((post (parameter 'post t #'find-object)))
(redirect (if (can-edit-p post)
(write-post post)
post))))
(defmethod render-content ((post post))
(let ((edited-time (edited-time post))
(posted-time (posted-time post)))
(render-text (body post))
(html ((:p :class "meta")
((:a :href (uri-to post) :class "permalink")
((:span :class "permalink-text") "permalink"))
#\Space (render-link 'edit :post post)
(:br) "posted " (render-local-time posted-time)
(:br) "edited " (render-local-time edited-time)))))
(defmethod render-content :around ((handler (eql 'history)))
(html (:let* ((post (parameter 'post t #'find-object))
(basis (or (first (history post)) post))
(old (or (parameter "old" nil #'find-object) basis))
(new (or (parameter "new" nil #'find-object) post)))
((:div :class "box") ((:pre :class "diff") (render-diff (body new) (body old))))
(:whereas ((old-tail (member old (history post))) (next-oldest (second old-tail)))
(:p ((:a :href (uri-to t :post post :old next-oldest :new old)) "next >>"))))))
(defun authorized-session-p (&optional (session *session*))
(and session (if (authorization-time session) t nil)))
(defmethod render-content :around ((handler (eql 'system)))
(loop initially (authorize-if-not (authorized-session-p))
for object in (get-root 'inbox)
do (html ((:div :class "box")
(:pl (do-slots (slot-name slot-value object)
(render-slot-value slot-name slot-value)))))))
(defgeneric render-slot-value (slot-name slot-value)
(:method :around ((slot-name symbol) slot-value)
(unless (whitespacep slot-value) (call-next-method)))
(:method (slot-name slot-value)
(html (:pr slot-name (render-value slot-value))))
(:method ((slot-name (eql 'ip-address)) ip-address)
(html (:pr slot-name (:ip-address ip-address)))))
(defun render-value (object)
(labels ((render-uri (uri)
(html ((:a :href uri) uri)))
(render-pathname (pathname)
(or (whereas ((uri (ignore-errors (pathname-uri pathname))))
(let ((file-namestring (file-namestring pathname)))
(html ((:a :href uri) file-namestring))))
(default-render-value pathname)))
(default-render-value (object)
(html (:code (:princ object)))))
(declare (dynamic-extent #'default-render-value))
(funcall (typecase object
(uri #'render-uri)
(object #'render-link)
(pathname #'render-pathname)
(local-time #'render-local-time)
(otherwise #'default-render-value))
object)))
(defgeneric render-xml (object)
(:method :before ((object t))
(html +canonical-xml-declaration+))
(:method ((symbol (eql 'rss)))
(html ((:rss-channel
:|xmlns:dc| "http://purl.org/dc/elements/1.1/"
:|xmlns:atom| "http://www.w3.org/2005/Atom")
((:|atom:link|
:href (:princ (resolve-uri "/rss.xml"))
:rel "self" :type "application/rss+xml"
/))
(:title (render-title 'home))
(:link (absolute-uri-to 'home))
(:|pubDate| (822-time *html-output* (get-local-time)))
(:description (:princ (system-value 'description)))
(mapc #'render-channel-item (get-root 'log))))))
(defun render-channel-item (object &aux uri title)
(html (:item (:link (:princ (setq uri (absolute-uri-to object))))
(:title (:string (setq title (grab (render-title object)))))
(:guid *base-uri* (princ (object-id object) *html-output*))
(:|pubDate| (822-time *html-output* (posted-time object)))
(:description (:cdata ((:a :href uri) (:string title))))
(:|dc:creator| (render-title (session object))))))
(defun cache-xml (symbol &aux (pathname (format nil "kira:www;~(~A~).xml" symbol)))
(with-open-file (*html-output* pathname :direction :output :if-exists :supersede)
(render-xml symbol)))
(defmethod render-xml ((symbol (eql 'sitemap)))
(let ((kira-source-files (system-value 'kira-source-files)))
(html ((:urlset :xmlns "http://www.sitemaps.org/schemas/sitemap/0.9")
(dolist (object `(home kira contact ,@kira-source-files))
(html (:url (:loc (absolute-uri-to object)))))
(:url (:loc (:princ (resolve-uri "/comp.lang.lisp/"))))))))
(defstatic *http-process*
(let ((initial-package (load-time-package :kira)))
`(:initial-bindings ((*package* . ,initial-package))
:name "HTTP")))
(defun kill-server (server-process)
(process-kill server-process)
(close (make-socket :connect :active
:connect-timeout 0.5
:remote-host "127.0.0.1"
:remote-port 8080)))
(defun start-server (&optional restart-server-p)
(setq *random-state* (make-random-state t))
(setq *package* (load-time-value (find-package :kira)))
(setq *default-external-format* +binary-external-format+)
(setf *print-length* 1000 (get 'home 'title) "CL-PDX")
(open-database "kira:data;")
(let ((server-process (find-process "HTTP")))
(unless (and server-process (not restart-server-p))
(when server-process (kill-server server-process))
(process-run-function *http-process* #'http-serve))))