path: root/src/site.clj

(ns pichat
  (:import java.lang.System
           java.text.SimpleDateFormat
           java.util.Date
           java.io.File
           javax.imageio.ImageIO
           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
        rooms
        tags
        scheduled-agent
        user))

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

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


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

(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-timestamp (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]
  ; Sorting is done on client
  (map process-user (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-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 [m-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 m-id -1)]))))

;;  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.
   (Apply to request map)"
  [{session :session}]
  (contains? session :nick))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Login-token version history
;
; v0: Format: nick%expiry%token-hash
;     Date:   Mists of dump antiquity
;
; v1: Format: v1%nick%expiry%token-hash
;     Date:   2010/04/24
;     Note:   Contains same information as v0, but created under the
;             wildcard domain (i.e. ".dump.fm") so that logins work
;             across all subdomains.

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

(defn- parse-login-vec [v]
  (try [(aget v 1) (Long/parseLong (aget v 2)) (aget v 3)]
       (catch NumberFormatException _ nil)))

(defn parse-login-token [token]
  ; If users have multiple login-cookies across different domains
  ; (i.e. both "dump.fm" and ".dump.fm"), token will be a vector
  ; instead of a string.
  (if (not (string? token))
    (some identity (map parse-login-token token))
    (let [v  (.split token "\\%")]
      (if (and (= (alength v) 4) (= (aget v 0) "v1"))
        (parse-login-vec v)))))

(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*)
        token      (encode-login-token nick hash expiration)]
    (set-cookie *login-token-key* token
                :expires (gmt-string (new Date expiration))
                :domain ".dump.fm")))

;; Landing

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

(defn login [session params cookies]
  (let [nick         (or (params :nick) "")
        hash         (or (params :hash) "")
        remember-me  (= (params :rememberme) "yes")
        db-user      (authorize-nick-hash nick hash)
        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)
   (set-cookie *login-token-key* "dummy"
               :expires "Thu, 01-Jan-1970 00:00:01 GMT"
               :domain ".dump.fm")
   (redirect-to "http://dump.fm/")])

;; Registration

(def *reserved-nicks-path* "docs/reserved_nicks.txt")
(def *reserved-nicks-refresh-period-sec* 300)

(defn load-invalid-nicks []
  (set (read-lines *reserved-nicks-path*)))

(def *reserved-nicks*
     (scheduled-agent load-invalid-nicks
                      *reserved-nicks-refresh-period-sec*
                      (load-invalid-nicks)))

(defn nick-reserved? [nick]
  (let [query "SELECT * FROM users WHERE LOWER(nick) = ? LIMIT 1"]
    (or (contains? (poll *reserved-nicks*) nick)
        (> (count (do-select [query (lower-case nick)])) 0))))

