path: root/src/site.clj

(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
           org.antlr.stringtemplate.StringTemplateGroup)
  (:use compojure
        clojure.contrib.json.write
        clojure.contrib.sql))

(let [db-host "localhost"
      db-port 5432
      db-name "dumpfm"]
  (def db {:classname "org.postgresql.Driver"
           :subprotocol "postgresql"
           :subname (str "//" db-host ":" db-port "/" db-name)
           :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 :created_on)

(def users (ref {}))
(def messages (ref []))

(def run-flusher true)
(def flusher-sleep-ms 4000)
(def user-timeout-ms 5000)

(def flusher (agent nil))

(defn flush! [x]
  (when run-flusher
    (send-off *agent* #'flush!))
  (dosync
   (let [now (System/currentTimeMillis)
         alive? (fn [[n u]] (> (u :last-seen) (- now user-timeout-ms)))]
     (ref-set users
              (into {} (filter alive? @users)))))
  (. 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)})


;; Database

(defn do-select [query]
  (with-connection db
    (with-query-results rs query
      (doall rs))))

;; User authentication

(defn fetch-nick [nick]
  (let [query "SELECT * FROM users WHERE nick = ?"]
    (first (do-select [query nick]))))

(defn authorize-nick-hash [nick hash]
  (let [db-user (fetch-nick nick)]
    (if (and db-user (= (db-user :hash) hash))
      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))
     "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 " 
                   "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 image-only]
  (let [query (str "SELECT m.content, m.created_on, u.nick "
                   "FROM messages m, users u "
                   "WHERE m.user_id = u.user_id AND u.nick = ? "
                   (if image-only "AND m.is_image = true " "")
                   "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 "/chat")
      (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)
        email (params :email)
        hash (params :hash)]
    (if (fetch-nick nick)
      (resp-error "NICK_TAKEN")
      (with-connection db
        (insert-values :users 
                       [:nick :hash :email]
                       [nick hash email])
        (resp-success "OK")))))

;; 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 true)
            st (fetch-template "profile" session)]
        (do
          (.setAttribute st "is_home" is-home)
          (doseq [a [:nick :avatar :contact :bio]]
            (let [v (user-info a)]
              (.setAttribute st (name a)
                             (if (non-empty-string? v) (encode-html-entities v) 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)
        st (fetch-template "chat" session)
        message-list (to-array
                      (map process-message-for-output
                           (reverse (fetch-messages-by-room 1))))]
    (if nick
      (dosync
       (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)]
    (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"))))

;; http://snippets.dzone.com/posts/show/6995
(def url-regex #"((http\:\/\/|https\:\/\/|ftp\:\/\/)|(www\.))+(\w+:{0,1}\w*@)?(\S+)(:[0-9]+)?(\/|\/([\w#!:.?+=&%@!\-\/]))?")
(def pic-regex #"^.*\.(jpg|jpeg|png|gif|bmp)$")

(defn is-image? [content]
 (let [lower-content (.toLowerCase content)]
   (if (and (re-matches url-regex lower-content)
            (re-matches pic-regex lower-content))
     true false)))

(defn msg-transaction [nick msg]
  (dosync
   (and (contains? (ensure users) nick)
        (do (alter messages (swap cons) msg) 
            true))))

(defn msg-db [user-id room-id msg]
  (let [content (msg :content)
        is-image (is-image? content)]
    (with-connection db
      (insert-values :messages
                     [:user_id :room_id :content :is_image]
                     [user-id room-id content is-image]))))

(defn msg [session params]
   (let [user-id (session :user-id)
         nick (session :nick)
         content (.trim (params :content))
         now (new Date)
         msg (struct message-struct nick content now)]
     (if (msg-transaction nick msg)
       (do
         (msg-db user-id 1 msg)
         (resp-success "OK"))
       (resp-error "MUST_LOGIN"))))

(defroutes pichat
  (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 "/chat" (chat session))
  (GET "/refresh" (refresh session))
  (GET "/msg" (msg session params))
  (ANY "*" [404 "Page not found"]))

(decorate pichat 
  (with-mimetypes)
  (with-session {:type :memory, :expires (* 60 60)}))


; Load messages from database
(dosync
 (ref-set messages (fetch-messages-by-room 1)))

(run-server {:port 8080}
  "/*" (servlet pichat))

(send-off flusher flush!)