summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2012-04-09 15:05:27 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2012-04-09 15:05:27 +0200
commite3aee2b049c46599b3e8f7552bd33ea162e485ab (patch)
tree043a97f2452cecef526baf6fdede68b94cdfae3b /src
parenteec1fa16980cfc91b9fe69e4840f9cfb2f535167 (diff)
Add Lafargue subsite (lazy chat functionality).
Diffstat (limited to 'src')
-rw-r--r--src/mulk/benki/lazychat.clj145
-rw-r--r--src/mulk/benki/main.clj2
-rw-r--r--src/mulk/benki/util.clj17
-rw-r--r--src/mulk/benki/webutil.clj6
4 files changed, 168 insertions, 2 deletions
diff --git a/src/mulk/benki/lazychat.clj b/src/mulk/benki/lazychat.clj
new file mode 100644
index 0000000..7546f45
--- /dev/null
+++ b/src/mulk/benki/lazychat.clj
@@ -0,0 +1,145 @@
+(ns mulk.benki.lazychat
+ (:refer-clojure)
+ (:use [clojure repl]
+ [hiccup core page-helpers]
+ [noir core]
+ [mulk.benki auth config db util webutil]
+ ;;
+ [clojure.core.match :only [match]]
+ [hiccup.core :only [escape-html]]
+ [ring.util.codec :only [url-encode]])
+ (:require [clojure.algo.monads :as m]
+ [clojure.java.jdbc :as sql]
+ [clojure.string :as string]
+ [noir.request :as request]
+ [noir.response :as response]
+ [noir.session :as session]
+ hiccup.core)
+ (:import [org.apache.abdera Abdera]))
+
+
+(defn create-lazychat-message! [{content :content, visibility :visibility
+ format :format, targets :targets,
+ referees :referees, id :id}]
+ {:pre [*user*]}
+ (with-dbt
+ (when id
+ ;; FIXME: Is this assertion sufficient? Is it too strict?
+ (assert (query1 "SELECT 't' WHERE currval('lazychat_messages_id_seq') >= ?" id)))
+ (let [id (or id
+ (:id (query1 "SELECT nextval('lazychat_messages_id_seq')::INTEGER AS id")))]
+ (sql/with-query-results ids
+ ["INSERT INTO lazychat_messages(id, author, content, format, visibility)
+ VALUES (?, ?, ?, ?, ?)
+ RETURNING id"
+ id *user* content format visibility]
+ (doseq [referee referees]
+ (sql/insert-values :lazychat_references
+ [:referrer :referee]
+ [id (int referee)]))
+ (doseq [target targets]
+ (sql/insert-values :lazychat_targets
+ [:message :target]
+ [id (int target)]))))))
+
+(defn select-message [id]
+ (let [message (query1 "SELECT author, content, format, visibility, date
+ FROM lazychat_messages
+ WHERE id = ?"
+ id)
+ referees (map :referee (query "SELECT referee FROM lazychat_references WHERE referrer = ?" id))
+ targets (map :target (query "SELECT target FROM lazychat_targets WHERE message = ?" id))]
+ (and message
+ (assoc message
+ :referees referees
+ :targets targets))))
+
+(defn may-read? [user message]
+ (or (= (:visibility message) "public")
+ (and user (= (:visibility message) "protected"))
+ (and user
+ (= (:visibility message) "personal")
+ (contains? (:targets message) user))))
+
+(defn may-post? [user]
+ user)
+
+
+(def lafargue-list-page
+ {:head (list
+ [:link {:rel "stylesheet"
+ :href (resolve-uri "/style/hammer-and-sickle.css")
+ :type "text/css"}]
+ [:link {:rel "stylesheet"
+ :href (resolve-uri "/style/lafargue.css")
+ :type "text/css"}])})
+
+(defpage "/lafargue" {}
+ (with-dbt
+ (layout lafargue-list-page "Lafargue Lazy Chat"
+ [:div {:id "login-message"
+ :class "login-message"}
+ (login-message)]
+ [:div
+ [:div {:id "lafargue-main-input-box" :class "lafargue-input-box"}
+ [:form {:method "POST" :action (link :lafargue :post)}
+ [:div [:textarea {:name "content", :rows 3, :cols 100}]]
+ [:div [:input {:type "hidden", :name "format", :value "markdown"}]]
+ [:div
+ [:input {:type "radio", :name "visibility", :value "protected" :checked "checked"} "Semi-private"]
+ [:input {:type "radio", :name "visibility", :value "public"} "Public"]]
+ [:div [:input {:type "submit"}]]]]
+ [:ul {:class "lafargue-list"}
+ (sql/with-query-results messages
+ ["SELECT m.id, m.author, m.date, m.content, m.format, u.first_name, u.last_name
+ FROM lazychat_messages m
+ JOIN users u ON (author = u.id)
+ WHERE (visibility = 'public'
+ OR (visibility = 'protected' AND (?::INTEGER) IS NOT NULL)
+ OR (visibility = 'personal'
+ AND EXISTS (SELECT *
+ FROM lazychat_targets t
+ WHERE t.target = (?::INTEGER)
+ AND message = m.id)))
+ ORDER BY m.date DESC"
+ *user* *user*]
+ (doall
+ (for [message messages]
+ [:li {:class "lafargue-message"}
+ [:h2 {:class "lafargue-message-title"}]
+ [:p {:class "lafargue-message-date-and-owner"}
+ [:span {:class "lafargue-message-date"}
+ (escape-html (format-date (:date message)))]
+ [:span {:class "lafargue-message-owner"}
+ " by " (escape-html (:first_name message))]]
+ [:div {:class "lafargue-message-body"}
+ (sanitize-html (markdown->html (:content message)))]])))]])))
+
+
+(defpage [:any "/lafargue/post"] {content :content, visibility :visibility
+ format :format, targets :targets,
+ referees :referees}
+ (with-auth
+ (create-lazychat-message! {:content content, :visibility visibility,
+ :format format, :targets targets,
+ :referees referees})
+ (redirect (referrer))))
+
+(defpage [:put "/lafargue/messages/:id"] {id :id}
+ (if (may-post? *user*)
+ (let [message (assoc (slurp (:body (request/ring-request))) :id id)]
+ (create-lazychat-message! message)
+ {:status 200})
+ {:status 403}))
+
+(defpage [:get "/lafargue/messages/:id"] {id :id}
+ (with-dbt
+ (let [message (select-message id)]
+ (if (may-read? *user* message)
+ (response/json message)
+ {:status 403}))))
+
+(defpage [:post "/lafargue/messages/genid"] {id :id}
+ (with-auth
+ (response/json
+ (with-dbt (query1 "SELECT NEXTVAL('lazychat_messages_id_seq')")))))
diff --git a/src/mulk/benki/main.clj b/src/mulk/benki/main.clj
index bdecdc1..a5e7b31 100644
--- a/src/mulk/benki/main.clj
+++ b/src/mulk/benki/main.clj
@@ -5,7 +5,7 @@
[hiccup core page-helpers]
[mulk.benki util config db])
(:require [noir server options]
- [mulk.benki wiki auth book_marx id]
+ [mulk.benki wiki auth book_marx id lazychat]
[ring.middleware.file]
[noir.session :as session]
[noir.request :as request]
diff --git a/src/mulk/benki/util.clj b/src/mulk/benki/util.clj
index 505c637..cb0ffde 100644
--- a/src/mulk/benki/util.clj
+++ b/src/mulk/benki/util.clj
@@ -9,7 +9,10 @@
[clojure.java.jdbc :as sql])
(:import [java.text DateFormat]
[java.security SecureRandom]
- [java.math BigInteger]))
+ [java.math BigInteger]
+ [org.jsoup Jsoup]
+ [org.jsoup.safety Cleaner Whitelist]
+ [org.pegdown PegDownProcessor]))
(def fmt clojure.pprint/cl-format)
@@ -54,10 +57,12 @@
(defn linkrel [& args]
(match [(vec args)]
[[:login]] (fmt nil "/login")
+ [[:home]] (fmt nil "/")
[[:marx]] (fmt nil "/marx")
[[:marx :submit]] (fmt nil "/marx/submit")
[[:marx :feed]] (fmt nil "/marx/feed")
[[:marx id]] (fmt nil "/marx/~a" id)
+ [[:lafargue :post]] (fmt nil "/lafargue/post")
[[:wiki title & xs]] (fmt nil "/wiki/~a~@[~a~]" title (first xs))
))
@@ -87,3 +92,13 @@
(defn genkey []
;;(.toString (BigInteger. 260 secure-random) 32)
(BigInteger. 260 secure-random))
+
+
+;;;; * User input
+(defonce pegdown (PegDownProcessor.))
+
+(defn markdown->html [markdown]
+ (.markdownToHtml pegdown markdown))
+
+(defn sanitize-html [html]
+ (Jsoup/clean html (Whitelist/basic)))
diff --git a/src/mulk/benki/webutil.clj b/src/mulk/benki/webutil.clj
index a1a0bb5..88516e6 100644
--- a/src/mulk/benki/webutil.clj
+++ b/src/mulk/benki/webutil.clj
@@ -13,6 +13,7 @@
+;;;; * Login/authentication
(defn authlink [uri]
(with-dbt
(let [user *user*
@@ -47,3 +48,8 @@
:alt "Sign in"}]]
[:div "or:"]
[:a {:href (link :login)} "Sign in normally"]])))
+
+
+;;;; * Environment/request stuff
+(defn referrer []
+ (get-in (request/ring-request) [:headers "referer"]))