path: root/src/site.clj

(ns pichat
  (:import java.lang.System
           java.text.SimpleDateFormat
           java.util.Date
           java.util.TimeZone
           java.io.File
           javax.imageio.ImageIO
           org.apache.commons.codec.digest.DigestUtils
           javax.servlet.http.Cookie)
  (:use clojure.xml
        clojure.contrib.command-line
        clojure.contrib.duck-streams
        clojure.contrib.json.write
        clojure.contrib.sql
        clojure.contrib.str-utils
        clojure.contrib.def
        admin
        compojure
        email
        utils
        cookie-login
        session-sweeper
        feed
        tags))

(def *run-flusher* true)
(def *flusher-sleep* (seconds 4))
(def *user-timeout* (seconds 15))

(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 flusher (agent nil))

(defn flush-inactive-users! [x]
  (doseq [[rid room] @rooms]
    (dosync
     (let [users (room :users)
           now (System/currentTimeMillis)
           alive? (fn [[n u]] (> (u :last-seen) (- now *user-timeout*)))]
       (ref-set users
                (into {} (filter alive? @users))))))
  (Thread/sleep *flusher-sleep*)
  (when *run-flusher*
    (send *agent* #'flush-inactive-users!))
  x)

(defn start-user-flusher! []
  (send flusher flush-inactive-users!))

;; Configuration

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

(def *root-directory* (System/getProperty "user.dir"))
(def *image-directory* "images")
(def *avatar-directory* "avatars")

; Create image directories if they don't exist.
(.mkdir (new File *image-directory*))
(.mkdir (new File *avatar-directory*))

;; Utils

(defn id [x]
  x)

(defn open-file [dir-comps filename]
  (let [d (str-join (System/getProperty "file.separator")
                    (cons *root-directory* dir-comps))
        f (str-join (System/getProperty "file.separator")
                    [d filename])]
    (.mkdir (new File d))
    (new File f)))

(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))))


;; 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))

;; Logging

; is there a better way to do this or am i insane for introducing state? just wanna do
; (let [log (debug-log)]
;   (log "something")
;   (log "something else")
;   (log)) ; gets log array for output to template
(defn make-debug-logger
  ([] (make-debug-logger (new java.util.ArrayList)))
  ([log]
    (fn
      ([] (to-array log))
      ([s] (make-debug-logger (.add log s))))))

(defn make-time-logger
  ([] (make-time-logger (new java.util.ArrayList)))
  ([log]
    (fn
      ([] (to-array log));
            ([f & args]
        (let [start (.getTime (new Date))
             ret (apply f args)
              log-string (str f ": " (- (.getTime (new Date)) start) " msecs" )]
              (.add log log-string)
              ret)))))

;; Output

(defn strip-empty-vals [m]
  (into {} (filter (fn [[k v]] (non-empty-string? v)) m)))

(declare stringify-and-escape)
(defn escape-html-deep [o]
  (if (map? o)
      (stringify-and-escape o)
      (if (seq? o)
          (map escape-html-deep o)
          (escape-html o))))

(defn stringify-and-escape [m]
  (zipmap (map str* (keys m)) (map escape-html-deep (vals m))))

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

(defn process-message-for-output [d]
  (escape-html-deep 
   (strip-empty-vals
    (if (contains? d :created_on) 
      (assoc d :created_on (.format formatter (d :created_on)))
      d))))

(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]
  (stringify-and-escape (strip-empty-vals u)))

(defn process-directory-listing [d]
  (stringify-and-escape
   (strip-empty-vals d)))

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

(defn updates [room since]
  (let [m {"users" (prepare-user-list room)
           "messages" (map process-message-for-json
                           (new-messages room since))}
                           
        topic @(room :topic)]
    (if topic
      (assoc m "topic" topic)
      m)))


