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.seq-utils
        clojure.contrib.sql
        clojure.contrib.str-utils
        clojure.contrib.def
        config
        admin
        compojure
        email
        utils
        cookie-login
        session-sweeper
        feed
        rooms
        tags
        scheduled-agent
        user))

; 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

;; http://snippets.dzone.com/posts/show/6995
(def 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 is-image? [word]
  (and (re-find url-regex word)
       (re-find pic-regex word)))

(defn classify-msg [msg]
  (let [words (.split msg " ")
        imgs  (map is-image? words)]
    (cond (every? boolean imgs) :image
          (some boolean imgs)   :mixed
          :else                 :text)))

(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 ts]
  (reverse (take-while #(.after (% :created_on) ts) 
                       @(room :messages))))

(defn new-favs [nick ts]
  (filter #(.after (:added %) ts)
          (get @fav-map nick [])))

(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 sort?]
  (let [users (vals @(room :users))]
    (map process-user (if sort?
			(sort-by (fn [u] (.toLowerCase (:nick u))) users)
			users))))

(defn updates [nick room ts]
  {"users"    (prepare-user-list room false) ; Sorting is done on client
   "messages" (map process-message-for-json
                   (new-messages room ts))
   "favs"     (new-favs nick ts)})

(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-message-by-id [m-id]
  (let [query "SELECT m.message_id, m.content, m.created_on, m.user_id,
                      u.nick, u.avatar, r.key, r.admin_only
               FROM messages m, users u, rooms r
               WHERE m.user_id = u.user_id
               AND r.room_id = m.room_id
               AND m.message_id = ?"]
    (first (do-select [query (maybe-parse-int m-id -1)]))))

(defn fetch-public-message-by-id [m-id]
  (let [msg (fetch-message-by-id m-id)]
    (if (and msg (not (:admin_only msg)))
      msg)))

;;  User-id/nick cache
;;  I keep needing to grab user-id from a nick so I thought I'd cache them
;;  @timb: I just duplicated this in the user-info map :(
;;         we should reconcile our user caches
(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 *cookie-domain*)))

