Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
495 lines (464 sloc) 20.7 KB
(ns net.thegeez.wiki.wiki
(:require
[bidi.bidi :as bidi]
[clojure.tools.logging :refer :all]
[clojure.string :as str]
[selmer.parser :as selmer]
[schema.core :as s]
[yada.yada :as yada]
[net.thegeez.wiki.diff :as diff]
[markdown.core :as md]
[markdown.transformers :as mdt]
[datomic.client :as client]
[clojure.core.async :as async]
[manifold.deferred :as d]
[manifold.stream :as stream]
[aleph.http :as http]
[byte-streams :as bs]))
(defn slug->title [slug]
(str/replace slug "_" " "))
(defn next-rev-str [slug]
(str slug "_" (.getTime (java.util.Date.)) "_" (java.util.UUID/randomUUID)))
(defn with-article-links [ctx attr-map]
(assoc attr-map
:article/title (slug->title (:article/slug attr-map))
:wiki/links
{:article/show (yada/url-for ctx ::article
{:route-params
{:slug (:article/slug attr-map)}})
:article/edit (yada/url-for ctx ::article-edit
{:route-params
{:slug (:article/slug attr-map)}})
:article/history (yada/url-for ctx ::article-history
{:route-params
{:slug (:article/slug attr-map)}})}))
(defn async->manifold [c]
;; core async into manifold
(let [d (d/deferred)]
(async/take! c
(fn [item]
(d/success! d item)))
d))
(defn async-log-remove-error [c]
(async/pipe c
(async/chan 1
(halt-when
(fn [i]
(when (client/error? i)
(info "Error in datomic result: " i)
true))))))
(defn md-escape-html [text state]
;; https://github.com/yogthos/markdown-clj/issues/36
[(clojure.string/escape text
{\& "&"
\< "&lt;"
\> "&gt;"
\" "&quot;"
\' "&#39;"})
state])
(defn md->html [md-str]
(md/md-to-html-string md-str
:replacement-transformers
(cons md-escape-html mdt/transformer-vector)))
(defn get-articles [ctx]
(d/chain
(let [conn (:conn ctx)
db (client/db conn)]
(-> (client/q conn {:query
'{:find [(pull ?e [:*])]
:where [[?e :article/slug]]}
:limit -1
:args [db]})
async-log-remove-error
(async/pipe (async/chan 1 (comp
cat ;; q results are "paged"/chuncked
(map first) ;; unwrap datomic result tuples from [{..pull map..}]
)))
(->> (async/into []))
async->manifold))
(fn [articles]
(map
(partial with-article-links ctx)
articles))))
(defn get-article-by-slug [ctx slug]
(d/chain
(let [conn (:conn ctx)
db (client/db conn)]
(-> (client/q conn {:query
'{:find [(pull ?e [:*])]
:in [$ ?slug]
:where [[?e :article/slug ?slug]]}
:args [db slug]})
async-log-remove-error
(async/pipe (async/chan 1 (comp
cat ;; q results are "paged"/chuncked
(map first) ;; unwrap datomic result tuples from [{..pull map..} rev]
)))
async->manifold))
(fn [article]
(when article
(with-article-links ctx article)))))
(defn get-article-history [ctx slug]
(d/chain
(let [conn (:conn ctx)
db (client/db conn)
db-hist (client/history db)]
(-> (client/q conn
{:query
'{:find [?tx
?rev
?tx-instant
?tx-doc]
:in [$ $hist ?slug]
:where [[$ ?e :article/slug ?slug]
[$hist ?e :article/rev ?rev ?tx true]
[$ ?tx :db/txInstant ?tx-instant]
[$ ?tx :db/doc ?tx-doc]]}
:limit -1
:args [db db-hist slug]})
async-log-remove-error
(async/pipe (async/chan 1
(comp
cat ;; q results are "paged"/chuncked
(map (fn [[tx rev tx-instant tx-doc txep]]
{:tx tx
:rev rev
:tx-instant tx-instant
:comment tx-doc
:link (yada/url-for ctx
::article-rev
{:route-params
{:slug slug
:rev rev}})})))))
(->> (async/into []))
async->manifold))
(fn [history]
(when (seq history)
(sort-by :tx > history)))))
(defn get-article-revision [ctx rev]
(let [conn (:conn ctx)
db (client/db conn)
db-hist (client/history db)]
(-> (client/q conn {:query
'{:find [?rev ?comment]
:in [$hist ?rev]
:where [[$hist ?e :article/rev ?rev ?tx-rev true]
[$hist ?tx-rev :db/doc ?comment ?tx-rev true]]}
:args [db-hist rev]})
async-log-remove-error
(async/pipe (async/chan 1 (map
(comp
(fn [[rev comment]]
{:rev rev
:comment comment})
first))))
async->manifold)))
(defn get-article-revision-relative [ctx rev query]
(let [conn (:conn ctx)
db (client/db conn)
db-hist (client/history db)]
(-> (client/q conn {:query query
:args [db-hist rev]})
async-log-remove-error
(async/pipe (async/chan 1 (comp
(map first)
(halt-when nil?)
(map
(fn [[tx-rel rev-rel doc-rel :as res]]
(when res
{:tx tx-rel
:rev rev-rel
:comment doc-rel}))))))
async->manifold)))
(defn get-article-revision-before [ctx rev]
(get-article-revision-relative
ctx rev
'{:find [?tx-rel ?rev-rel ?doc-rel]
:in [$hist ?rev]
:where [[$hist ?e :article/rev ?rev ?tx-rev true]
[$hist ?e :article/rev ?rev-rel ?tx-rev false]
[$hist ?e :article/rev ?rev-rel ?tx-rel true]
[(< ?tx-rel ?tx-rev)]
[$hist ?tx-rel :db/doc ?doc-rel ?tx-rel true]]}))
(defn get-article-revision-after [ctx rev]
(get-article-revision-relative
ctx rev
'{:find [?tx-rel ?rev-rel ?doc-rel]
:in [$hist ?rev]
:where [[$hist ?e :article/rev ?rev ?tx-rev true]
[$hist ?e :article/rev ?rev ?tx-rel false]
[$hist ?e :article/rev ?rev-rel ?tx-rel true]
[(< ?tx-rev ?tx-rel)]
[$hist ?tx-rel :db/doc ?doc-rel ?tx-rel true]]}
))
(defn update-article [ctx slug comment base-rev next-rev]
(let [conn (:conn ctx)
db (client/db conn)]
(-> (client/transact conn
{:tx-data [[:db.fn/cas [:article/slug slug] :article/rev base-rev next-rev]
[:db/add "datomic.tx" :db/doc comment]]})
async-log-remove-error
async->manifold
)))
(defn create-article [ctx slug title comment next-rev]
(let [conn (:conn ctx)
db (client/db conn)]
(-> (client/transact conn
{:tx-data [{:db/id "tempid"
:article/slug slug
:article/title title
:article/rev next-rev}
[:db/add "datomic.tx" :db/doc comment]]})
async-log-remove-error
async->manifold
)))
(defn upload-revision [ctx rev text]
(let [upload-blob-uri (java.net.URI. (str (:fs2-host ctx) "/upload/" rev))]
(-> (http/post (str upload-blob-uri)
{:headers {"Content-Type" "application/octet-stream"}
:body text})
(d/catch (fn [x]
(info "Upload error" x)
x)))))
(defn body-for-article [ctx article]
(-> (d/chain (let [url (str (:fs2-host ctx) "/" (:article/rev article))]
(http/get url
{:headers {"Accept" "*/*"}}))
(fn [resp]
(when (= (:status resp) 200)
(let [body (-> resp
:body
bs/to-string)]
(assoc article :article/body body)))))
(d/catch (fn [err]
article))))
(defn redirect [ctx url]
(assoc (:response ctx)
:status 303
:headers {"location" url}))
(def index
(yada/resource
{:id ::wiki-index
:properties (fn [ctx]
(d/chain (get-articles ctx)
(fn [articles]
{:exists? true
::articles articles})))
:methods
{:get
{:produces
{:media-type "text/html"}
:response
(fn [ctx]
(let [articles (-> ctx :properties ::articles)]
(selmer/render-file
"wiki/index.html"
{:index (yada/url-for ctx ::wiki-index)
:articles articles})))}}}))
(def article
(yada/resource
{:id ::article
:produces "text/html"
:parameters {:path {:slug String}}
:properties (fn [ctx]
(let [slug (get-in ctx [:parameters :path :slug])]
(d/chain (get-article-by-slug ctx slug)
(fn [article]
(when article
(body-for-article ctx article)))
(fn [article]
{:exists? true
::slug slug
::article article}))))
:methods
{:get {:response
(fn [ctx]
(if-let [article (get-in ctx [:properties ::article])]
(selmer/render-file
"wiki/show.html"
{:index (yada/url-for ctx ::wiki-index)
:title (:article/title article)
:article (assoc article :article/md-body
(md->html (:article/body article)))})
;; article not found
(redirect ctx (yada/url-for ctx ::article-edit
{:route-params
{:slug (get-in ctx [:properties ::slug])}}))))}
:post {:parameters {:form {:text String
:comment String
(s/optional-key :rev) String}}
:consumes #{"application/x-www-form-urlencoded"}
:response (fn [ctx]
(let [slug (get-in ctx [:parameters :path :slug])
comment (get-in ctx [:parameters :form :comment] "")
next-text (-> (get-in ctx [:parameters :form :text] "")
(str/replace "\r\n" "\n"))
base-rev (get-in ctx [:parameters :form :rev])]
(if (not (and slug next-text))
(throw (ex-info "" {:status 400
:error (str next-text)}))
(let [next-rev (next-rev-str slug)]
(d/let-flow [upload (upload-revision ctx next-rev next-text)
success? (if-not base-rev
(let [title (slug->title slug)]
(create-article ctx slug title comment next-rev))
(update-article ctx slug comment base-rev next-rev))]
(if success?
(redirect ctx
(java.net.URI. ;; redirect
(yada/url-for ctx ::article-rev
{:route-params {:slug slug
:rev next-rev}})))
;; resolve conflict screen
(d/let-flow [article (d/chain (get-article-by-slug ctx slug)
(fn [article]
(body-for-article ctx article)))]
(selmer/render-file
"wiki/conflict.html"
{:index (yada/url-for ctx ::wiki-index)
:title (:article/title article)
:article article
:comment comment
:next-text next-text
:diff-trs (let [diffs (diff/diffs (:article/body article)
next-text)]
(-> diffs
diff/diff-blocks
diff/diff-trs-str))})))))))
)}}
:responses {400 {:produces #{"text/html"}
:response (fn [ctx]
(str "Something is wrong, here is the text you submitted: \n" (:error (ex-data (:error ctx)))))}
}}))
(def edit
(yada/resource
{:id ::article-edit
:parameters {:path {:slug String}}
:produces "text/html"
:properties (fn [ctx]
(let [slug (get-in ctx [:parameters :path :slug])]
(d/chain (get-article-by-slug ctx slug)
(fn [article]
(when article
(body-for-article ctx article)))
(fn [article]
{:exists? true
::slug slug
::article article}))))
:methods
{:get {:response
(fn [ctx]
(let [article (::article (:properties ctx))]
(if article
;; edit existing
(selmer/render-file
"wiki/edit.html"
{:index (yada/url-for ctx ::wiki-index)
:title (:article/title article)
:article article})
;; creating new article
(let [slug (get-in ctx [:properties ::slug])
title (slug->title slug)]
(selmer/render-file
"wiki/create.html"
{:index (yada/url-for ctx ::wiki-index)
:title title
:action (yada/url-for ctx ::article
{:route-params
{:slug slug}})}))
)))}}}))
(def history
(yada/resource
{:id ::article-history
:parameters {:path {:slug String}}
:properties (fn [ctx]
(let [slug (get-in ctx [:parameters :path :slug])]
(d/let-flow [article (get-article-by-slug ctx slug)
history (get-article-history ctx slug)]
(if (and article history)
{:exists? true
::article article
::history history}
{:exists? false}))))
:methods
{:get {:produces "text/html"
:response (fn [ctx]
(let [article (::article (:properties ctx))
history (::history (:properties ctx))]
(selmer/render-file
"wiki/history.html"
{:index (yada/url-for ctx ::wiki-index)
:title (str (:article/title article) " history")
:article article
:history history})))}}}))
(def revision
(yada/resource
{:id ::article-rev
:parameters {:path {:slug String
:rev String}}
:produces #{"text/html" "diff/patch"}
:properties (fn [ctx]
(let [slug (get-in ctx [:parameters :path :slug])
revision (get-in ctx [:parameters :path :rev])]
(d/let-flow [article (get-article-by-slug ctx slug)
rev (get-article-revision ctx revision)
prev (get-article-revision-before ctx revision)
nrev (get-article-revision-after ctx revision)
rev-body (body-for-article ctx {:article/rev (:rev rev)})
prev-body (when prev
(body-for-article ctx {:article/rev (:rev prev)}))]
(if (and article
(:rev rev))
(cond->
{:exists? true
::slug slug
::article article
::rev-body rev-body
::comment (:comment rev)}
(:rev prev)
(assoc ::prev
(yada/url-for ctx ::article-rev
{:route-params
{:slug slug
:rev (:rev prev)}}))
(:rev nrev)
(assoc ::nrev
(yada/url-for ctx ::article-rev
{:route-params
{:slug slug
:rev (:rev nrev)}}))
prev-body
(assoc ::diff (diff/diffs (:article/body prev-body)
(:article/body rev-body)))
(= (get-in ctx [:request :headers "accept"]) "diff/patch")
(assoc ::patch (diff/patch (:article/body prev-body)
(:article/body rev-body))))
{:exists? false}))))
:methods
{:get {:response
(fn [ctx]
(let [slug (::slug (:properties ctx))
article (::article (:properties ctx))]
(if-let [patch (-> ctx :properties ::patch)]
patch
(selmer/render-file
"wiki/revision.html"
{:index (yada/url-for ctx ::wiki-index)
:article (assoc article :article/md-body
(md->html (:article/body article)))
:nav (let [props (:properties ctx)]
{:prev (::prev props)
:nrev (::nrev props)})
:rev-body (md->html (-> ctx :properties ::rev-body :article/body))
:comment (-> ctx :properties ::comment)
:diff-trs (when-let [diffs (-> ctx :properties ::diff)]
(-> diffs
diff/diff-blocks
diff/diff-trs-str))}))))}}}))
(defn wiki-routes []
["/wiki"
[["" index]
[["/" :slug] article]
[["/" :slug "/edit"] edit]
[["/" :slug "/history"] history]
[["/" :slug "/rev/" :rev] revision]]])