summaryrefslogtreecommitdiff
path: root/src/site.clj
diff options
context:
space:
mode:
Diffstat (limited to 'src/site.clj')
-rw-r--r--src/site.clj256
1 files changed, 191 insertions, 65 deletions
diff --git a/src/site.clj b/src/site.clj
index 63e2c2a..1c43ae3 100644
--- a/src/site.clj
+++ b/src/site.clj
@@ -2,9 +2,12 @@
(ns pichat
(:import java.lang.System
+ java.text.SimpleDateFormat
+ java.util.Date
clojure.lang.PersistentQueue
org.apache.commons.codec.digest.DigestUtils
- javax.servlet.http.Cookie)
+ javax.servlet.http.Cookie
+ org.antlr.stringtemplate.StringTemplateGroup)
(:use compojure
clojure.contrib.json.write
clojure.contrib.sql))
@@ -18,8 +21,11 @@
:user "postgres"
:password "root"}))
+(def template-group (new StringTemplateGroup "dumpfm" "template"))
+(.setRefreshInterval template-group 3)
+
(defstruct user-struct :user-id :nick :last-seen)
-(defstruct message-struct :nick :content :timestamp)
+(defstruct message-struct :nick :avatar :content :created_on)
(def users (ref {}))
(def messages (ref []))
@@ -28,9 +34,6 @@
(def flusher-sleep-ms 4000)
(def user-timeout-ms 5000)
-(defn swap [f]
- (fn [& more] (apply f (reverse more))))
-
(def flusher (agent nil))
(defn flush! [x]
@@ -44,40 +47,42 @@
(. Thread (sleep flusher-sleep-ms))
x)
+;; Utils
+
+(defn encode-html-entities [s]
+ (loop [ret s
+ [[char replacement] & rest] [["&" "&"]
+ ["'" "'"]
+ ["\"" """]
+ ["<" "&lt;"]
+ [">" "&gt;"]]]
+ (if (nil? char)
+ ret
+ (recur (.replaceAll ret char replacement)
+ rest))))
+
+(defn swap [f]
+ (fn [& more] (apply f (reverse more))))
+
+(def formatter (new SimpleDateFormat "h:mm EEE M/d"))
+
+;;;;;
+
(defn resp-error [message]
{:status 400 :headers {} :body message})
(defn resp-success [message]
{:status 200 :headers {} :body (json-str message)})
-(defn new-messages
- ([since] (reverse (take-while (fn [m] (> (m :timestamp) since)) @messages)))
- ([] (reverse (take 25 @messages))))
-
-(def random (java.util.Random.))
-(def max-user-int 1000000)
-(defn make-random-nick []
- (let [nick (str "user-" (.nextInt random max-user-int))]
- (if (contains? @users nick)
- (make-random-nick)
- nick)))
-
-(defn updates
- ([] {"users" (sort (keys @users)) "messages" (new-messages)})
- ([since] {"users" (sort (keys @users)) "messages" (new-messages since)}))
+;; Database
(defn do-select [query]
(with-connection db
(with-query-results rs query
(doall rs))))
-(defn fetch-messages [room_id]
- (let [query (str "SELECT m.content, m.created_on, u.nick FROM messages m, users u "
- "WHERE room_id = ? AND m.user_id = u.user_id")
- res (do-select [query room_id])]
- (map (fn [r] (struct message-struct (r :nick) (r :content) (.getTime (r :created_on))))
- res)))
+;; User authentication
(defn fetch-nick [nick]
(let [query "SELECT * FROM users WHERE nick = ?"]
@@ -86,8 +91,89 @@
(defn authorize-nick-hash [nick hash]
(let [db-user (fetch-nick nick)]
(if (and db-user (= (db-user :hash) hash))
- (db-user :user_id)
- false)))
+ db-user false)))
+
+;; Message handling
+
+(defn process-message-for-json [d]
+ (assoc d :created_on (.getTime (d :created_on))))
+
+(defn process-message-for-output [d]
+ (let [avatar (d :avatar)]
+ {"nick" (encode-html-entities (d :nick))
+ "avatar" (if avatar (encode-html-entities avatar) nil)
+ "created_on" (.format formatter (d :created_on))
+ "content" (encode-html-entities (d :content))}))
+
+(defn new-messages
+ ([since-ts]
+ (let [since-date (new Date (long since-ts))]
+ (reverse (take-while (fn [m] (.after (m :created_on) since-date)) @messages))))
+ ([] (reverse (take 25 @messages))))
+
+(defn updates
+ ([] {"users" (sort (keys @users))
+ "messages" (map process-message-for-json (new-messages))})
+ ([since] {"users" (sort (keys @users))
+ "messages" (map process-message-for-json (new-messages since))}))
+
+(defn fetch-messages-by-room [room-id]
+ (let [query (str "SELECT m.content, m.created_on, u.nick, u.avatar "
+ "FROM messages m, users u "
+ "WHERE room_id = ? AND m.user_id = u.user_id "
+ "ORDER BY created_on DESC "
+ "LIMIT 20")]
+ (do-select [query room-id])))
+
+(defn fetch-messages-by-nick [nick]
+ (let [query (str "SELECT m.content, m.created_on, u.nick, u.avatar "
+ "FROM messages m, users u "
+ "WHERE m.user_id = u.user_id AND u.nick = ? "
+ "ORDER BY created_on DESC "
+ "LIMIT 20")]
+ (do-select [query nick])))
+
+;; Templates
+
+(defn set-user-attributes [st session]
+ (if (session :nick)
+ (.setAttribute st "user_nick" (session :nick))))
+
+(defn fetch-template [template-name session]
+ (let [st (.getInstanceOf template-group template-name)]
+ (and st
+ (do
+ (set-user-attributes st session)
+ st))))
+
+;; Landing
+
+(defn landing [session]
+ (let [nick (session :nick)]
+ (if nick
+ (redirect-to (str "/u/" nick))
+ (serve-file "static" "index.html"))))
+
+(defn login [session params]
+ (let [nick (params :nick)
+ hash (params :hash)
+ db-user (authorize-nick-hash nick hash)]
+ (if db-user
+ (dosync
+ (let [user-struct (struct user-struct (db-user :user_id) ; DB naming
+ nick (System/currentTimeMillis))]
+ (alter users assoc nick user-struct)
+ [(session-assoc :user-id (db-user :user_id)
+ :nick nick
+ :avatar (db-user :avatar))
+ (resp-success "OK")]))
+ (resp-error "BAD_LOGIN"))))
+
+(defn logout [session]
+ [(session-dissoc :nick :user-id)
+ (redirect-to "/")])
+
+;; Registration
(defn register [session params]
(let [nick (params :nick)
@@ -101,45 +187,80 @@
[nick hash email])
(resp-success "OK")))))
-(defn init [session]
+;; Profile
+
+(defn non-empty-string? [s]
+ (and s (> (count s) 0)))
+
+(defn profile [session profile-nick]
+ (let [user-info (fetch-nick profile-nick)]
+ (if user-info
+ (let [nick (session :nick)
+ is-home (and nick (= nick profile-nick))
+ has-avatar (non-empty-string? (user-info :avatar))
+ dumps (fetch-messages-by-nick profile-nick)
+ st (fetch-template "profile" session)]
+ (do
+ (.setAttribute st "is_home" is-home)
+ (doseq [a [:nick :avatar :contact :bio]]
+ (.setAttribute st (name a) (encode-html-entities (or (user-info a) nil))))
+ (.setAttribute st "dumps"
+ (to-array (map process-message-for-output dumps)))
+ (.toString st)))
+ (resp-error "NO_USER"))))
+
+(defn update-profile [session params]
+ (let [user-id (session :user-id)
+ attr (params :attr)
+ val (params :val)
+ attr-set #{"avatar" "contact" "bio"}]
+ (if (and user-id attr val
+ (contains? attr-set attr))
+ (do
+ (with-connection db
+ (update-values "users" ["user_id = ?" user-id] {attr val}))
+ (if (= attr "avatar")
+ [(session-assoc :avatar val) "OK"]
+ "OK"))
+ (resp-error "BAD_REQUEST"))))
+
+;; Chat
+
+(defn chat [session]
(let [now (System/currentTimeMillis)
+ nick (session :nick)
user-id (session :user-id)
- nick (session :nick)
- resp (updates)]
- (dosync
- (if (and user-id nick)
- (let [user-struct (struct user-struct user-id nick now)]
- (alter users assoc nick user-struct)
- (resp-success (merge resp {"nick" nick})))
- [(session-assoc :last-seen now)
- (resp-success resp)]))))
-
-(defn login [session params]
- (let [old-nick (session :nick)
- nick (params :nick)
- hash (params :hash)
- user-id (authorize-nick-hash nick hash)]
- (if user-id
+ st (fetch-template "chat" session)
+ message-list (to-array
+ (map process-message-for-output
+ (reverse (fetch-messages-by-room 1))))]
+ (if nick
(dosync
- (set-session {:user-id user-id :nick nick})
- (let [user-struct (struct user-struct user-id nick (System/currentTimeMillis))]
- (alter users dissoc old-nick)
- (alter users assoc nick user-struct)
- [(session-assoc :user-id user-id :nick nick)
- (resp-success "OK")]))
- (resp-error "BAD_LOGIN"))))
+ (let [user-struct (struct user-struct user-id nick now)]
+ (alter users assoc nick user-struct))))
+ (.setAttribute st "users" (map encode-html-entities
+ (sort (keys @users))))
+ (.setAttribute st "messages" message-list)
+ (.setAttribute st "json_user_nick" (if nick (json-str nick) "null"))
+ (if nick
+ (.toString st)
+ [(session-assoc :last-seen now)
+ (.toString st)])))
(defn refresh [session]
(let [nick (session :nick)
now (System/currentTimeMillis)]
- (dosync
- (if (contains? (ensure users) nick)
- (let [last-seen (get-in @users [nick :last-seen])]
- (alter users assoc-in [nick :last-seen] now)
- (resp-success (updates last-seen)))
- (let [last-seen (max (or (session :last-seen) 0) (- now (* 60 20)))]
- [(session-assoc :last-seen now)
- (updates last-seen)])))))
+ (if (or nick (session :last-seen))
+ (dosync
+ (if (contains? (ensure users) nick)
+ (let [last-seen (get-in @users [nick :last-seen])]
+ (alter users assoc-in [nick :last-seen] now)
+ (resp-success (updates last-seen)))
+ (let [last-seen (session :last-seen)]
+ [(session-assoc :last-seen now)
+ (updates last-seen)])))
+ ; TODO: session should store room-id of anon. users
+ (resp-error "NOT_IN_CHAT"))))
(defn msg-transaction [nick msg]
(dosync
@@ -157,8 +278,10 @@
(defn msg [session params]
(let [user-id (session :user-id)
nick (session :nick)
+ avatar (session :avatar)
content (params :content)
- msg (struct message-struct nick content (System/currentTimeMillis))]
+ now (new Date)
+ msg (struct message-struct nick avatar content now)]
(if (msg-transaction nick msg)
(do
(msg-db user-id 1 msg)
@@ -166,14 +289,17 @@
(resp-error "MUST_LOGIN"))))
(defroutes pichat
- (GET "/" (serve-file "static" "index.html"))
+ (GET "/" (landing session))
(GET "/static/*" (or (serve-file "static" (params :*))
:next))
(GET "/favicon.ico" (serve-file "static" "favicon.ico"))
+ (GET "/u/:nick" (profile session (-> request :route-params :nick)))
+ (GET "/update-profile" (update-profile session params))
+ (GET "/login" (login session params))
+ (GET "/logout" (logout session))
(GET "/register" (serve-file "static" "register.html"))
(GET "/submit-registration" (register session params))
- (GET "/login" (login session params))
- (GET "/init" (init session))
+ (GET "/chat" (chat session))
(GET "/refresh" (refresh session))
(GET "/msg" (msg session params))
(ANY "*" [404 "Page not found"]))
@@ -185,7 +311,7 @@
; Load messages from database
(dosync
- (ref-set messages (fetch-messages 1)))
+ (ref-set messages (fetch-messages-by-room 1)))
(run-server {:port 8080}
"/*" (servlet pichat))
generated by cgit v1.2.3-70-g09d2 (git 2.51.0) at 2025-12-11 15:29:32 +0000