path: root/src/utils.clj

(ns utils
  (:import java.text.SimpleDateFormat
           java.net.URL
           java.util.Date
           java.util.TimeZone
           java.io.File
           java.net.URLDecoder
           javax.sql.DataSource
           javax.crypto.Cipher
           javax.crypto.spec.SecretKeySpec
           javax.crypto.KeyGenerator
           javax.crypto.Mac
	   org.postgresql.ds.PGPoolingDataSource
           org.apache.commons.codec.binary.Base64
           org.apache.commons.codec.digest.DigestUtils
           org.antlr.stringtemplate.StringTemplateGroup)
  (:use clojure.contrib.json.write
        clojure.contrib.sql
        clojure.contrib.def
        clojure.contrib.duck-streams
        clojure.contrib.seq-utils
        clojure.contrib.str-utils
        compojure
        config))

(let [db-host "localhost"
      db-name "dumpfm"
      db-user "postgres"
      db-pass "root"]
  ; TODO: use c3p0 for pooling?
  (def *db* {:datasource (doto (new PGPoolingDataSource)
                           (.setServerName   db-host)
                           (.setDatabaseName db-name)
                           (.setUser         db-user)
                           (.setPassword     db-pass)
                           (.setMaxConnections 10))}))


;; Misc

(defn except! [& more]
  (throw (Exception. (apply str more))))

(defn download-http-url [u]
  (let [url (URL. u)]
    (if (= (.getProtocol url) "http")
      (slurp* url)
      (throw (Exception. (str "Invalid url " u))))))

(defn get-ip [request]
  (let [ip (get (:headers request) "x-real-ip")  ; behind nginx
        ip (if ip ip (:remote-addr request))] (str ip))  ; deployed locally
)

(defn append [& seqs]
  (reduce into (map vector seqs)))

(defn transpose [lsts]
  (apply (partial map vector) lsts))

(declare stringify-and-escape)
(defn escape-html-deep [o]
  (cond (map? o)         (stringify-and-escape o)
        (vector? o)      (map escape-html-deep o)
        (seq? o)         (map escape-html-deep o)
        (true? o)        o
        (false? o)       o
        :else            (escape-html o)))

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

(defn nor [& args]
  (not-any? identity args))

(defn ms-in-future [ms]
  (+ ms (System/currentTimeMillis)))

(defn swap [f]
  (fn [& more] (apply f (reverse more))))

(defn join [lst int]
  (apply str (interpose int lst)))

(defn non-empty-string? [s]
  (cond (string? s) (> (count s) 0)
        :else s))

(defn seconds [t] (* t 1000))
(defn minutes [t] (* 60 (seconds t)))
(defn hours   [t] (* 60 (minutes t)))
(defn days    [t] (* 24 (hours t)))

(defn ms-ago [ms]
  (- (System/currentTimeMillis) ms))

(defn kbytes [b] (* b 1024))
(defn mbytes [b] (* b 1024 1024))