(defn register [session params]
  (let [nick                (or (params :nick) "")
        email               (or (params :email) "")
        hash                (or (params :hash) "")
	invalid-nick-reason (is-invalid-nick? nick)]
    (cond invalid-nick-reason   (resp-error invalid-nick-reason)
	  (nick-reserved? nick) (resp-error "NICK_TAKEN")
	  :else (do
                  (do-insert :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")])))))

;; Fav scores

(def *score-query* "
SELECT u.nick,
       COUNT(*) AS cnt
FROM   tags t,
       messages m,
       users u
WHERE  t.message_id = m.message_id
       AND m.user_id != t.user_id
       AND m.user_id = u.user_id
GROUP  BY u.nick
ORDER  BY cnt DESC;
")

(def *scores-refresh-period-sec* (* 30 60))

(defn compute-scores []
  (let [res     (do-select [*score-query*])]
    (zipmap (map :nick res)
            (map :cnt  res))))

(def *user-scores*
     (scheduled-agent (no-args-adaptor compute-scores)
                      *scores-refresh-period-sec*
                      {}))

(def *piece-map*
     (zipmap
      [:pawn :knight :bishop :rook :queen :king :skull]
      ["♟" "♞" "♝" "♜" "♛" "♚" "☠"]))

(defn score-to-piece [score]
  (cond (= score -1)   :skull 
        (= score 0)    :pawn
        (< score 50)   :knight
        (< score 150)  :bishop
        (< score 300)  :rook
        (< score 1000) :queen
        :else :king))

(def score-to-entity (comp *piece-map* score-to-piece))

;; Profile

(def *zoeee-query* "
SELECT m.content, m.message_id, m.created_on, 
       u.nick, u.avatar, r.key, 
       array_to_string(ARRAY(SELECT nick || ' ' || tag
          FROM tags, users
          WHERE message_id = m.message_id AND tags.user_id = users.user_id), ' ') as tags
FROM messages m, users u,rooms r
WHERE u.nick = 'zoeee'
AND   m.user_id = u.user_id
AND   m.message_id <= 519399
AND   m.message_id >=  517713
AND   m.is_image = true
AND   m.room_id = r.room_id
AND   r.room_id = 1
ORDER BY created_on DESC;
")

(defn zoeee-nudes [session]
  (let [raw-dumps    (map tags/parse-tags-from-row-as-tag-map
                          (do-select [*zoeee-query*]))
        dumps        (map tags/add-favorited-flag raw-dumps (repeat session))
        dumps        (map tags/remove-tags-for-output dumps)
        dumps        (map process-message-for-output dumps)
        st           (fetch-template "profile" session)
        user-info    (fetch-nick "zoeee")]
    (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" dumps)
    (.toString st)))
      
(defn profile
  ([session profile-nick offset] (profile session profile-nick offset "profile"))
  ([session profile-nick offset template]
     (if-let [user-info (fetch-nick profile-nick)]
       (let [st            (fetch-template template session)
             profile-nick  (:nick user-info) ; Update to get right casing
             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)
             score         (if (= (lower-case profile-nick) "scottbot")
                             -1
                             (or ((poll *user-scores*) profile-nick) 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)))
        (.setAttribute st "score" score)
        (.setAttribute st "score_ent" (score-to-entity score))
        (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 *per-directory-page* 25)
(def *directory-refresh-period-sec* (* 60 60))

(def *directory-update-query* "
SELECT m.user_id,
       u.nick,
       u.avatar,
       message_id,
       m.created_on,
       msg_count,
       content
FROM   (SELECT user_id,
               created_on,
               message_id,
               content,
               MAX(created_on) OVER (PARTITION BY user_id) max_created_on,
               COUNT(*) OVER (PARTITION BY user_id)        msg_count
        FROM   messages
        WHERE  room_id = 1
               AND is_image = true) AS m,
       users u
WHERE  m.created_on = max_created_on
       AND m.user_id = u.user_id
ORDER  BY msg_count DESC")
           
(defn fetch-directory []
  (vec (do-select [*directory-update-query*])))

(def *directory-list*
  (scheduled-agent fetch-directory
                   *directory-refresh-period-sec*
                   []))

(defn directory-search [offset]
  (let [directory (poll *directory-list*)
        users     (subvec directory
                          (min (count directory)
                               (* offset *per-directory-page*))
                          (min (count directory)
                               (* (inc offset) *per-directory-page*)))]
    (when (> (count users) 0)
      (map process-directory-listing users))))

(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 (poll *directory-list*)))
      (.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-vip
   (let [st (fetch-template "topic_list" session)]
     (.setAttribute st "rooms"
                    (map topic-map-from-room (vals @rooms)))
     (.toString st))))

(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]
  (if-vip
   (let [room     (lookup-room (params :room))
         topic    (params :topic)
         deadline (params :deadline)
         maker    (params :maker)]
     (cond (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]
  (if-vip
   (if-let [room (lookup-room (params :room))]
     (do
       (end-topic! room)
       (resp-success "OK"))
     (resp-error "INVALID_ROOM"))))

;; Chat

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chat format version history
;
; v0: Keys:   users, messages, timestamp
;     Date:   Mists of dump antiquity
;
; v1: Keys:   users, messages, timestamp, v
;     Date:   2010/04/25
;     Note:   Incorporates explicit version

(def *chat-version-number* 1)

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

(defn chat [session room template]
  (let [now              (System/currentTimeMillis)
        nick             (session :nick)
        st               (fetch-template template session)
        limit            (if (:admin_only room) *vip-dumps-per-page* *dumps-per-page*)
        message-list     (reverse (tags/fetch-dumps-by-room :room-id (room :room_id)
                                                            :image-only false
                                                            :amount limit))
        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 "version" *chat-version-number*)
    (.setAttribute st "roomname" (room :name))
    (.setAttribute st "timestamp" now)
    (.toString st)))

(defn validated-chat [session room-key template]
  (let [room-key   (if (= (lower-case room-key) "www") *default-room* room-key)]
    (if (validate-room-access room-key session)
      (chat session (lookup-room 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 :v *chat-version-number*)))))

(defn validated-refresh [session params]
  (let [room-key (params :room)
        room (lookup-room 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|svg)$")

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

; TODO: is-image? is broken for messages w/ multiple image links.

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

(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)
         mute         ((poll *active-mutes*) user-id)
         nick         (session :nick)
         room-key     (params :room)
         room         (lookup-room room-key)
         content      (.trim (params :content))
         now          (new Date)]
     (cond (not room) (resp-error "BAD_ROOM")
           (not nick) (resp-error "NOT_LOGGED_IN")
           mute       (resp-error (format-mute mute))
           :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

;; TODO: make work for all rooms
(defn browser [session]
  (let [room  (lookup-room *default-room*)
        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)
    (.setAttribute st "version" *chat-version-number*)
    (.toString st)))


;; Chat Log

(defn log [session room offset params]
  (let [roomkey     (room :key)
        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)
    (if (default-room? roomkey)
      (.setAttribute st "roomkey" "")
      (.setAttribute st "roomkey" (str roomkey ".")))
    (.setAttribute st "roomname" (room :name))
    (.setAttribute st "debug_log_items" (logger))
    (.toString st)))

(defn validated-log [session room-key offset params]
  (let [room-key (if (= (lower-case room-key) "www") "dumpfm" room-key)]
    (if (validate-room-access room-key session)
      (log session (lookup-room 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-request-page [session]
  (.toString (fetch-template "req_reset" session)))

(defn reset-request! [session {nick :nick}]
  (if-let [info   (fetch-nick nick)]
    (let [email  (info :email)
          hash   (info :hash)
          ts     (System/currentTimeMillis)
          token  (reset-token nick hash ts)
          link   (reset-link nick token ts)]
      (do (send-reset-email nick email link)
          (resp-success "OK")))
    (resp-error "NO_NICK")))

(defn reset-page [session params]
  (let [st    (fetch-template "reset" session)
        nick  (params :nick)
        ts    (maybe-parse-long (params :ts) 0)
        token (params :token)
        valid (valid-reset-link? nick token ts)]
    (.setAttribute st "valid_request" valid)
    (.setAttribute st "nick" nick)
    (when valid
      (.setAttribute st "link" (reset-link nick token ts)))
    (.toString st)))

(defn reset-account! [session params]
  (let [nick   (params :nick)
        ts     (maybe-parse-long (params :ts) 0)
        token  (params :token)
        hash   (params :hash)]
    (if (and (valid-reset-link? nick token ts) hash)
      (let [info (fetch-nick nick)]
        (update-nick-hash nick hash)
        [(session-assoc-from-db info)
         (redirect-to "http://dump.fm/")])
      [200 "BAD_REQUEST"])))

;; Upload

(def *max-image-dimensions* [2000 2000])
(def *max-avatar-dimensions* [2000 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 invalid-image-dimensions? [f [max-width max-height]]
  (try 
   (let [i (ImageIO/read f)
         height (.getHeight i)
         width (.getWidth i)]
     (if (or (> width max-width)
             (> height max-height))
       (str "INVALID_RESOLUTION "  max-width " " max-height)))
   (catch Exception _ "INVALID_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-file [f vip]
  (or (is-file-too-big? f vip)
      (invalid-image-dimensions? f *max-image-dimensions*)))


; Upload notes:
; The webcam code doesn't feature an error handler,
; so all upload responses not equal to "OK" are considered
; errors.
; The upload code doesn't use jQuery.ajax, and doesn't JSON-eval
; responses. Therefore, return strings should not be JSON-encoded.

(defn do-upload [session image room]
  (if-let [err (validate-upload-file (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)
        [200 "OK"]))))

(defn upload [session params]
  (let [room-key   (params :room)
        nick       (session :nick)
        user-id    (session :user_id)
        image      (params :image)
        mute       ((poll *active-mutes*) user-id)
        has-access (validate-room-access room-key session)]
    (cond (not nick)       [200 "NOT_LOGGED_IN"]
          (not image)      [200 "INVALID_REQUEST"]
          mute             [200 (format-mute mute)]
          (not has-access) [200 "UNKNOWN_ROOM"]
          :else (do-upload session image (lookup-room 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 serve-static [dir path]
  ; TODO: cache 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 "http://:sub.dump.fm/"     (validated-chat session (params :sub) "chat"))
  (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub) "chat"))
  (GET "/:room/chat"              (validated-chat session (params :room) "chat"))
  (GET "/chat"                    (validated-chat session *default-room* "chat"))
  (GET "/chat/:t"                 (validated-chat session *default-room* (params :t)))

  (GET "http://:sub.dump.fm/log"         (validated-log session (params :sub) "0" params))
  (GET "http://:sub.dump.fm/log/:offset" (validated-log session (params :sub) (params :offset) params))
  (GET "/log"                            (validated-log session *default-room* "0" params))
  (GET "/log/:offset"                    (validated-log session *default-room* (params :offset) params))
  (GET "/:room/log"                      (validated-log session (params :room) "0" params))
  (GET "/:room/log/:offset"              (validated-log session (params :room) (params :offset) params))

  (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))
  
  ; have to put this route after favs
  (GET "/u/:nick/:offset" (profile session (params :nick) (params :offset)))
  
  (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 "/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))

  ;; 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 (params :offset) 0)))
  (GET "/reset-request" (reset-request-page session))
  (POST "/reset-request" (reset-request! session params))
  (GET  "/reset" (reset-page session params))
  (POST "/reset" (reset-account! session params))

  ;; Admin stuff (should be own route?)
  (GET "/debug" (debug-page session flash))
  (POST "/debug" (debug-commmand! session params))
  (GET "/mutes" (show-mutes session))
  (POST "/mute" (mute! session params))
  (POST "/cancel-mute" (handle-cancel-mute! session params))
  (GET "/feed-test" (feed-test-page session))
  (POST "/feed-test" (feed-test session params))
  (GET "/profile-test/:t" (profile session "ryder" "0" (params :t)))

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

  ;; Put username routes below all others in priority
  (GET "/zoeee/nudes"     (zoeee-nudes session))
  (GET "/:nick"           (profile session (params :nick) "0"))
  (GET "/:nick/"          (profile session (params :nick) "0"))
  (GET "/:nick/:offset"   (profile session (params :nick) (params :offset)))
  (GET "/" (landing 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"
   "svg"  "image/svg+xml"
   "swf"  "application/x-shockwave-flash"
   "txt"  "text/plain"
   "xml"  "text/xml"
   "zip"  "application/zip"})

(decorate static
  (with-mimetypes {:mimetypes mimetypes}))

(def *session-cookie-params* {:type :memory
                              :expires (* 60 60)
                              :domain ".dump.fm"})

(decorate pichat
  (with-mimetypes {:mimetypes mimetypes})
  (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
  (with-session *session-cookie-params*))

(decorate multipart
  (with-mimetypes {:mimetypes mimetypes})
  (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
  (with-session *session-cookie-params*)
  (with-multipart))


;;; Startup Code

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

(load-rooms!)
(start-server (options :port))
(start-user-flusher!)
(start-session-pruner!)