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-name "dumpfm"
      db-user "postgres"
      db-pass "root"]
  (def *db* {:datasource (doto (new PGPoolingDataSource)
                           (.setServerName   db-server)
                           (.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 keywordify [m]
  (zipmap (map keyword (keys m)) (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 "hh:mm a EEE M/d"))
(def date-first-timestamp-formatter (new SimpleDateFormat "yy/MM/dd HH:mm"))

(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 build-interval-table [i]
  [[(.getYears i)   "year"  ]
   [(.getMonths i)  "month" ]
   [(.getDays i)    "day"   ]
   [(.getHours i)   "hour"  ]
   [(.getMinutes i) "minute"]])

(defn format-friendly-interval [i]
  (if-let [[val unit] (first
                       (filter #(> (first %) 0)
                               (build-interval-table i)))]
    (format "%s %s" (inc val) (pluralize unit (inc val)))))

(defn format-interval [i]
  (let [arr     (into [] (for [[v l] (build-interval-table i) :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] (= (first res) 1)))

(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 to-int [x]
  (cond (integer? x) x
        (string? x) (Integer/parseInt x)
        :else (throw (Exception. (str "Invalid argument " x)))))

(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]
  (.setAttribute st "domain" config/*server-url*)
  (doto st
    ; user_nick is used in some templates to test if user is logged in,
    ; and stringtemplate only recognizes variables set to false, not nil.
    (.setAttribute "logged_in" (not (nil? (:nick session))))
    (.setAttribute "user_nick" (or (:nick session) false))
    (.setAttribute "user_email" (:email session))
    (.setAttribute "user_avatar" (if (non-empty-string? (:avatar session))
                                   (:avatar session)
                                   nil))
    (.setAttribute "isadmin" (:is_admin session))))

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

;; Misc index/sorting funcs

(defn sort-by-index-in
  ([c1 c2]       (sort-by-index-in c1 c2 nil nil))
  ([c1 c2 f1]    (sort-by-index-in c1 c2 f1 nil))
  ([c1 c2 f1 f2]
     (let [c2-map     (zipmap (if f2 (map f2 c2) c2)
                              (range (count c2)))
           sort-func  (if f1
                        #(get c2-map (f1 %))
                        #(get c2-map %))]
       (sort-by sort-func c1))))