(defn open-file [dir-comps filename]
  (let [d (str-join (System/getProperty "file.separator")
                    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)))

(defmacro with-timing [e]
  `(let [s# (System/nanoTime)
         r# ~e
         f# (System/nanoTime)]
     [(int (/ (- f# s#) 1e6)) r#]))


(def truncation-factor 2)

(defn insert-and-truncate! [list-ref item soft-limit]
  (if (> (count @list-ref) (* soft-limit truncation-factor))
    (ref-set list-ref
	     (cons item (take soft-limit @list-ref)))
    (ref-set list-ref (cons item @list-ref))))

;; Formatters

(defn comma-format [i]
  (.format (java.text.DecimalFormat. "#,###") i))
  
(def yyyy-formatter (new SimpleDateFormat "yyyy"))
(def yyyy-mm-formatter (new SimpleDateFormat "yyyy-MM"))
(def yyyy-mm-dd-formatter (new SimpleDateFormat "yyyy-MM-dd"))
(def yymmdd-formatter (new SimpleDateFormat "yyyyMMdd"))

(doseq [f [yyyy-formatter yyyy-mm-formatter yyyy-mm-dd-formatter yymmdd-formatter]]
  (.setLenient f false))

(defn format-yyyy-mm-dd [d]
  (.format yyyy-mm-dd-formatter d))

(defn format-yyyymmdd [d]
  (.format yymmdd-formatter d))

(defn today []
  (format-yyyymmdd (new Date)))

(def timestamp-formatter (new SimpleDateFormat "h:mm a EEE M/d"))
(def date-first-timestamp-formatter (new SimpleDateFormat "M/d h:mm a"))

(defn format-timestamp [d]
  (.format timestamp-formatter d))

(defn format-date-first-timestamp [d]
  (.format date-first-timestamp-formatter d))

(defn pluralize [word val]
  (if (= val 1) word (str word "s")))

(defn format-interval [i]
  (let [vals    [(.getYears i)
                 (.getMonths i)
                 (.getDays i)
                 (.getHours i)
                 (.getMinutes i)]
        labels  ["year" "month" "day" "hour" "minute"]
        arr     (into [] (for [[l v] (map vector labels vals) :when (> v 0)]
                           (str v " " (pluralize l v))))]
    (str-join ", " arr)))

(defn apply-formats [formats d]
  (into {} (for [[k v] d]
             (if-let [f  (formats k)]
               [k (f v)]
               [k v]))))

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

;; JSON responses

(defmethod print-json Date
  [d]
  (print-json (format-yyyy-mm-dd d)))

(defn resp-error [message]
  {:status 400 :headers {} :body message})

(defn resp-success [message]
  {:status 200 :headers {} :body (json-str message)})

;; Database

(defn to-sql-date [dt]
  (java.sql.Date. (.getTime dt)))

(defn join-clauses [clauses]
  (if clauses
    (let [clause-func (fn [c]
                        (cond (string? c) [c []]
                              (vector? c) [(first c) (rest c)]
                              :else (except! "Invalid query-clause: " c)))
          pairs          (for [c clauses :when c]
                           (clause-func c))
          [clauses vars] (transpose pairs)]
      [clauses
       (apply concat vars)])
    [[] []]))

(defnk build-query [:select nil :from nil
                    :where nil :ljoin nil
                    :order nil :limit nil :indent "    "]
  (cond
   (not select) (except! "Invalid query missing SELECT")
   (not from)   (except! "Invalid query missing FROM")
   (not where)  (except! "Invalid query missing WHERE")
   :else (let [[sel-cls sel-var]     (join-clauses select)
               [from-cls from-var]   (join-clauses from)
               [ljoin-cls ljoin-var] (join-clauses ljoin)
               [where-cls where-var] (join-clauses where)]
           (vec
            (concat
             [(str "SELECT\n" indent
                   (str-join (str ",\n" indent) sel-cls)
                   "\nFROM\n" indent
                   (str-join (str ",\n" indent) from-cls)
                   (if ljoin
                     (str-join "" (map #(str "\nLEFT JOIN " %) ljoin-cls)))
                   "\nWHERE\n" indent
                   (str-join (str " AND\n" indent) where-cls)
                   (if order (str "\nORDER BY " order) "")
                   (if limit (str "\nLIMIT " limit) ""))]
             sel-var from-var ljoin-var where-var)))))
  
(defn do-cmds [query]
  (with-connection *db*
    (do-commands query)))

(defn do-prepared! [& args]
  (with-connection *db*
    (apply do-prepared args)))

(defn do-update [& args]
  (with-connection *db*
    (apply update-values args)))

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

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

(defn do-delete [table query]
  (with-connection *db*
    (delete-rows table query)))

(defn do-insert [table cols values]
  (with-connection *db*
    (insert-values table cols values)))

(defn assert-update
  ([res ok err] (if (not (= (first res) 1)) err ok))
  ([res] (assert-update res true false)))

(defn sql-array [type arr]
  (with-connection *db*
    (.createArrayOf (connection) type (into-array arr))))

(defn execute-query! [query & objects]
  (with-connection *db*
    (let [stmt (.prepareStatement (connection) query)]
      (doseq [[i o] (map vector (iterate inc 1) objects)]
        (.setObject stmt i o))
      (.executeQuery stmt))))

;; Crypto

(def b64codec (Base64.))

(defn b64enc [bytes]
  (.encodeToString b64codec bytes))

(defn b64dec [s]
  (.decode b64codec s))

(defn generate-aes-key [bits]
  (let [kgen (doto (KeyGenerator/getInstance "AES")
               (.init bits))
        skey (.generateKey kgen)]
    (.getEncoded skey)))

(defn aes-encoder [secret]
  (let [spec      (SecretKeySpec. secret "AES")
        cipher    (Cipher/getInstance "AES")]
    (.init cipher Cipher/ENCRYPT_MODE spec)
    (fn [input]
      (.doFinal cipher input))))

(defn aes-decoder [secret]
  (let [spec      (SecretKeySpec. secret "AES")
        cipher    (Cipher/getInstance "AES")]
    (.init cipher Cipher/DECRYPT_MODE spec)
    (fn [input]
      (.doFinal cipher input))))


(defn make-signer [secret]
  (let [algo "HmacSHA1"
        spec (SecretKeySpec. (.getBytes secret) algo)
        mac  (Mac/getInstance algo)]
    (.init mac spec)
    (fn [input] (.doFinal mac (.getBytes input)))))

;; Parsing

(defn maybe-parse-int 
  ([s] (maybe-parse-int s 0))
  ([s a]
     (if (number? s)
       (int s)
       (try (Integer/parseInt s)
            (catch NumberFormatException _ a)))))

(defn maybe-parse-long
  ([s]   (maybe-parse-long s 0))
  ([s a]
     (if (number? s)
       (long s)
       (try (Long/parseLong s)
            (catch NumberFormatException _ a)))))

(defn parse-yyyy-mm-dd-date [s]
  (try (.parse yyyy-mm-dd-formatter s)
       (catch java.text.ParseException _ nil)))
  
(defn parse-flexi-date
  "Accepts date strings as YYYY, YYYY-MM, or YYYY-MM-DD."
  [s]
  (let [parse-f (fn [f l] (try [(.parse f s) l]
                               (catch java.text.ParseException _ nil)))]
    (or (parse-f yyyy-mm-dd-formatter :day)
        (parse-f yyyy-mm-formatter :month)
        (parse-f yyyy-formatter :year))))

(defn url-decode [text]
  (URLDecoder/decode text "UTF-8"))

; TODO: this duplicates str-utils, should be removed
(defn #^String lower-case
  "Converts string to all lower-case."
  [#^String s]
  (.toLowerCase s))

;; 404

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

;; Templates

(def template-group (new StringTemplateGroup "dumpfm" "template"))
(.setRefreshInterval template-group 10)

(defn initialize-template [st session]
  (if (session :nick)
    (doto st
      (.setAttribute "user_email" (session :email))
      (.setAttribute "user_nick" (session :nick))
      (.setAttribute "user_avatar" (if (non-empty-string? (session :avatar))
				     (session :avatar) nil))
      (.setAttribute "isadmin" (session :is_admin))
      (.setAttribute "domain" config/*server-url*))
    (doto st
      (.setAttribute "domain" config/*server-url*))))

(defn fetch-template [template session]
  (try
    (let [st (.getInstanceOf template-group template)]
      (initialize-template st session))
    (catch Exception e
      nil)))

(defn fetch-template-fragment [template]
  (.getInstanceOf template-group template))

(defn serve-template [template session]
  (.toString (fetch-template template session)))

;; VIP

(defn is-vip? [session]
  (session :is_admin))

(def super-vips #{"timb" "scottbot" "ryder"})

(defn is-super-vip? [session]
  (contains? super-vips (:nick session)))

(defmacro if-vip
  "Evaluates expr if user is super-vip otherwise returns 404. Can only be used
   where session is defined."
  ([e]
     `(if (is-vip? ~'session) ~e (unknown-page)))
  ([e alt]
     `(if (is-vip? ~'session) ~e ~alt)))

(defmacro if-super-vip [e]
  "Evaluates expr if user is super-vip otherwise returns 404. Can only be used
   where session is defined."
  `(if (is-super-vip? ~'session) ~e (unknown-page)))


;; Time-expiry memoize
;; http://www.mail-archive.com/clojure@googlegroups.com/msg20038.html

(defn expire-cached-results* [cached-results time-to-live]
  "Expire items from the cached function results."
  (into {}
    (filter (fn [[k v]]
      (> time-to-live
        (- (System/currentTimeMillis) (:time v)))) cached-results)))

(defn ttl-memoize
  "Returns a memoized version of a referentially transparent function. The
  memoized version of the function keeps a cache of the mapping from arguments
  to results and, when calls with the same arguments are repeated often, has
  higher performance at the expense of higher memory use. Cached results are
  removed from the cache when their time to live value expires."
  [function time-to-live]
  (let [cached-results (atom {})]
    (fn [& arguments]
      (swap! cached-results expire-cached-results* time-to-live)
      (if-let [entry (find @cached-results arguments)]
        (:result (val entry))
        (let [result (apply function arguments)]
          (swap! cached-results assoc arguments
            { :result result :time (System/currentTimeMillis)})
          result)))))

;; Taken from Programming Clojure by Stuart Halloway

(defn index-filter [pred coll]
  (for [[idx elt] (indexed coll) :when (pred elt)] idx))

(defn index-of [pred coll]
  (first (index-filter pred coll)))