(in-package :panettone)
(declaim (optimize (safety 3)))
;;;
;;; Data model
;;;
(defclass/std user ()
((cn dn mail displayname :type string)))
;;;
;;; LDAP integration
;;;
(defvar *ldap* nil
"The ldap connection")
(defun connect-ldap (&key
(host "localhost")
(port 389))
(setq *ldap* (ldap:new-ldap :host host :port port)))
(defun ldap-entry->user (entry)
(apply
#'make-instance
'user
:dn (ldap:dn entry)
(alexandria:mappend
(lambda (field)
(list field (car (ldap:attr-value entry field))))
(list :mail
:cn
:displayname))))
(defun find-user/ldap (username)
(check-type username (simple-array character (*)))
(ldap:search
*ldap*
`(and (= objectClass organizationalPerson)
(or
(= cn ,username)
(= dn ,username)))
;; TODO(grfn): make this configurable
:base "ou=users,dc=tvl,dc=fyi")
(ldap:next-search-result *ldap*))
(defun find-user (username)
(check-type username (simple-array character (*)))
(when-let ((ldap-entry (find-user/ldap username)))
(ldap-entry->user ldap-entry)))
(defun find-user-by-dn (dn)
(ldap:search *ldap* `(= objectClass organizationalPerson)
:base dn
:scope 'ldap:base)
(when-let ((ldap-entry (ldap:next-search-result *ldap*)))
(ldap-entry->user ldap-entry)))
(comment
(user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
)
(defun authenticate-user (user-or-username password)
"Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind
request against the ldap server at *ldap*. Returns the user if authentication is
successful, `nil' otherwise"
(when-let ((user (if (typep user-or-username 'user) user-or-username
(find-user user-or-username))))
(let ((dn (dn user)))
(let ((code-sym
(nth-value 1 (ldap:bind
(ldap:new-ldap :host (ldap:host *ldap*)
:port (ldap:port *ldap*)
:user dn
:pass password)))))
(when (equalp code-sym 'trivial-ldap:success)
user)))))
(defun author (object)
(find-user-by-dn (author-dn object)))
;;;
;;; Views
;;;
(defvar *title* "Panettone")
(defvar *user* nil)
(setf (who:html-mode) :html5)
(defun render/footer-nav ()
(who:with-html-output (*standard-output*)
(:footer
(:nav
(if (find (hunchentoot:request-uri*)
(list "/" "/issues/closed")
:test #'string=)
(who:htm (:span :class "placeholder"))
(who:htm (:a :href "/" "All Issues")))
(if *user*
(who:htm
(:form :class "form-link log-out"
:method "post"
:action "/logout"
(:input :type "submit" :value "Log Out")))
(who:htm
(:a :href
(format nil
"/login?original-uri=~A"
(drakma:url-encode (hunchentoot:request-uri*)
:utf-8))
"Log In")))))))
(defmacro render ((&key (footer t)) &body body)
`(who:with-html-output-to-string (*standard-output* nil :prologue t)
(:html
:lang "en"
(:head
(:title (who:esc *title*))
(:link :rel "stylesheet" :type "text/css" :href "/main.css")
(:meta :name "viewport"
:content "width=device-width,initial-scale=1"))
(:body
(:div
:class "content"
,@body
(when ,footer
(render/footer-nav)))))))
(defun render/alert (message)
"Render an alert box for MESSAGE, if non-null"
(check-type message (or null string))
(who:with-html-output (*standard-output*)
(when message
(who:htm (:div :class "alert" (who:esc message))))))
(defun render/login (&key message (original-uri "/"))
(render (:footer nil)
(:div
:class "login-form"
(:header
(:h1 "Login"))
(:main
:class "login-form"
(render/alert message)
(:form
:method :post :action "/login"
(:input :type "hidden" :name "original-uri"
:value original-uri)
(:div
(:label :for "username"
"Username")
(:input :type "text"
:name "username"
:id "username"
:placeholder "username"))
(:div
(:label :for "password"
"Password")
(:input :type "password"
:name "password"
:id "password"
:placeholder "password"))
(:input :type "submit"
:value "Submit"))))))
(defun created-by-at (issue)
(check-type issue model:issue)
(who:with-html-output (*standard-output*)
(:span :class "created-by-at"
"Opened by "
(:span :class "username"
(who:esc
(or
(when-let ((author (author issue)))
(displayname author))
"someone")))
" at "
(:span :class "timestamp"
(who:esc
(format-dottime (created-at issue)))))))
(defun render/issue-list (&key issues)
(who:with-html-output (*standard-output*)
(:ol
:class "issue-list"
(dolist (issue issues)
(let ((issue-id (model:id issue)))
(who:htm
(:li
(:a :href (format nil "/issues/~A" issue-id)
(:p
(:span :class "issue-subject"
(who:esc (subject issue))))
(:span :class "issue-number"
(who:esc (format nil "#~A" issue-id)))
" - "
(created-by-at issue)
(let ((num-comments (length (issue-comments issue))))
(unless (zerop num-comments)
(who:htm
(:span :class "comment-count"
" - "
(who:esc
(format nil "~A comment~:p" num-comments))))))))))))))
(defun render/index (&key issues)
(render ()
(:header
(:h1 "Issues")
(when *user*
(who:htm
(:a
:class "new-issue"
:href "/issues/new" "New Issue"))))
(:main
(:div
:class "issue-links"
(:a :href "/issues/closed" "View closed issues"))
(render/issue-list :issues issues))))
(defun render/closed-issues (&key issues)
(render ()
(:header
(:h1 "Closed issues"))
(:main
(:div
:class "issue-links"
(:a :href "/" "View open isues"))
(render/issue-list :issues issues))))
(defun render/new-issue (&optional message)
(render ()
(:header
(:h1 "New Issue"))
(:main
(render/alert message)
(:form :method "post"
:action "/issues"
:class "issue-form"
(:div
(:input :type "text"
:id "subject"
:name "subject"
:placeholder "Subject"))
(:div
(:textarea :name "body"
:placeholder "Description"
:rows 10))
(:input :type "submit"
:value "Create Issue")))))
(defun render/new-comment (issue-id)
(who:with-html-output (*standard-output*)
(:form
:class "new-comment"
:method "post"
:action (format nil "/issues/~A/comments" issue-id)
(:div
(:textarea :name "body"
:placeholder "Leave a comment"
:rows 5))
(:input :type "submit"
:value "Comment"))))
(defun render/issue (issue)
(check-type issue model:issue)
(let ((issue-id (id issue))
(issue-status (status issue)))
(render ()
(:header
(:h1 (who:esc (subject issue)))
(:div :class "issue-number"
(who:esc (format nil "#~A" issue-id))))
(:main
(:div
:class "issue-info"
(created-by-at issue)
(when *user*
(who:htm
(:form :class "set-issue-status"
:method "post"
:action (format nil "/issues/~A/~A"
issue-id
(case issue-status
(:open "close")
(:closed "open")))
(:input :type "submit"
:class (case issue-status
(:open "close-issue")
(:closed "open-issue"))
:value (case issue-status
(:open "Close")
(:closed "Reopen")))))))
(:p (who:esc (body issue)))
(let ((comments (issue-comments issue)))
(who:htm
(:div
:class "issue-comments"
(dolist (comment comments)
(let ((author (author comment)))
(who:htm
(:div
:class "comment"
(:p (who:esc (body comment)))
(:p
:class "comment-info"
(:span :class "username"
(who:esc (displayname author))
" at "
(who:esc (format-dottime (created-at comment)))))))))
(when *user*
(render/new-comment (id issue))))))))))
(defun render/not-found (entity-type)
(render ()
(:h1 (who:esc entity-type) "Not Found")))
;;;
;;; HTTP handlers
;;;
(defun @auth-optional (next)
(let ((*user* (hunchentoot:session-value 'user)))
(funcall next)))
(defun @auth (next)
(if-let ((*user* (hunchentoot:session-value 'user)))
(funcall next)
(hunchentoot:redirect
(format nil "/login?original-uri=~A"
(drakma:url-encode
(hunchentoot:request-uri*)
:utf-8)))))
(defun @txn (next)
(pomo:with-transaction ()
(catch
;; 'hunchentoot:handler-done is unexported, but is used by functions
;; like hunchentoot:redirect to nonlocally abort the request handler -
;; this doesn't mean an error occurred, so we need to catch it here to
;; make the transaction still get committed
(intern "HANDLER-DONE" "HUNCHENTOOT")
(funcall next))))
(defun @handle-issue-not-found (next)
(handler-case (funcall next)
(issue-not-found (err)
(render/not-found
(format nil "Issue #~A" (model:id err))))))
(defroute login-form ("/login" :method :get)
(original-uri)
(if (hunchentoot:session-value 'user)
(hunchentoot:redirect (or original-uri "/"))
(render/login :original-uri original-uri)))
(defroute submit-login ("/login" :method :post)
(&post original-uri username password)
(if-let ((user (authenticate-user username password)))
(progn
(setf (hunchentoot:session-value 'user) user)
(hunchentoot:redirect (or original-uri "/")))
(render/login :message "Invalid credentials")))
(defroute logout ("/logout" :method :post) ()
(hunchentoot:delete-session-value 'user)
(hunchentoot:redirect "/"))
(defroute index ("/" :decorators (@auth-optional)) ()
(let ((issues (model:list-issues :status :open)))
(render/index :issues issues)))
(defroute handle-closed-issues
("/issues/closed" :decorators (@auth-optional)) ()
(let ((issues (model:list-issues :status :closed)))
(render/closed-issues :issues issues)))
(defroute new-issue ("/issues/new" :decorators (@auth)) ()
(render/new-issue))
(defroute handle-create-issue
("/issues" :method :post :decorators (@auth @txn))
(&post subject body)
(if (string= subject "")
(render/new-issue "Subject is required")
(progn
(model:create-issue :subject subject
:body body
:author-dn (dn *user*))
(hunchentoot:redirect "/"))))
(defroute show-issue
("/issues/:id" :decorators (@auth-optional @handle-issue-not-found))
(&path (id 'integer))
(handler-case
(let* ((issue (model:get-issue id))
(*title* (format nil "~A | Panettone"
(subject issue))))
(render/issue issue))
(issue-not-found (_)
(declare (ignore _))
(render/not-found "Issue"))))
(defroute handle-create-comment
("/issues/:id/comments"
:decorators (@auth @handle-issue-not-found @txn)
:method :post)
(&path (id 'integer) &post body)
(flet ((redirect-to-issue ()
(hunchentoot:redirect (format nil "/issues/~A" id))))
(cond
((string= body "")
(redirect-to-issue))
(:else
(model:create-issue-comment
:issue-id id
:body body
:author-dn (dn *user*))
(redirect-to-issue)))))
(defroute close-issue
("/issues/:id/close" :decorators (@auth @handle-issue-not-found @txn)
:method :post)
(&path (id 'integer))
(model:set-issue-status id :closed)
(hunchentoot:redirect (format nil "/issues/~A" id)))
(defroute open-issue
("/issues/:id/open" :decorators (@auth)
:method :put)
(&path (id 'integer))
(model:set-issue-status id :open)
(hunchentoot:redirect (format nil "/issues/~A" id)))
(defroute styles ("/main.css") ()
(setf (hunchentoot:content-type*) "text/css")
(apply #'lass:compile-and-write panettone.css:styles))
(defvar *acceptor* nil
"Hunchentoot acceptor for Panettone's web server.")
(defun migrate-db ()
"Migrate the database to the latest version of the schema"
(model:ddl/init))
(defun start-panettone (&key port
(ldap-host "localhost")
(ldap-port 389)
postgres-params)
(connect-ldap :host ldap-host
:port ldap-port)
(apply #'model:connect-postgres postgres-params)
(migrate-db)
(setq *acceptor*
(make-instance 'easy-routes:routes-acceptor :port port))
(hunchentoot:start *acceptor*))
(defun main ()
(let ((port (integer-env "PANETTONE_PORT" :default 6161))
(ldap-port (integer-env "LDAP_PORT" :default 389)))
(setq hunchentoot:*show-lisp-backtraces-p* nil)
(setq hunchentoot:*log-lisp-backtraces-p* nil)
(start-panettone :port port
:ldap-port ldap-port)
(sb-thread:join-thread
(find-if (lambda (th)
(string= (sb-thread:thread-name th)
(format nil "hunchentoot-listener-*:~A" port)))
(sb-thread:list-all-threads)))))
(comment
(setq hunchentoot:*catch-errors-p* nil)
(start-panettone :port 6161
:ldap-port 3899)
)