(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, u.avatar
		      FROM users u, messages m 
		      WHERE room_id = ? AND m.user_id = u.user_id "
          (if image-only "AND m.is_image = true " "")
          "ORDER BY created_on DESC
		      LIMIT ? OFFSET ?")]
       (do-select [query room-id *dumps-per-page* 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, m.message_id, u.nick, u.avatar, r.key
                       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 ? OFFSET ?")]
       (do-select [query nick *dumps-per-page* offset]))))


(defn fetch-public-message-by-id [id]
  (let [query "SELECT m.content, m.created_on, m.user_id, u.nick, u.avatar
               FROM messages m, users u, rooms r
               WHERE m.user_id = u.user_id
               AND r.room_id = m.room_id
               AND r.admin_only = false
               AND m.message_id = ?"]
    (first (do-select [query (maybe-parse-int id -1)]))))

(defn build-room-map-from-db [room-db]
  {: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))
   :topic (ref nil)
   })

;;  User-id/nick cache
;;  I keep needing to grab user-id from a nick so I thought I'd cache them

(def user-id-cache (ref {}))
(def *user-id-cache-size* 500)

(defn user-id-from-nick [nick]
  (let [nick (lower-case nick)
        found (@user-id-cache nick)]
    (if found
      found
      (let [query (str "SELECT user_id FROM users WHERE lower(nick) = ?")
            res (first (do-select [query nick]))]
        (if (nil? res)
          nil
          (let [found (res :user_id)]
            (dosync
              (if (> (count @user-id-cache) *user-id-cache-size*) (ref-set user-id-cache {}))
                (alter user-id-cache assoc nick found))
            found))))))

;; Login code

(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)
    :email (user-info :email)
    :is_admin (user-info :is_admin)
		:avatar (user-info :avatar)
    :password_login true))

;; login-token functions

(defn logged-in?
  "Test whether user is logged in by presence of nick key in session."
  [request]
  (contains? (request :session) :nick))

(defn encode-login-token [nick hash expiry]
  (let [token-hash (sha1-hash hash expiry)]
    (str nick "%" expiry "%" token-hash)))

(defn parse-login-token [token]
  (let [x (.split token "\\%")]
    (if (= (alength x) 3)
      (try [(aget x 0) (Long/parseLong (aget x 1)) (aget x 2)]
           (catch NumberFormatException _ nil)))))

(defn read-login-token [token]
  (if-let [[nick expiry token-hash]  (parse-login-token token)]
    (if (>= expiry (System/currentTimeMillis))
      (let [db-info (fetch-nick nick)
            computed-hash (sha1-hash (db-info :hash) expiry)]
        (if (= token-hash computed-hash)
          (select-keys db-info [:user_id :nick :email :is_admin :avatar]))))))

(defn make-login-token
  [{nick :nick hash :hash}]
  (let [expiration (ms-in-future *login-token-expiry*)]
    (set-cookie *login-token-key* 
                (encode-login-token nick hash expiration)
                :expires 
                (gmt-string (new Date expiration)))))

;; 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
                       (make-login-token db-user)
                       (clear-login-token *login-token-key*))]
    (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 *login-token-key*)
   (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)
	  (check-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)]
                    (send-registration-email nick email)
		    [(session-assoc-from-db db-user)
		     (resp-success "OK")])))))

;; Profile

(defn profile [session profile-nick offset]
  (if-let [user-info (fetch-nick profile-nick)]
    (let [st (fetch-template "profile" session)
          nick (session :nick)
          logger (make-time-logger)
          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*)
          raw-dumps (logger tags/fetch-dumps-by-nick :nick profile-nick :amount (+ 1 *dumps-per-page*) :offset dump-offset)
          dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
          dumps (map tags/remove-tags-for-output dumps)
          dumps (logger doall (map process-message-for-output dumps))]
      (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)))))
        (if (> (count dumps) 0)
          (.setAttribute st "dumps" dumps))
        (if (> (count raw-dumps) *dumps-per-page*)
          (.setAttribute st "next" (inc offset)))
        (if (not= offset 0)
          (.setAttribute st "prev" (max (dec offset) 0)))
        (.setAttribute st "debug_log_items" (logger))
        (.toString st)))
    (resp-error "NO_USER")))

