path: root/src/site.clj

(ns pichat
  (:import java.lang.System
           java.text.SimpleDateFormat
           java.util.Date
           java.util.TimeZone
           java.io.File
           org.apache.commons.codec.digest.DigestUtils
           javax.servlet.http.Cookie
           org.antlr.stringtemplate.StringTemplateGroup)
  (:use compojure
        clojure.contrib.str-utils
        clojure.contrib.duck-streams
        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 :nick :user_id :avatar :last-seen)
(defstruct message-struct :nick :content :created_on :msg_id)

(defn user-struct-from-session [session]
  (struct user-struct (session :nick) (session :user_id) (session :avatar)
          (System/currentTimeMillis)))

(def rooms (ref {}))

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

(def flusher (agent nil))

(defn flush! [x]
  (when run-flusher
    (send-off *agent* #'flush!))
  (doseq [[rid room] @rooms]
    (dosync
     (let [users (room :users)
           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)

;; Configuration

(def *server-url*
  (if (= (System/getProperty "user.name") "dumpfmprod")
    "http://dump.fm"
    "http://localhost:8080"))

(def *image-directory* "images")

; Create image directory if it doesn't exist.
(.mkdir (new File *image-directory*))

;; Utils

(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 non-empty-string? [s]
  (and s (> (count s) 0)))

(defn rel-join [& more]
  (str-join (System/getProperty "file.separator")
            (cons (System/getProperty "user.dir")
                  more)))

(defn sha1-hash [& more]
  (DigestUtils/shaHex (apply str more)))

(defn gmt-string 
  ([] (gmt-string (new Date)))
  ([dt]
     (let [df (new SimpleDateFormat "EEE, dd MMM yyyy kk:mm:ss z")]
       (.setTimeZone df (TimeZone/getTimeZone "GMT"))
       (.format df dt))))

;; Database

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

(defn do-count [query]
  ((first (with-connection db
	    (with-query-results rs query
	      (doall rs))))
   :count))

;; User authentication

(def nick-regex #"^[A-Za-z0-9\-_∆˚†]*$")

(defn is-invalid-nick? [n]
  (cond
   (< (count n) 3) "NICK_TOO_SHORT"
   (not (re-matches nick-regex n)) "NICK_INVALID_CHARS"))

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

(defn authorize-nick-hash [nick hash]
  (let [db-user (fetch-nick nick)]
    (and db-user (= (db-user :hash) hash) db-user)))

;; Room handling

(defn fetch-rooms []
  (do-select ["SELECT * FROM ROOMS"]))

(defn login-user [user room]
  (alter (room :users) assoc (user :nick) user))

(defn add-message [msg room]
  (alter (room :messages) (swap cons) msg))

;; Output

(defn process-message-for-json [d]
  (assoc d :created_on (.getTime (d :created_on))))

(defn process-message-for-output [d]
  {"nick" (escape-html (d :nick))
   "message_id" (d :message_id)
   "created_on" (.format formatter (d :created_on))
   "content" (escape-html (d :content))})

(defn new-messages [room since-ts]
  (let [since-date (new Date (long since-ts))]
    (reverse (take-while (fn [m] (.after (m :created_on) since-date)) 
                         @(room :messages)))))

(defn process-user [u]
  (if (non-empty-string? (u :avatar))
    {"nick" (u :nick)
     "avatar" (escape-html (u :avatar))}
    {"nick" (u :nick)}))

(defn prepare-user-list [room]
  (map process-user (sort-by #(% :nick)
			     (vals @(room :users)))))

(defn updates [room since] 
  {"users" (prepare-user-list room)
   "messages" (map process-message-for-json
                   (new-messages room since))})

(def dumps-per-page 20)

(defn maybe-parse-int [s f]
  (if s (Integer/parseInt s) f))

(defn maybe-parse-long [s f]
  (if s (Long/parseLong s) f))

(defn count-messages-by-room [room-id image-only]
  (let [query (str "SELECT COUNT(*) "
		   "FROM messages m, users u "
		   "WHERE room_id = ? AND m.user_id = u.user_id "
		   (if image-only "AND m.is_image = true " ""))]
    (do-count [query room-id])))

(defn fetch-messages-by-room
  ([room-id image-only] (fetch-messages-by-room room-id image-only 0))
  ([room-id image-only offset]
     (let [query (str "SELECT m.content, m.message_id, m.created_on, u.nick "
		      "FROM messages m, users u "
		      "WHERE room_id = ? AND m.user_id = u.user_id "
                      (if image-only "AND m.is_image = true " "")
		      "ORDER BY created_on DESC "
		      "LIMIT " dumps-per-page " OFFSET ?")]
       (do-select [query room-id offset]))))

(defn count-messages-by-nick [nick image-only]
  (let [query (str "SELECT COUNT(*) "
		   "FROM messages m, users u, rooms r "
		   "WHERE m.user_id = u.user_id AND u.nick = ? "
                   "AND r.room_id = m.room_id AND r.admin_only = false "
		   (if image-only "AND m.is_image = true " ""))]
    (do-count [query nick])))

(defn fetch-messages-by-nick 
  ([nick image-only] (fetch-messages-by-nick nick image-only 0))
  ([nick image-only offset]
     (let [query (str "SELECT m.content, m.created_on, u.nick "
                      "FROM messages m, users u, rooms r "
                      "WHERE m.user_id = u.user_id AND u.nick = ? "
                      "AND r.room_id = m.room_id AND r.admin_only = false "
                      (if image-only "AND m.is_image = true " "")
                      "ORDER BY created_on DESC "
                      "LIMIT " dumps-per-page " OFFSET ?")]
       (do-select [query nick offset]))))

;; Templates

(defn fetch-template [template-name session]
  (let [st (.getInstanceOf template-group template-name)]
    (if (and st (session :nick))
      (do (.setAttribute st "user_nick" (session :nick))
          (.setAttribute st "isadmin" (session :is_admin))))
    st))


;; Login code
  
;; Authorize login-cookies for a week.
(def *login-cookie-duration* (* 1000 60 60 24 7))

(defn session-map-from-db
  [user-info]
  {:user_id (user-info :user_id)
   :nick (user-info :nick)
   :is_admin (user-info :is_admin)
   :avatar (user-info :avatar)})

(defn session-assoc-from-db 
  [user-info]
  (session-assoc :user_id (user-info :user_id)
		 :nick (user-info :nick)
                 :is_admin (user-info :is_admin)
		 :avatar (user-info :avatar)))

(defn generate-login-token [nick hash]
  (let [expiry (+ (System/currentTimeMillis) *login-cookie-duration*)
        token-hash (sha1-hash hash expiry)]
    (str nick "%" expiry "%" token-hash)))

(defn validate-login-token [token]
  (try
   (let [[nick expiry token-hash] (.split token "\\%")]
         (if (< (Long/parseLong expiry) (System/currentTimeMillis))
           nil
           (let [db-info (fetch-nick nick)
                 computed-hash (sha1-hash (db-info :hash) expiry)]
             (if (= token-hash computed-hash)
               db-info nil))))
   (catch Exception _ nil)))

(defn clear-login-token
  []
  (set-cookie :token "dummy"
              :expires "Thu, 01-Jan-70 00:00:01 GMT"))

(defn set-login-token
  [nick hash]
  (set-cookie :token (generate-login-token nick hash)
              :expires (gmt-string (new Date
                                        (+ (System/currentTimeMillis)
                                           *login-cookie-duration*)))))

(defn apply-login-info
  [request user-info]
  (let [req-cookies (request :cookies)
        req-session (request :session)
        login-token (generate-login-token (user-info :nick)
                                          (user-info :hash))
        user-session (session-map-from-db user-info)]
    (merge request
           {:cookies (assoc req-cookies :token login-token)
            :session (merge req-session user-session)})))

(defn logged-in?
  "Test whether user is logged in"
  [session]
  (and session (contains? session :nick)))

(defn try-cookie-login
  [request]
  (let [token (get-in request [:cookies :token])
        login-info (validate-login-token token)]
    (if (not login-info)
      (merge request (clear-login-token))
      (apply-login-info request login-info))))

(defn with-cookie-login
  "Middleware to support automatic cookie login. Place after with-session."
  [handler]
  (fn [request]
    (if (or (logged-in? (request :session))
            (not (get-in request [:cookies :token])))
      (handler request)
      (handler (try-cookie-login request)))))

;; Landing

(defn landing [session]
  (if (session :nick)
    (redirect-to "/chat")
    (serve-file "static" "index.html")))

(defn login [session params cookies]
  (let [nick (params :nick)
        hash (params :hash)
        db-user (authorize-nick-hash nick hash)
        remember-me (= (params :rememberme) "yes")
        login-cookie (if remember-me
                       (set-login-token nick hash)
                       (clear-login-token))]
    (if db-user
      [(session-assoc-from-db db-user)
       login-cookie
       (resp-success "OK")]
      (resp-error "BAD_LOGIN"))))

(defn logout [session]
  [(session-dissoc :nick :user_id :is_admin :avatar)
   (clear-login-token)
   (redirect-to "/")])

;; Registration

(defn register [session params]
  (let [nick (params :nick)
        email (params :email)
        hash (params :hash)
	invalid-nick-reason (is-invalid-nick? nick)]
    (cond invalid-nick-reason (resp-error invalid-nick-reason)
	  (fetch-nick nick) (resp-error "NICK_TAKEN")
	  :else (with-connection db
		  (insert-values :users
				 [:nick :hash :email]
				 [nick hash email])
		  (let [db-user (fetch-nick nick)]
		    [(session-assoc-from-db db-user)
		     (resp-success "OK")])))))

;; Profile

(defn profile [session profile-nick offset]
  (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))
            offset (maybe-parse-int offset 0)
            dump-offset (* offset dumps-per-page)
            dumps (fetch-messages-by-nick profile-nick true dump-offset)
	    dump-count (count-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) (escape-html v)))))
          (.setAttribute st "dumps"
                         (to-array (map process-message-for-output dumps)))
	  (if (< (+ dump-offset dumps-per-page) dump-count)
	    (.setAttribute st "next" (inc offset)))
	  (if (not= offset 0)
	    (.setAttribute st "prev" (max (dec offset) 0)))
        (.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 validate-room-access [room-key session]
  (let [room (@rooms room-key)]
    (and room
         (or (not (room :admin_only))
             (session :is_admin)))))

(defn chat [session room]
  (let [now (System/currentTimeMillis)
        nick (session :nick)
        st (fetch-template "chat" session)
        message-list (to-array
                      (map process-message-for-output
                           ; TODO: remove db query
                           (reverse (fetch-messages-by-room (room :room_id) false))))]
    (if nick
      (dosync
       (login-user (user-struct-from-session session) room)))
    (let [user-list (to-array (prepare-user-list room))]
      (.setAttribute st "users" user-list))
    (.setAttribute st "messages" message-list)
    (.setAttribute st "roomkey" (room :key))
    (.setAttribute st "isadminroom" (room :admin_only))
    (.setAttribute st "json_room_key" (json-str (room :key)))
    (.setAttribute st "json_user_nick" (if nick (json-str nick) "null"))
    (.setAttribute st "roomname" (room :name))
    (.setAttribute st "timestamp" now)
    (.toString st)))

(defn validated-chat [session room-key]
  (if (validate-room-access room-key session)
    (chat session (@rooms room-key))
    (resp-error "UNKNOWN_ROOM")))

(defn refresh [session params room]
  (dosync
   (let [now (System/currentTimeMillis)
         since (maybe-parse-long (params :since) now)
         nick (session :nick)
         users (room :users)]
     (if nick
       (if (contains? @users nick)
         (alter users assoc-in [nick :last-seen] now)
         (alter (room :users) assoc nick (user-struct-from-session session))))
     (resp-success (assoc (updates room since)
                     :timestamp now)))))

(defn validated-refresh [session params]
  (let [room-key (params :room)
        room (@rooms room-key)]
    (if (validate-room-access room-key session)
      (refresh session params room)
      (resp-error "UNKNOWN_ROOM"))))

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

(defn strip-params [s]
  (.replaceFirst s "\\?.*$" ""))

(defn is-image? [content]
  (if (and (re-find single-url-regex content)
           (re-find pic-regex (strip-params content)))
    true false))

(defn msg-db [user-id room-id content]
  (let [is-image (is-image? content) 
	qry (str "INSERT INTO messages (user_id, room_id, content, is_image) "
		 "VALUES (?, ?, ?, ?) RETURNING message_id")] 
    (with-connection db
      ((first (do-select [qry user-id room-id content is-image])) 
       :message_id))))

(defn msg [session params]
   (let [user-id (session :user_id)
         nick (session :nick)
         room-key (params :room)
         room (@rooms room-key)
         content (.trim (params :content))
         now (new Date)]
     (cond (not room) (resp-error "BAD_ROOM")
           (not nick) (resp-error "NOT_LOGGED_IN")
           :else
	   (let [msg-id (msg-db user-id (room :room_id) content)
		 msg (struct message-struct nick content now msg-id)]
	     (dosync
	      (if (not (contains? (ensure (room :users)) nick))
		(login-user (user-struct-from-session session) room))
	      (add-message msg room))
	     (resp-success msg-id)))))

(defn validated-msg [session params]
  (if (validate-room-access (params :room) session)
    (msg session params)
    (resp-error "UNKNOWN_ROOM")))

;; Browser

(defn browser [session]
  (let [room  (@rooms "RoomA")
        now (System/currentTimeMillis)
        nick (session :nick)
        st (fetch-template "browser" session)
        message-list (to-array
                      (map process-message-for-output
                           ; TODO: remove db query
                           (reverse (fetch-messages-by-room (room :room_id) false))))]
    (if nick
      (dosync
       (login-user (user-struct-from-session session) room)))
    (let [user-list (to-array (prepare-user-list room))]
      (.setAttribute st "users" user-list))
    (.setAttribute st "messages" message-list)
    (.setAttribute st "roomkey" (room :key))
    (.setAttribute st "isadminroom" (room :admin_only))
    (.setAttribute st "json_room_key" (json-str (room :key)))
    (.setAttribute st "json_user_nick" (if nick (json-str nick) "null"))
    (.setAttribute st "roomname" (room :name))
    (.setAttribute st "timestamp" now)
    (.toString st)))


;; Chat Log

; TODO: Optimize dump counts
(defn log [session room offset params]
  (let [st (fetch-template "log" session)
	offset (maybe-parse-int offset 0)
        dump-offset (* offset dumps-per-page)
        image-only (and (not (room :admin_only))
                        (not= (params :show) "all"))
	dumps (to-array (map process-message-for-output
			     (fetch-messages-by-room (room :room_id) image-only dump-offset)))
	dump-count (count-messages-by-room (room :room_id) image-only)]
    (if (< (+ dump-offset dumps-per-page) dump-count)
      (.setAttribute st "next" (inc offset)))
    (if (not= offset 0)
      (.setAttribute st "prev" (max (dec offset) 0)))
    (.setAttribute st "dumps" dumps)
    (.setAttribute st "roomkey" (room :key))
    (.setAttribute st "roomname" (room :name))
    (.toString st)))

(defn validated-log [session room-key offset params]
  (if (validate-room-access room-key session)
    (log session (@rooms room-key) offset params)
    (resp-error "UNKNOWN_ROOM")))

;; Upload

(defn format-filename [s]
  (let [spaceless (.replace s \space \-)
        subbed (re-gsub #"[^\w.-]" "" spaceless)]
    (str (System/currentTimeMillis) "-" subbed)))

(defn image-url-from-file [f]
  (str-join "/" [*server-url* "images" (.getName f)]))

(defn do-upload [session image room]
  (let [filename (format-filename (:filename image))
        dest (File. (rel-join *image-directory* filename))
        url (image-url-from-file dest)
        msg-id (msg-db (session :user_id) (room :room_id) url)
        now (new Date)
        msg (struct message-struct (session :nick) url now msg-id)]
    (dosync
     (add-message msg room))
    (copy (:tempfile image) dest)
    [200 url]))

(defn upload [session params]
  (let [room-key (params :room)
        nick (session :nick)]
    (cond (not nick) [200 "NOT_LOGGED_IN"]
          (not (validate-room-access room-key session)) [200 "UNKNOWN_ROOM"]
          :else (do-upload session (:image params) (@rooms room-key)))))
;; 404

(defn unknown-page [params]
  [404 "Page not Found"])

;; Compojure Routes

(defn no-cache [resp]
  [{:headers {"Cache-Control" "no-cache, no-store, max-age=0, must-revalidate"}}
   resp])

(defn serve-static [dir path]
  ; TODO: cache policy for other static files (js, css, etc.)
  (let [cache-header (if (re-find pic-regex path)
                       {:headers {"Cache-Control"
                                  "post-check=3600,pre-check=43200"}}
                       {})]
    [cache-header
     (serve-file dir path)]))

(defroutes pichat
  (GET "/" (no-cache (landing session)))
  (GET "/favicon.ico" (serve-static "static" "favicon.ico"))
  (GET "/static/*" (serve-static "static" (params :*)))
  (GET "/images/*" (serve-static *image-directory* (params :*)))
  (GET "/u/:nick" (profile session (params :nick) "0"))
  (GET "/u/:nick/" (profile session (params :nick) "0"))
  (GET "/u/:nick/:offset" (profile session
                                   (params :nick)
                                   (params :offset)))
  (GET "/login" (login session params cookies))
  (GET "/logout" (logout session))
  (GET "/register" (serve-static "static" "register.html"))
  (GET "/:room/chat" (no-cache (validated-chat session (-> request :route-params :room))))
  (GET "/chat" (no-cache (validated-chat session "RoomA")))
  (GET "/browser" (browser session))
  (GET "/refresh" (validated-refresh session params))
  (GET "/log" (validated-log session "RoomA" "0" params))
  (GET "/:room/log" (validated-log session 
                                   (-> request :route-params :room)
                                   "0" params))
  (GET "/:room/log/:offset" (validated-log session
                                           (-> request :route-params :room)
                                           (-> request :route-params :offset)
                                           params))
  ;; TODO: validate POST Referrer headers for POSTs
  (POST "/msg" (validated-msg session params))
  (POST "/submit-registration" (register session params))
  (POST "/update-profile" (update-profile session params))
  (ANY "*" (unknown-page params)))

(defroutes multipart
  (POST "/upload" (upload session params)))

;; Add jpeg to list
(def mimetypes
  {"css"  "text/css"
   "gif"  "image/gif"
   "gz"   "application/gzip"
   "htm"  "text/html"
   "html" "text/html"
   "jpg"  "image/jpeg"
   "jpeg" "image/jpeg"
   "js"   "text/javascript"
   "pdf"  "application/pdf"
   "png"  "image/png"
   "swf"  "application/x-shockwave-flash"
   "txt"  "text/plain"
   "xml"  "text/xml"
   "zip"  "application/zip"})

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

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

;; Load messages from database

(dosync
 (doseq [room-db (fetch-rooms)]
   (alter rooms assoc (room-db :key)
          {:admin_only (room-db :admin_only)
           :room_id (room-db :room_id)
           :key (room-db :key)
           :name (room-db :name)
           :description (room-db :description)
           :users (ref {})
           :messages (ref (fetch-messages-by-room (room-db :room_id) false))})))
  
(run-server {:port 8080}
  "/upload" (servlet multipart)
  "/*" (servlet pichat))

(send-off flusher flush!)