Add Lafargue subsite (lazy chat functionality).

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"]))