;; 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 *cookie-domain*)
   (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 *user-info-query* "
SELECT u.nick,
       u.user_id,
       u.avatar,
       LAST.content,
       LAST.message_id
FROM   users u
       LEFT JOIN messages LAST
         ON u.user_id = LAST.user_id
            AND LAST.created_on = (SELECT MAX(created_on)
                                   FROM   messages
                                   WHERE  user_id = u.user_id
                                          AND room_id != 2
                                          AND is_image)
")


(defn build-user-info-map []
  (let [res (do-select [*user-info-query*])]
    (zipmap (map :nick res) res)))

(defn build-score-list []
  (let [res (vec (do-select [*score-query*]))]
    {:list res
     :map  (zipmap (map :nick res) (map :cnt res))}))

(def *scores-refresh-period-sec* (* 30 60))
(def *user-info-refresh-period-sec* 300)

(def *user-scores*
     (scheduled-agent build-score-list
                      *scores-refresh-period-sec*
                      []))

(def *user-info*
     (scheduled-agent build-user-info-map
                      *user-info-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))

(defn lookup-score [nick]
  (if (= (lower-case nick) "scottbot")
    -1
    (let [scores (:map (poll *user-scores*))]
      (get scores nick 0))))

; TODO: merge w/ user/fetch-nick
(defn lookup-user-info [nick]
  (if-let [i (get (poll *user-info*) nick)]
    (if-let [score (lookup-score nick)]
      (assoc i :score (lookup-score nick)
               :score_ent (score-to-entity score))
      i)
    {}))

(defn get-user-ranking [offset num]
  (let [ranking  (:list (poll *user-scores*))
        count    (count ranking)]
    (subvec ranking
            (min count (* offset num))
            (min count (* (inc offset) num)))))


;; Profile

(defn take-random-image [content]
  (let [imgs (filter is-image? (.split content " "))]
    (if (empty? imgs) nil (rand-elt imgs))))

(defn msg-transformer [key f]
  (fn [msg] (assoc msg key (f (msg key)))))

(defn count-dumps-posted [nick]
  (:count
   (first 
    (do-select ["select count(*) from messages m, users u
                 where m.user_id = u.user_id and lower(u.nick) = ?
                 and m.is_image = true" (.toLowerCase nick)]))))

(defn count-dumps-user-faved [nick]
  (:count
   (first
    (do-select ["select count(distinct(m.message_id)) from users u, tags t, messages m
                 where lower(u.nick) = ? and u.user_id = t.user_id
                 and t.tag = 'favorite'
                 and t.message_id = m.message_id and m.is_image = true"
		(.toLowerCase nick)]))))

(defn recently-faved [nick]
  (do-select ["select distinct(u2.avatar, u2.nick) from users u, tags t, messages m, users u2
               where lower(u.nick) = ? and u.user_id = t.user_id and t.message_id = m.message_id
               and m.user_id = u2.user_id order by t.created_on, u2.avatar, u2.nick limit 4"
	      (.toLowerCase nick)]))

(defn profile
  ([session profile-nick] (profile session profile-nick "profile"))
  ([session profile-nick 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))
	     dump-cnt      (count-dumps-posted profile-nick)
	     fav-from-cnt  (count-dumps-user-faved profile-nick)
             score         (lookup-score profile-nick)
	     raw-dumps     (logger tags/fetch-dumps-by-nick
				   :nick profile-nick
				   :image-only true
				   :amount 5)
	     dumps         (logger doall
				   (map (comp process-message-for-output
					      (msg-transformer :content take-random-image)
					      tags/remove-tags-for-output
					      tags/add-favorited-flag)
					(take 5 raw-dumps) (repeat 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 "score" (comma-format score))
	   (.setAttribute st "score_ent" (score-to-entity score))
	   (.setAttribute st "dump_cnt" (comma-format dump-cnt))
	   (.setAttribute st "dumps_user_faved_cnt" (comma-format fav-from-cnt))
	   (if (not (empty? dumps))
	     (.setAttribute st "dumps" dumps))
	   (.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")))))

;; User log

(defn build-mini-profile [user-info]
  (let [st    (fetch-template-fragment "mini_profile")
	nick  (user-info :nick)
	score (lookup-score nick)]
    (doseq [a [:nick :avatar :contact :bio]]
      (let [v (user-info a)]
	(.setAttribute st (name a)
		       (if (non-empty-string? v) (escape-html v)))))
    (doto st
      (.setAttribute "score" (comma-format score))
      (.setAttribute "score_ent" (score-to-entity score))
      (.setAttribute "dump_cnt" (comma-format (count-dumps-posted nick)))
      (.setAttribute "dumps_user_faved_cnt" (comma-format (count-dumps-user-faved nick)))
      (.toString))))
  
(defn user-log [session profile-nick offset]
  (if-let [user-info (fetch-nick profile-nick)]
    (let [st            (fetch-template "userlog" session)
	  profile-nick  (:nick user-info) ; Update to get right casing
	  nick          (session :nick)
	  logger        (make-time-logger)
	  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))]
      (.setAttribute st "nick" profile-nick)
      (.setAttribute st "is_home" (= nick profile-nick))
      (.setAttribute st "mini_profile" (build-mini-profile user-info))
      (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")))

;; Directory

(def *per-directory-page* 25)

(defn process-directory-entry [entry]
  (let [info (lookup-user-info (:nick entry))]
    (assoc (stringify-and-escape info)
      "score_ent" (:score_ent info))))

(defn get-directory-info [offset]
  (map process-directory-entry
       (get-user-ranking offset
                         *per-directory-page*)))
    
(defn directory [session offset]    
  (let [st     (fetch-template "directory" session)
        users  (get-directory-info 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)))
    (.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")))


;; 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]
  (if-let [room (lookup-room room-key)]
    (or (not (room :admin_only))
	(is-vip? session))))

(defn chat [session room template]
  (if-let [st (fetch-template template session)]
    (let [now              (System/currentTimeMillis)
	  nick             (session :nick)
	  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)))
      (doto st
	(.setAttribute "users" (prepare-user-list room true))
	(.setAttribute "messages" message-list)
	(.setAttribute "roomkey" (room :key))
	(.setAttribute "isadminroom" (room :admin_only))
	(.setAttribute "json_room_key" (json-str (room :key)))
	(.setAttribute "json_user_nick" (if nick (json-str nick) "null"))
	(.setAttribute "version" *chat-version-number*)
	(.setAttribute "roomname" (room :name))
	(.setAttribute "timestamp" now))
      (.toString st))
    [404 "UNKNOWN PAGE"]))

(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)
         old-ts   (new Date (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 users assoc nick (user-struct-from-session session))))
     (resp-success (assoc (updates nick room old-ts)
		          :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"))))

;; admins can post arbitrary html if wrapped in <safe>
;; this is temporary so that i can test generating html messages
(defn validated-content [content session]
  (if (.startsWith content "<safe>")
      (if (is-vip? session)
          (str content)
          (str "<unsafe>" content "</unsafe>"))
      (str content)))

(defn msg-db [user-id room-id content]
  (let [msg-type (classify-msg content)
        is-image (boolean (#{:image :mixed} msg-type))
        is-text  (boolean (#{:mixed :text} msg-type))
	qry      (str "INSERT INTO messages (user_id, room_id, content, is_image, is_text) "
		      "VALUES (?, ?, ?, ?, ?) RETURNING message_id")]
    (with-connection *db*
      ((first (do-select [qry user-id room-id content is-image is-text]))
       :message_id))))

(defn msg [session params]
   (let [user-id      (session :user_id)
         mute         (get (poll *active-mutes*) user-id)
         nick         (session :nick)
         room-key     (params :room)
         room         (lookup-room room-key)
         content      (.trim (params :content))]
     (cond (not room) (resp-error "BAD_ROOM")
           (not nick) (resp-error "NOT_LOGGED_IN")
           mute       (resp-error (format-mute mute))
           :else
	   (let [content  (validated-content content session)
	         msg-id (msg-db user-id (room :room_id) content)]
	     (dosync
              (if (not (contains? (ensure (room :users)) nick))
                (login-user (user-struct-from-session session) room))
              (add-message (build-msg nick content msg-id) 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 false)]
      (.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 msg tag]
  (try
   (do-insert "tags" 
              ["user_id" "message_id" "tag"]
              [(:user_id user) (msg :message_id) tag])
   (if (and (= tag "favorite")
            (not (= (msg :nick) (user :nick))))
     (insert-fav-notification! (msg :nick)
                               (user :nick)
                               (user :avatar)
                               (msg :content)))
   true
    ; catch error when inserting duplicate tags
   (catch Exception e false)))


(defn validated-add-tag [session params]
  (if (session :nick)
    (let [nick          (session :nick)
          user-id       (session :user_id)
          user-admin?   (session :admin-only)
          msg-id        (params :message_id)
          tag           (validate-tag (params :tag))
          msg           (fetch-message-by-id msg-id)
          access        (or (is-vip? session)
                            (not (:admin-only msg)))]
      (cond (not msg)      (resp-error "NO_MSG")
            (not access)   (resp-error "NO_MSG")
            (not tag)      (resp-error "NO_TAG")
            :else (if (add-tag session msg 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 info-bar
			                                       :message-user-id false
                                                               :tag-user-id false
                                                               :logger (make-time-logger)
                                                               :include-vip false]
  (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
                                                  :include-vip include-vip)
        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 "infobar" info-bar)
          (.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)
	user-id (user-id-from-nick nick)
	user-info (fetch-nick nick)
	info-bar (build-mini-profile user-info)
        tags (map url-decode (re-split #"\+" (undecoded-url-piece url 2)))
        url (str 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 info-bar :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]
  (if-let [user-info (fetch-nick (params :nick))]
    (let [nick (params :nick)
	  user-info (fetch-nick nick)
	  user-id (:user_id user-info)
	  avatar (:avatar user-info)
	  url (str nick "/favorites")
	  page-title (str nick "'s favorites")
	  infobar (build-mini-profile user-info)]
      (tagged-dumps-template session params "favorite" url page-title infobar
			     :tag-user-id user-id
			     :include-vip (is-vip? session)))
    "NO_USER"))

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

(defn ghetto-search-query [num-tokens]
  (str "select 
  content from messages, rooms
  where  messages.room_id=rooms.room_id 
    and content ilike " (str-join " and content ilike " (take num-tokens (repeat "?"))) "
    and content like '%http://%'
    and admin_only = 'f'
  order by message_id desc 
  limit 250;"))

(def *ghetto-search-regex* #"^[A-Za-z0-9\-_.+]*$")

(defn json-ghetto-search [undecoded-url-searchterms]
  (if (re-matches *ghetto-search-regex* undecoded-url-searchterms)
     (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms))
	   tokens (map #(str "%" %1 "%") tokens)
	   query (ghetto-search-query (count tokens))
	   rows (do-select (vec (concat [query] tokens)))] 
       (str "searchResult(" (json-str rows) ")"))
     (str "searchError('sorry, no fancy characters')")))

;; 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-upload-dimensions [2000 2000])
(def max-avatar-dimensions [800 800])
(def max-vip-file-size (mbytes 5)) ; don't be nuts guys
(def max-file-size (mbytes 1))
(def max-avatar-size (kbytes 500))

(defn is-file-too-big? [f limit]
  (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]
  (let [file-limit (if vip
		     max-vip-file-size
		     max-file-size)]
    (or (is-file-too-big? f file-limit)
	(invalid-image-dimensions? f max-upload-dimensions))))

(defn validate-avatar-file [f]
  (or (is-file-too-big? f max-avatar-size)
      (invalid-image-dimensions? f max-avatar-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       (get (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 (if-let [err (validate-avatar-file (:tempfile image))]
		  [200 err]
		  (do-upload-avatar session image)))))

(defn serve-meme [session meme]
  (if-let [st (fetch-template meme session)]
    (.toString st)
    (unknown-page)))

;; Compojure Routes

(defn serve-static [dir path]
  (if (= path "")
    (redirect-to "http://dump.fm")
    (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 "/r/:room/log"                      (validated-log session (params :room) "0" params))
  (GET "/r/: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)))
  (GET "/u/:nick/" (profile session (params :nick)))
  (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" (user-log session (params :nick) (params :offset)))
  
  (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid)))
  ;; TODO: these shouldn't be GETs
  (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 "/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  "/profile-test/:t" (profile session "ryder" (params :t)))

  (GET "/cmd/ghettosearch/:searchterm" (json-ghetto-search (undecoded-url-piece (request-url request) 2)))
  (GET "/search" (serve-template "search_files" session))

  ;; Memes
  (GET "/m/:m" (serve-meme session (params :m)))
  
  ;; 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 "/:nick"           (profile session (params :nick)))
  (GET "/:nick/"          (profile session (params :nick)))
  (GET "/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
  (GET "/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
  (GET "/:nick/favorites" (favorites session params))
  (GET "/:nick/favorites/:offset" (favorites session params))
  (GET "/:nick/favs" (favorites session params))
  (GET "/:nick/favs/:offset" (favorites session params))
  (GET "/:nick/log" (user-log session (params :nick) "0"))
  (GET "/:nick/log/:offset" (user-log session (params :nick) (params :offset)))
  (GET "/:nick/:offset"   (user-log 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 *cookie-domain*})

(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
               :nio  true}
              "/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! reserved-nicks)
(def server (start-server (options :port)))
(start! *user-scores*)
(start! *user-info*)
(start! *active-mutes*)

; Delay the following to reduce start-load
(Thread/sleep 3000)
(start-user-flusher!)
(start-session-pruner!)

(if (= *server-url* "http://dump.fm")
  (do (start! feed-downloader)
      (start! feed-inserter)))