Add Lafargue subsite (lazy chat functionality).

8 files changed, 236 insertions, 4 deletions

diff --git a/project.clj b/project.clj
index 1384d4e..a8bbe7f 100644
--- a/project.clj
+++ b/project.clj
@@ -40,6 +40,7 @@
                  [org.jsoup/jsoup "1.6.1"]
                  [org.apache.abdera/abdera-parser "1.1.1"]
                  [clj-apache-http "2.3.2"]
+                 [org.pegdown/pegdown "1.1.0"]
                  ]
   :plugins [[lein-swank "1.4.3"]]
   :exclusions [org.clojure/clojure-contrib]  ;you know, the old pre-1.3.0 versions
@@ -62,6 +63,9 @@
                  ;;},
                  "oracle"
                  {:url "http://download.oracle.com/maven/"
+                  :snapshots false}
+                 "scala-releases"  ;pegdown
+                 {:url "http://scala-tools.org/repo-releases"
                   :snapshots false}}
   :source-path "src"
   ;;:jvm-opts ["-Xms32m"]
diff --git a/schema.sql b/schema.sql
index 49e1e63..c12f73e 100644
--- a/schema.sql
+++ b/schema.sql
@@ -85,5 +85,35 @@ CREATE TABLE bookmark_tags(
   FOREIGN KEY(bookmark) REFERENCES bookmarks
 );
 
+
+CREATE TABLE lazychat_messages(
+  id          SERIAL    NOT NULL,
+  author      INTEGER,
+  date        TIMESTAMP WITH TIME ZONE DEFAULT now(),
+  content     VARCHAR,
+  visibility  VARCHAR NOT NULL,
+  format      VARCHAR NOT NULL,
+  PRIMARY KEY(id),
+  FOREIGN KEY(author) REFERENCES users,
+  CHECK (format     IN ('markdown')),
+  CHECK (visibility IN ('personal', 'protected', 'public'))
+);
+
+CREATE TABLE lazychat_targets(
+  message INTEGER NOT NULL,
+  target  INTEGER NOT NULL,
+  PRIMARY KEY(message, target),
+  FOREIGN KEY(message) REFERENCES lazychat_messages,
+  FOREIGN KEY(target)  REFERENCES users
+);
+
+CREATE TABLE lazychat_references(
+  referrer INTEGER NOT NULL,
+  referee  INTEGER NOT NULL,
+  PRIMARY KEY(referrer, referee),
+  FOREIGN KEY(referrer) REFERENCES lazychat_messages,
+  FOREIGN KEY(referee)  REFERENCES lazychat_messages
+);
+
 ROLLBACK;
 --COMMIT;
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"]))
diff --git a/static/style/hammer-and-sickle.css b/static/style/hammer-and-sickle.css
index 40db121..d6b7ae6 100644
--- a/static/style/hammer-and-sickle.css
+++ b/static/style/hammer-and-sickle.css
@@ -39,7 +39,7 @@ a:active {
 	border-bottom: 0px solid none;
 }
 
-ul.bookmarx-list {
+ul.bookmarx-list, ul.lafargue-list {
         list-style-type: none;
 }
 
@@ -71,7 +71,7 @@ h2 {
 	border: solid #bbccff;
 }
 
-.bookmark, #content {
+.bookmark, .lafargue-message, #content {
 	/* border-right: 1px solid silver; */
 	color: inherit;
 	background-color: #ffbfbf;
diff --git a/static/style/lafargue.css b/static/style/lafargue.css
new file mode 100644
index 0000000..31b6a30
--- /dev/null
+++ b/static/style/lafargue.css
@@ -0,0 +1,32 @@
+.lafargue-message-date-and-owner {
+    font-style: oblique;
+    color: #555;
+    /* text-indent: 1.5em; */
+    /* margin-left: 1.5em; */
+}
+
+.lafargue-message-body {
+    margin-left: 1.5em;
+    margin-bottom: 1em;
+}
+
+#lafargue-message-footer {
+    text-align: right;
+    position: relative;
+    padding: 0.5em 0.5em 0.5em 0.5em;
+    right: 0;
+    margin: 1em;
+    font-style: oblique;
+}
+
+#lafargue-message-footer-text {
+    padding: 0.5em 1em 0.5em 1em;
+    border: solid 1px #000;
+    background-color: orange;
+}
+
+#lafargue-main-input-box {
+    margin-left:auto;
+    margin-right:auto;
+    text-align:center;
+}