(defn update-user-db [user-id attr val]
  (with-connection *db*
    (update-values "users" ["user_id = ?" user-id] {attr val})))

(defn update-avatar [session url] 
  (update-user-db (session :user_id) "avatar" url)
  [(session-assoc :avatar url)
   (resp-success url)])

(defn update-profile [session params]
  (let [user-id (session :user_id)
        attr (params :attr)
        val (params :val)
        attr-set #{"avatar" "contact" "bio"}]
    (cond (not user-id)                   (resp-error "MUST_LOGIN")
          (not (and user-id attr val))    (resp-error "BAD_REQUEST")
          (not (contains? attr-set attr)) (resp-error "BAD_REQUEST")
          (= attr "avatar")               (update-avatar session val)
          :else (do (update-user-db user-id attr val)
                    (resp-success "OK")))))

;; Directory

(def *directory-agent* (agent nil))
(def *directory-listing* (ref []))
(def *per-directory-page* 25)
(def *run-update-directory* true)
(def *update-directory-sleep* (minutes 15))

(defn directory-search [offset]
  (let [directory @*directory-listing* 
        users (subvec directory
                      (min (count directory) 
                           (* offset *per-directory-page*))
                      (min (count directory)
                           (* (inc offset) *per-directory-page*)))
        user-ids (apply str (interpose ", " (map #(%1 :user_id) users)))
        qry (str "SELECT u.user_id, u.nick, u.avatar, m.content, m.message_id
                  FROM users u, messages m
                  WHERE u.user_id in (" user-ids ")
                  AND m.user_id = u.user_id
                  AND m.message_id = (SELECT message_id FROM messages 
                           WHERE user_id = u.user_id
                           AND room_id = 1
                           AND is_image = true
                           ORDER BY created_on DESC LIMIT 1)")]
    (when (> (count user-ids) 0)
      (let [res (do-select [qry])
            keys (map :user_id res)
            res-dict (zipmap keys res)]
        (map (fn [u]
               (let [u-id (u :user_id)]
                 (process-directory-listing (merge u (res-dict u-id)))))
             users)))))
           
(defn update-directory! []
  (let [qry "SELECT u.user_id, COUNT(m) as cnt
             FROM users u, messages m
             WHERE u.user_id = m.user_id
             AND m.room_id = 1
             AND m.is_image = true
             GROUP BY u.user_id
             ORDER BY COUNT(m) DESC"
        res (vec (do-select [qry]))]
    (dosync (ref-set *directory-listing* res))
    res))

(defn update-directory-agent-func [x]
  (update-directory!)
  (Thread/sleep *update-directory-sleep*)
  (when *run-update-directory*
    (send *directory-agent* #'update-directory-agent-func))
  x)

(defn start-directory-updater! []
  (send *directory-agent* update-directory-agent-func))

(defn directory [session offset]    
  (let [st (fetch-template "directory" session)
        users (directory-search offset)]
    (.setAttribute st "users" users)
    (cond (= offset 0) (.setAttribute st "prev" false)
          (= offset 1) (.setAttribute st "prev" "")
          :else (.setAttribute st "prev" (str "/" (dec offset))))
    (if (> offset 0)
      (.setAttribute st "cur" offset))
    (.setAttribute st "next" (str "/" (inc offset)))
    (if (zero? (count @*directory-listing*))
      (.setAttribute st "notloaded" true))
    (.toString st)))

;; Single posts

(defn single-message [session nick-from-url id-from-url]
  (if-let [user-info (fetch-nick nick-from-url)]
    (if-let [message (fetch-public-message-by-id id-from-url)]
      ; error if nick in url doesn't match the nick who posted the message from the id in url 
      ; this prevents people from scraping all the content by incrementing the id in the url
      (if (= (user-info :user_id) (message :user_id))
        (let [st (fetch-template "single_message" session)]
          (.setAttribute st "message" (process-message-for-output message))
          (.toString st))
        (resp-error "NO_MESSAGE"))
      (resp-error "NO_MESSAGE"))
    (resp-error "NO_USER")))


;; Topics

(defn valid-topic? [topic]
  topic)

(defn valid-deadline? [deadline]
  deadline)

(defn topic-map-from-room [r]
  (let [topic (or @(r :topic) {})]
    {"key" (r :key)
     "topic" (topic :topic)
     "deadline" (topic :deadline)
     "maker" (topic :maker)}))

(defn validate-topic-list [session]
  (if (is-vip? session)
    (let [st (fetch-template "topic_list" session)]
      (.setAttribute st "rooms"
                     (map topic-map-from-room (vals @rooms)))
      (.toString st))
    [404 "UNKNOWN_ROOM"]))

(defn set-topic! [room topic deadline maker]
  (dosync (ref-set (room :topic) 
                   {:topic topic
                    :deadline deadline
                    :maker maker})))

(defn end-topic! [room]
  (dosync (ref-set (room :topic) nil)))

(defn validate-set-topic [session params]
  (let [room     (@rooms (params :room))
        topic    (params :topic)
        deadline (params :deadline)
        maker    (params :maker)]
    (cond (not (is-vip? session))          (resp-error "NOT_VIP")
          (not (valid-topic? topic))       (resp-error "INVALID_TOPIC")
          (not (valid-deadline? deadline)) (resp-error "INVALID_DEADLINE")
          (not room)                       (resp-error "INVALID_ROOM")
          (not maker)                      (resp-error "NOT_MAKER")
          :else (do
                  (set-topic! room topic deadline maker)
                  (resp-success "OK")))))

(defn validate-end-topic [session params]
  (let [room (@rooms (params :room))]
    (cond (not (is-vip? :is_admin)) (resp-error "NOT_VIP")
          (not room)                (resp-error "INVALID_ROOM")
          :else (do
                  (end-topic! room)
                  (resp-success "OK")))))

;; Chat

(defn validate-room-access [room-key session]
  (let [room (@rooms room-key)]
    (and room
         (or (not (room :admin_only))
             (is-vip? session)))))

;; 3/20/10: add template so multiple chat urls for ryder
(defn chat [session room template]
  (let [now (System/currentTimeMillis)
        nick (session :nick)
        st (fetch-template template session)
        ; TODO: remove db query
        message-list (reverse (tags/fetch-dumps-by-room :room-id (room :room_id) :image-only false))
        message-list (map tags/add-favorited-flag message-list (repeat session))
        message-list (to-array (map process-message-for-output message-list))]
    (if nick
      (dosync
       (login-user (user-struct-from-session session) room)))
    (let [user-list (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 template]
  (if (validate-room-access room-key session)
    (chat session (@rooms room-key) template)
    (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-let [user-info (@users nick)]
         ; Incorporate avatar updates
         (commute users assoc nick (merge user-info {:last-seen now
                                                     :avatar (session :avatar)}))
         (commute (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 "dumpfm")
        now (System/currentTimeMillis)
        nick (session :nick)
        st (fetch-template "browser" session)]
    (if nick
      (dosync
       (login-user (user-struct-from-session session) room)))
    (let [user-list (prepare-user-list room)]
      (.setAttribute st "users" user-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
; timb: ^^ done... i changed it to fetch one more than is shown per page to determine if next page is needed
(defn log [session room offset params]
  (let [st (fetch-template "log" session)
  logger (make-time-logger)
	offset (maybe-parse-int offset 0)
  dump-offset (* offset *dumps-per-page*)
  image-only (and (not (room :admin_only))
                        (not= (params :show) "all"))
  raw-dumps (logger tags/fetch-dumps-by-room :room-id (room :room_id) 
                                             :image-only image-only 
                                             :amount (+ 1 *dumps-per-page*)
                                             :offset dump-offset)
  dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
;;   json-tags (for [dump dumps :when (not (empty? (dump :tags)))] 
;;               (json-str {"id" (dump :message_id) "tags" (dump :tags) }))
  dumps (map tags/remove-tags-for-output dumps)
  dumps (logger doall (map process-message-for-output dumps))]
    (if (> (count raw-dumps) *dumps-per-page*)
      (.setAttribute st "next" (inc offset)))
    (if (not= offset 0)
      (.setAttribute st "prev" (max (dec offset) 0)))
    (.setAttribute st "dumps" dumps)
;;     (.setAttribute st "json_tags" json-tags)
    (.setAttribute st "roomkey" (room :key))
    (.setAttribute st "roomname" (room :name))
    (.setAttribute st "debug_log_items" (logger))
    (.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")))

;; Tags

(defn undecoded-url-piece [url position]
  "Get nth thing out of a url path.
  For example, (undecoded-url-piece 'http://example.com/a/b/c?foo' 2) will return 'c'"
  (let [path-without-domain (nth (re-find #"//[^/]+/(.+)" url) 1)]
    (nth (re-split #"/|\?" path-without-domain) position)))

(defn add-tag [user-id message-id tag]
  (try
    (do-insert "tags" ["user_id" "message_id" "tag"] [user-id (maybe-parse-int message-id) (normalize-tag-for-db tag)])
    true
    ; catch error when inserting duplicate tags
    (catch Exception e false)))


; to do: don't let people set tags on messages they can't access
(defn validated-add-tag [session params]
  (if (session :nick)
      (if (add-tag (session :user_id) (params :message_id) (params :tag))
        (resp-success "OK")
        (resp-error "TAG_EXISTS_ALREADY_OR_SOMETHING_ELSE_IS_FUCKED"))
      (resp-error "NO_USER")))

(defn remove-tag [user-id message-id tag]
  (let [query "user_id = ? AND message_id = ? AND lower(tag) = ?"]
       (do-delete "tags" [query user-id (maybe-parse-int message-id) (normalize-tag-for-db (.toLowerCase tag))])
       (resp-success "OK")))

(defn validated-remove-tag [session params]
  (if (session :nick)
     (remove-tag (session :user_id) (params :message_id) (params :tag))
     (resp-error "NO_USER")))

;; message-user-id: get messages posted by this user
;; tag-user-id: get messages tagged by this user
(defnk tagged-dumps-template [session params tags url page-title :message-user-id false 
                                                                 :tag-user-id false 
                                                                 :logger (make-time-logger)]
  (let [st (fetch-template "tagged_dumps" session)
	      offset (maybe-parse-int (params :offset) 0)
        dump-offset (* offset *dumps-per-page*)
        raw-dumps (logger tags/fetch-dumps-by-tag :tags tags 
                                                  :image-only false 
                                                  :amount (+ 1 *dumps-per-page*)
                                                  :offset dump-offset
                                                  :message-user-id message-user-id
                                                  :tag-user-id tag-user-id)
        dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
        dumps (map tags/remove-tags-for-output dumps)
        dumps (logger doall (map process-message-for-output dumps))]
          (if (> (count raw-dumps) *dumps-per-page*)
            (.setAttribute st "next" (inc offset)))
          (if (not= offset 0)
            (.setAttribute st "prev" (max (dec offset) 0)))
          (.setAttribute st "dumps" dumps)
          (.setAttribute st "page_title" page-title)
          (.setAttribute st "page_url" url)
          (.setAttribute st "debug_log_items" (logger))
          (.toString st)))

;; gotta parse tag intersections myself because +'s get decoded into spaces
;; there's probably a less hacky way to do this
(defn tagged-dumps-by-nick [session params url]
  (let [nick (params :nick)
        tags (map url-decode (re-split #"\+" (undecoded-url-piece url 3)))
        user-id (user-id-from-nick nick)
        url (str "u/" nick "/tag/" (str-join "+" (map url-encode tags)))
        page-title (str "dumps " nick " tagged as '" (escape-html (str-join "' and '" tags)) "'")]
    (tagged-dumps-template session params tags url page-title :tag-user-id user-id)))

(defn tagged-dumps [session params url]
  (let [tags (map url-decode (re-split #"\+" (undecoded-url-piece url 1)))
        url (str "tag/" (str-join "+" (map url-encode tags)))
        page-title (str "dumps tagged as '" (escape-html (str-join "' and '" tags)) "'")]
    (tagged-dumps-template session params tags url page-title)))

(defn favorites [session params]
  (let [nick (params :nick)
        user-id (user-id-from-nick nick)
        url (str "u/" nick "/favorites")
        page-title (str nick "'s favorites")]
    (tagged-dumps-template session params "favorite" url page-title :tag-user-id user-id)))

(defn json-favorites [session params]
  (let [nick (params :nick)
        user-id (user-id-from-nick nick)
        raw-favs (tags/fetch-dumps-by-tag :tags "favorite"
                                          :image-only false
                                          :amount 50
                                          :offset 0
                                          :tag-user-id user-id
                                          :with-tags false)
        favs (reduce (fn [m fav] (assoc m (str (fav :message_id)) (fav :content))) {} raw-favs)]
    (str "RawFavs=" (json-str favs))))


;; Account resets

(defn reset-page [session]
  )

(defn reset-account-request! [session params]
  )

(defn reset-account! [session key]
  )

;; Upload


(def *max-image-height* 2000)
(def *max-image-width* 2000)
(def *max-avatar-height* 2000)
(def *max-avatar-width* 2000)
(def *vip-max-file-size* (mbytes 5)) ; don't be nuts guys
(def *max-file-size* (kbytes 750))
(def *ignore-size-limit-for-vip* true)
(def *avatar-dimensions* [50 50])

(defn file-size-limit [vip]
  (if (and *ignore-size-limit-for-vip* vip)
    *vip-max-file-size*
    *max-file-size*))

(defn is-file-too-big? [f vip]
  (let [limit (file-size-limit vip)]
    (if (> (.length f) limit)
      (str "FILE_TOO_BIG " limit))))

(defn is-image-invalid? [f]
  (try 
   (let [i (ImageIO/read f)
         height (.getHeight i)
         width (.getWidth i)]
     (if (or (> width *max-image-width*)
             (> height *max-image-height*))
       (str "INVALID_RESOLUTION "  *max-image-width* " " *max-image-height*)))
   (catch Exception _ "FILE_NOT_IMAGE")))

(defn format-filename [s nick]
  (let [spaceless (.replace s \space \-)
        nick-clean (re-gsub #"[^A-Za-z0-9]" "" nick)
        subbed (re-gsub #"[^\w.-]" "" spaceless)]
    (str-join "-" [(System/currentTimeMillis) "dumpfm" nick-clean subbed])))

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

(defn validate-upload [f vip]
  (or (is-file-too-big? f vip)
      (is-image-invalid? f)))

(defn do-upload [session image room]
  (if-let [err (validate-upload (image :tempfile) (is-vip? session))]
    (resp-error err)
    (let [filename (format-filename (:filename image) (session :nick))
          date (today)
          dest (open-file [*image-directory* date] filename)
          url (image-url-from-file "images" date dest)
          msg-id (msg-db (session :user_id) (room :room_id) url)
          msg (struct message-struct (session :nick) url (new Date) msg-id)]
      (do 
        (dosync
         (add-message msg room))
        (copy (:tempfile image) dest)
        (resp-success url)))))

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

;; N.B. -- Upload responses aren't JSON-evaluated
(defn do-upload-avatar [session image]
  (let [filename (format-filename (:filename image) (session :nick))
        date (today)
        dest (open-file [*avatar-directory* date] filename)
        url (image-url-from-file "avatars" date dest)]
    (do
      (copy (:tempfile image) dest)
      (update-user-db (session :user_id) "avatar" url)
      [(session-assoc :avatar url)
       [200 url]])))

(defn upload-avatar [session params]
  (let [image (params :image)]
    (cond (not image) [200 "INVALID_REQUEST"]
          (not (session :nick)) [200 "NOT_LOGGED_IN"]
          :else (do-upload-avatar session image))))


;; 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" "max-age=604800,public"}}
                       {})]
    [cache-header
     (serve-file dir path)]))

(defroutes static
  (GET "/static/*" (serve-static "static" (params :*)))
  (GET "/images/*" (serve-static *image-directory* (params :*)))
  (GET "/avatars/*" (serve-static *avatar-directory* (params :*))))

(defroutes pichat
  (GET "/" (no-cache (landing session)))
  (GET "/favicon.ico" (serve-static "static" "favicon.ico"))
  (GET "/u/:nick" (profile session (params :nick) "0"))  
  (GET "/u/:nick/" (profile session (params :nick) "0"))
  (GET "/u/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
  (GET "/u/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
  (GET "/u/:nick/favorites" (favorites session params))
  (GET "/u/:nick/favorites/:offset" (favorites session params))
  (GET "/json/:nick/favorites" (json-favorites session params))
  (GET "/u/:nick/:offset" (profile session
                                   (params :nick)
                                   (params :offset)))  ; have to put this route after favs
  (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid)))
  (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) "chat")))
  (GET "/chat" (no-cache (validated-chat session "dumpfm" "chat")))
  (GET "/chat/:t" (no-cache (validated-chat session "dumpfm" (-> request :route-params :t))))
  (GET "/browser" (browser session))
  (GET "/refresh" (validated-refresh session params))
  (GET "/tag/:tag" (tagged-dumps session params (request-url request)))
  (GET "/tag/:tag/:offset" (tagged-dumps session params (request-url request)))
  (POST "/cmd/tag/add" (validated-add-tag session params))
  (POST "/cmd/tag/rm" (validated-remove-tag session params))
  (GET "/log" (validated-log session "dumpfm" "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: add form tokens for all destructive actions
  (POST "/msg" (validated-msg session params))
  (POST "/submit-registration" (register session params))
  (POST "/update-profile" (update-profile session params))
  (GET "/topic-list" (validate-topic-list session))
  (POST "/set-topic" (validate-set-topic session params))
  (POST "/end-topic" (validate-end-topic session params))
  (GET "/directory" (directory session 0))
  (GET "/directory/:offset"
       (directory session (maybe-parse-int (-> request :route-params :offset) 0)))
  (GET "/reset" (reset-page session)) 
  (POST "/reset-request" (reset-account-request! session params))
  (POST "/reset/:key" (reset-account! session (-> request :route-params :key)))

  ;; Admin stuff (should be own route?)
  (GET "/debug" (debug-page session flash))
  (POST "/debug" (debug-commmand! session params))
  (GET "/mute-status" (mute-status session))
  (POST "/mute" (mute! session params))

  ;; Footer pages
  (GET "/about_us" (serve-template "about_us" session))
  (GET "/goodies" (serve-template "goodies" session))
  (GET "/help" (serve-template "help" session))
  (GET "/privacy" (serve-template "privacy" session))
  (GET "/terms" (serve-template "terms" session))
  (GET "/error/ie" (serve-template "error_ie" session))
  (ANY "*" (unknown-page)))

(defroutes multipart
  (POST "/upload/message" (upload session params))
  (POST "/upload/avatar" (upload-avatar 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 static
  (with-mimetypes {:mimetypes mimetypes}))

(decorate pichat
  (with-mimetypes {:mimetypes mimetypes})
  (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
  (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)
               (build-room-map-from-db room-db))))

(defn start-server [port] 
  (run-server {:port port}
              "/static/*" (servlet static)
              "/images/*" (servlet static)
              "/avatars/*" (servlet static)
              "/upload/*" (servlet multipart)
              "/*" (servlet pichat)))

(defn parse-command-args
  "Parses command-line arguments. First arg is script name,
  second arg is port number (defaults to 8080)."
  ([script] {:port 8080})
  ([script port] {:port (Integer/parseInt port)}))

(def options 
     (apply parse-command-args *command-line-args*))

(start-server (options :port))
(start-user-flusher!)
(start-session-pruner!)
(start-directory-updater!)