;;;
;;;   Copyright 2015 Ruediger Gad
;;;
;;;   This software is released under the terms of the Eclipse Public License
;;;   (EPL) 1.0. You can find a copy of the EPL at:
;;;   http://opensource.org/licenses/eclipse-1.0.php
;;;

(ns
  ^{:author "Ruediger Gad",
    :doc "DSL for processing data"}
  dsbdp.data-processing-dsl
  (:require [dsbdp.byte-array-conversion :refer :all]
            [clojure.pprint :refer :all]))

(def ^:dynamic *incremental-indicator-suffix* "#inc")

(defn- create-proc-sub-fn
  "Create a sub part of a processing function.
   The data-processing-definition will be processed recursively.
   This function is responsible for actually resolving the given data processing functions.
   The input symbol will be placed as first argument on the innermost terms."
  [data-processing-definition input]
  (into
    '()
    (reverse
      (reduce
        (fn [v data-proc-def-element]
          (cond
            (symbol? data-proc-def-element)
              (let [s data-proc-def-element]
                (cond
                  (or (= s 'nth) (= s 'get))
                    (conj v (ns-resolve 'clojure.core s) 'input)
                  (ns-resolve 'clojure.core s)
                    (conj v (ns-resolve 'clojure.core s))
                  (ns-resolve 'dsbdp.byte-array-conversion s)
                    (conj v (ns-resolve 'dsbdp.byte-array-conversion s) 'input)
                  :default
                    (do
                      (println "Warning: Could not resolve symbol:" s)
                      (println "Assuming" s "is intended as \"self-reference\".")
                      (conj v s))))
            (list? data-proc-def-element)
              (conj v (into '() (reverse (create-proc-sub-fn data-proc-def-element input))))
            :default (conj v data-proc-def-element)))
        [] data-processing-definition))))

(defn- create-bindings-vector
  [input rules nesting-level]
  (reduce
    (fn [v rule]
      (let [rule-name (first rule)
            rule-expression (second rule)]
        (cond
          (list? rule-expression) (conj v
                                    (if (> 1 nesting-level)
                                      (first rule)
                                      (symbol (str "__" nesting-level "_" rule-name)))
                                    (create-proc-sub-fn rule-expression input))
          (and
            (vector? rule-expression)
            (every? vector? rule-expression)) (do
                                                ;(println "Binding: Got a VECTOR..." (first rule) (second rule))
                                                (into
                                                  (conj v
                                                        rule-name
                                                        nil)
                                                  (create-bindings-vector
                                                    input
                                                    rule-expression
                                                    (inc nesting-level))))
          :default (println "Binding: unknown element for rule:" (str rule)))))
    []
    rules))

(defn- create-let-expression
  [input rules body-vec]
  `(let
    ~(create-bindings-vector input rules 0)
    ~(reverse (into '() body-vec))))

(defn- create-let-body-vec-java-map-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (cond
        (list? (second rule)) (conj v
                                    `(.put
                                      ~(name (first rule))
                                      ~(if (> 1 nesting-level)
                                         (first rule)
                                         (symbol (str "__" nesting-level "_" (first rule))))))
        (and
          (vector? (second rule))
          (every? vector? (second rule))) (do
                                            ;(println "Java Map Body: Got a Vector..." (first rule) (second rule))
                                            (conj v
                                                  `(.put
                                                     ~(name (first rule))
                                                     ~(reverse (into '() (create-let-body-vec-java-map-out (second rule) nil (inc nesting-level)))))))
        :default (println "Java Map Body: unknown element for rule:" (str rule))))
    (if (nil? output)
      '[doto (java.util.HashMap.)]
      '[doto ^java.util.Map output])
    rules))

(defn- create-let-body-vec-clj-map-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (cond
        (list? (second rule)) (conj v
                                    `(assoc
                                      ~(name (first rule))
                                      ~(if (> 1 nesting-level)
                                         (first rule)
                                         (symbol (str "__" nesting-level "_" (first rule))))))
        (and
          (vector? (second rule))
          (every? vector? (second rule))) (do
                                            ;(println "Java Map Body: Got a Vector..." (first rule) (second rule))
                                            (conj v
                                                  `(assoc
                                                     ~(name (first rule))
                                                     ~(reverse (into '() (create-let-body-vec-clj-map-out (second rule) nil (inc nesting-level)))))))
        :default (println "Clj Map Body: unknown element for rule:" (str rule))))
    (if (nil? output)
      '[-> {}]
      '[-> output])
    rules))

(defn- create-let-body-vec-csv-str-out
  [rules output]
  (reduce
    (fn [v rule]
      (let [tmp-v (if (some #{:string} rule)
                    (conj v `(.append "\"") `(.append ~(first rule)) `(.append "\""))
                    (conj v `(.append ~(first rule))))]
        (if (not= rule (last rules))
          (conj tmp-v `(.append ","))
          tmp-v)))
    (if (nil? output)
      '[doto (java.lang.StringBuilder.)]
      '[doto ^java.lang.StringBuilder output])
    rules))

(defn- create-let-body-vec-json-str-out
  [rules output]
  (reduce
    (fn [v rule]
      (let [tmp-k (conj v `(.append "\"") `(.append ~(name (first rule))) `(.append "\":"))
            tmp-v (if (some #{:string} rule)
                    (conj tmp-k `(.append "\"") `(.append ~(first rule)) `(.append "\""))
                    (conj tmp-k `(.append ~(first rule))))]
        (if (not= rule (last rules))
          (conj tmp-v `(.append ","))
          (conj tmp-v `(.append "}")))))
    (if (nil? output)
      '[doto (java.lang.StringBuilder.) (.append "{")]
      '[doto ^java.lang.StringBuilder output (.deleteCharAt (- (.length ^java.lang.StringBuilder output) 1)) (.append ",")])
    rules))

(defn create-proc-fn
  "Create a data processing function based on the given dsl-expression.
   An example of a dsl-expression for processing a Clojure seq is given below:

   {:output-type :clj-map
    :rules [['myFloat '(nth 0)]
            ['myStr '(clojure.string/lower-case (nth 1)) :string]
            ['myRatio '(/ (nth 2) 100.0)]
            ['myStr2 '(str (nth 3) (nth 4)) :string]]}

   The resulting function will for the input [1.23 \"FOO\" 42 \"bar\" \"baz\"] produce the output {\"myFloat\" 1.23, \"myStr\" \"foo\", \"myRatio\" 0.42, \"myStr2\" \"barbaz\"}."
  [dsl-expression]
;  (println "Got DSL expression:" dsl-expression)
  (let [input-sym 'input
        output-type (name (:output-type dsl-expression))
        rules (:rules dsl-expression)
        output-sym (if (.endsWith output-type *incremental-indicator-suffix*)
                     'output)
        let-body-vec (condp (fn [^String v ^String s] (.startsWith s v)) output-type
                       "java-map" (create-let-body-vec-java-map-out rules output-sym 0)
                       "clj-map" (create-let-body-vec-clj-map-out rules output-sym 0)
                       "csv-str" (create-let-body-vec-csv-str-out rules output-sym)
                       "json-str" (create-let-body-vec-json-str-out rules output-sym)
                       (do
                         (println "Unknown output type:" output-type)
                         (println "Defaulting to :java-map as output type.")
                         (create-let-body-vec-java-map-out rules output-sym 0)))
;        _ (println "Created data processing function vector from DSL:" fn-body-vec)
        fn-body (create-let-expression input-sym rules let-body-vec)
;        _ (println "Created data processing function body:" fn-body)
        _ (pprint fn-body)
        _ (println "")
        data-processing-fn (if (not (nil? output-sym))
                             (eval `(fn [~input-sym ~output-sym] ~fn-body))
                             (eval `(fn [~input-sym] ~fn-body)))]
    data-processing-fn))

(defn combine-proc-fns
  "Based on the DSL expression dsl-expression, create a data processing function in which the processing rules starting at start-idx, inclusive, up to end-idx, non inclusive, are combined.
   Please note that it is usually more appropriate to use combine-proc-fns-vec."
  [dsl-expression start-idx end-idx]
  (if (= 0 start-idx)
    (create-proc-fn
      {:output-type (:output-type dsl-expression)
       :rules (subvec (:rules dsl-expression) start-idx end-idx)})
    (create-proc-fn
      {:output-type (keyword (str (name (:output-type dsl-expression)) *incremental-indicator-suffix*))
       :rules (subvec (:rules dsl-expression) start-idx end-idx)})))

(defn combine-proc-fns-vec
  "Based on the function mapping fn-mapping and the DSL expression dsl-expression, create a vector of data processing functions.
   The mapping definition defines the number of processing rules to be included in each processing function.
   For a vector of processing rules [a b c d e f], a mapping definition [1 2 3] will result in the following association of processing rules to processing functions f_x: [f_1(a), f_2(b, c), f_3(d e f)]."
  [fn-mapping dsl-expression]
  (reduce
    (fn [v m]
      (let [start-idx (reduce + (subvec fn-mapping 0 (count v)))]
        (conj v (combine-proc-fns dsl-expression
                                  start-idx
                                  (+ start-idx m)))))
    (let [f (combine-proc-fns dsl-expression 0 (first fn-mapping))]
      [(fn [in _] (f in))])
    (rest fn-mapping)))

;;;
;;;   Copyright 2015 Ruediger Gad
;;;
;;;   This software is released under the terms of the Eclipse Public License
;;;   (EPL) 1.0. You can find a copy of the EPL at:
;;;   http://opensource.org/licenses/eclipse-1.0.php
;;;

(ns
  ^{:author "Ruediger Gad",
    :doc "DSL for processing data"}
  dsbdp.data-processing-dsl
  (:require [dsbdp.byte-array-conversion :refer :all]
            [clojure.pprint :refer :all]))

(def ^:dynamic *incremental-indicator-suffix* "#inc")

(defn- create-proc-sub-fn
  "Create a sub part of a processing function.
   The data-processing-definition will be processed recursively.
   This function is responsible for actually resolving the given data processing functions.
   The input symbol will be placed as first argument on the innermost terms."
  [data-processing-definition input]
  (into
    '()
    (reverse
      (reduce
        (fn [v data-proc-def-element]
          (cond
            (symbol? data-proc-def-element)
              (let [s data-proc-def-element]
                (cond
                  (or (= s 'nth) (= s 'get))
                    (conj v (ns-resolve 'clojure.core s) 'input)
                  (ns-resolve 'clojure.core s)
                    (conj v (ns-resolve 'clojure.core s))
                  (ns-resolve 'dsbdp.byte-array-conversion s)
                    (conj v (ns-resolve 'dsbdp.byte-array-conversion s) 'input)
                  :default
                    (do
                      (println "Warning: Could not resolve symbol:" s)
                      (println "Assuming" s "is intended as \"self-reference\".")
                      (conj v s))))
            (list? data-proc-def-element)
              (conj v (into '() (reverse (create-proc-sub-fn data-proc-def-element input))))
            :default (conj v data-proc-def-element)))
        [] data-processing-definition))))

(defn- create-bindings-vector
  [input rules nesting-level]
  (reduce
    (fn [v rule]
      (let [rule-name (first rule)
            rule-expression (second rule)]
        (cond
          (list? rule-expression) (conj v
                                    (if (> 1 nesting-level)
                                      (first rule)
                                      (symbol (str "__" nesting-level "_" rule-name)))
                                    (create-proc-sub-fn rule-expression input))
          (and
            (vector? rule-expression)
            (every? vector? rule-expression)) (do
                                                ;(println "Binding: Got a VECTOR..." (first rule) (second rule))
                                                (into
                                                  (conj v
                                                        rule-name
                                                        nil)
                                                  (create-bindings-vector
                                                    input
                                                    rule-expression
                                                    (inc nesting-level))))
          :default (println "Binding: unknown element for rule:" (str rule)))))
    []
    rules))

(defn- create-let-expression
  [input rules body-vec]
  `(let
    ~(create-bindings-vector input rules 0)
    ~(reverse (into '() body-vec))))

(defn- create-let-body-vec-java-map-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (cond
        (list? (second rule)) (conj v
                                    `(.put
                                      ~(name (first rule))
                                      ~(if (> 1 nesting-level)
                                         (first rule)
                                         (symbol (str "__" nesting-level "_" (first rule))))))
        (and
          (vector? (second rule))
          (every? vector? (second rule))) (do
                                            ;(println "Java Map Body: Got a Vector..." (first rule) (second rule))
                                            (conj v
                                                  `(.put
                                                     ~(name (first rule))
                                                     ~(reverse (into '() (create-let-body-vec-java-map-out (second rule) nil (inc nesting-level)))))))
        :default (println "Java Map Body: unknown element for rule:" (str rule))))
    (if (nil? output)
      '[doto (java.util.HashMap.)]
      '[doto ^java.util.Map output])
    rules))

(defn- create-let-body-vec-clj-map-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (cond
        (list? (second rule)) (conj v
                                    `(assoc
                                      ~(name (first rule))
                                      ~(if (> 1 nesting-level)
                                         (first rule)
                                         (symbol (str "__" nesting-level "_" (first rule))))))
        (and
          (vector? (second rule))
          (every? vector? (second rule))) (do
                                            ;(println "Java Map Body: Got a Vector..." (first rule) (second rule))
                                            (conj v
                                                  `(assoc
                                                     ~(name (first rule))
                                                     ~(reverse (into '() (create-let-body-vec-clj-map-out (second rule) nil (inc nesting-level)))))))
        :default (println "Clj Map Body: unknown element for rule:" (str rule))))
    (if (nil? output)
      '[-> {}]
      '[-> output])
    rules))

(defn- create-let-body-vec-csv-str-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (let [tmp-v (if (some #{:string} rule)
                    (conj v `(.append "\"") `(.append ~(first rule)) `(.append "\""))
                    (conj v `(.append ~(first rule))))]
        (if (not= rule (last rules))
          (conj tmp-v `(.append ","))
          tmp-v)))
    (if (nil? output)
      '[doto (java.lang.StringBuilder.)]
      '[doto ^java.lang.StringBuilder output])
    rules))

(defn- create-let-body-vec-json-str-out
  [rules output nesting-level]
  (reduce
    (fn [v rule]
      (let [tmp-k (conj v `(.append "\"") `(.append ~(name (first rule))) `(.append "\":"))
            tmp-v (if (some #{:string} rule)
                    (conj tmp-k `(.append "\"") `(.append ~(first rule)) `(.append "\""))
                    (conj tmp-k `(.append ~(first rule))))]
        (if (not= rule (last rules))
          (conj tmp-v `(.append ","))
          (conj tmp-v `(.append "}")))))
    (if (nil? output)
      '[doto (java.lang.StringBuilder.) (.append "{")]
      '[doto ^java.lang.StringBuilder output (.deleteCharAt (- (.length ^java.lang.StringBuilder output) 1)) (.append ",")])
    rules))

(defn create-proc-fn
  "Create a data processing function based on the given dsl-expression.
   An example of a dsl-expression for processing a Clojure seq is given below:

   {:output-type :clj-map
    :rules [['myFloat '(nth 0)]
            ['myStr '(clojure.string/lower-case (nth 1)) :string]
            ['myRatio '(/ (nth 2) 100.0)]
            ['myStr2 '(str (nth 3) (nth 4)) :string]]}

   The resulting function will for the input [1.23 \"FOO\" 42 \"bar\" \"baz\"] produce the output {\"myFloat\" 1.23, \"myStr\" \"foo\", \"myRatio\" 0.42, \"myStr2\" \"barbaz\"}."
  [dsl-expression]
;  (println "Got DSL expression:" dsl-expression)
  (let [input-sym 'input
        output-type (name (:output-type dsl-expression))
        rules (:rules dsl-expression)
        output-sym (if (.endsWith output-type *incremental-indicator-suffix*)
                     'output)
        let-body-vec (condp (fn [^String v ^String s] (.startsWith s v)) output-type
                       "java-map" (create-let-body-vec-java-map-out rules output-sym 0)
                       "clj-map" (create-let-body-vec-clj-map-out rules output-sym 0)
                       "csv-str" (create-let-body-vec-csv-str-out rules output-sym 0)
                       "json-str" (create-let-body-vec-json-str-out rules output-sym 0)
                       (do
                         (println "Unknown output type:" output-type)
                         (println "Defaulting to :java-map as output type.")
                         (create-let-body-vec-java-map-out rules output-sym 0)))
;        _ (println "Created data processing function vector from DSL:" fn-body-vec)
        fn-body (create-let-expression input-sym rules let-body-vec)
;        _ (println "Created data processing function body:" fn-body)
        _ (pprint fn-body)
        _ (println "")
        data-processing-fn (if (not (nil? output-sym))
                             (eval `(fn [~input-sym ~output-sym] ~fn-body))
                             (eval `(fn [~input-sym] ~fn-body)))]
    data-processing-fn))

(defn combine-proc-fns
  "Based on the DSL expression dsl-expression, create a data processing function in which the processing rules starting at start-idx, inclusive, up to end-idx, non inclusive, are combined.
   Please note that it is usually more appropriate to use combine-proc-fns-vec."
  [dsl-expression start-idx end-idx]
  (if (= 0 start-idx)
    (create-proc-fn
      {:output-type (:output-type dsl-expression)
       :rules (subvec (:rules dsl-expression) start-idx end-idx)})
    (create-proc-fn
      {:output-type (keyword (str (name (:output-type dsl-expression)) *incremental-indicator-suffix*))
       :rules (subvec (:rules dsl-expression) start-idx end-idx)})))

(defn combine-proc-fns-vec
  "Based on the function mapping fn-mapping and the DSL expression dsl-expression, create a vector of data processing functions.
   The mapping definition defines the number of processing rules to be included in each processing function.
   For a vector of processing rules [a b c d e f], a mapping definition [1 2 3] will result in the following association of processing rules to processing functions f_x: [f_1(a), f_2(b, c), f_3(d e f)]."
  [fn-mapping dsl-expression]
  (reduce
    (fn [v m]
      (let [start-idx (reduce + (subvec fn-mapping 0 (count v)))]
        (conj v (combine-proc-fns dsl-expression
                                  start-idx
                                  (+ start-idx m)))))
    (let [f (combine-proc-fns dsl-expression 0 (first fn-mapping))]
      [(fn [in _] (f in))])
    (rest fn-mapping)))

Add nesting-level argument to JSON and CSV generation functions.


(ns kixi.hecuba.api.templates
  (:require [cheshire.core :as json]
            [clojure.set :as set]
            [clojure.tools.logging :as log]
            [kixi.hecuba.api.entities :as entities]
            [kixipipe.pipeline :as pipe]
            [kixipipe.storage.s3 :as s3]
            [kixi.hecuba.security :as sec]
            [kixi.hecuba.storage.db :as db]
            [kixi.hecuba.storage.sha1 :as sha1]
            [kixi.hecuba.web-paths :as p]
            [kixi.hecuba.webutil :as util]
            [kixi.hecuba.webutil :refer (request-method-from-context decode-body authorized? stringify-values update-stringified-lists sha1-regex uuid)]
            [liberator.core :refer (defresource)]
            [liberator.representation :refer (ring-response)]
            [qbits.hayt :as hayt]
            [kixi.hecuba.data.measurements.core :refer (get-status write-status)]
            [kixi.hecuba.data.measurements.download :as measurements-download]
            [clj-time.core :as t]))

(def ^:private templates-resource (p/resource-path-string :templates-resource))
(def ^:private entity-templates-resource (p/resource-path-string :entity-templates-resource))
(def ^:private uploads-status-resource-path (p/resource-path-string :uploads-status-resource))
(def ^:private downloads-status-resource-path (p/resource-path-string :downloads-status-resource))

(defn- payload-from
  ([multipart] (payload-from (uuid) multipart))
  ([id multipart]
     (let [{:strs [name template]} multipart
           {:keys [size tempfile content-type filename]} template]
       (cond-> {:name name
                :filename filename
                :template (slurp tempfile)}
               id (assoc :id id)))))

(defn- valid-template-request? [name {:keys [size tempfile content-type filename]}]
  (and (pos? size)
       tempfile
       content-type
       filename
       name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESOURCE FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-exists?

(defmulti index-exists? request-method-from-context)

(defmethod index-exists? :get [store ctx]
  (db/with-session [session (:hecuba-session store)]
    {::items (db/execute session (hayt/select :csv_templates))}))

(defmethod index-exists? :default [store ctx] true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; malformed?

(defmulti malformed? request-method-from-context :default :default)

(defmethod malformed? :post [ctx]
  (let [{:strs [name template]} (-> ctx :request :multipart-params)]
    (not (valid-template-request? name template))))

(defmethod malformed? :default [_] false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-post!

(defn index-post! [store ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [payload (payload-from (-> ctx :request :multipart-params))
          result  (db/execute session
                              (hayt/insert :csv_templates
                                           payload))]
      (log/info "Created new template with name " (:name result))
      {::location (format templates-resource (:id result))})))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-handle-ok?

(defn index-handle-ok [ctx]
    (let [items (::items ctx)]
    (util/render-items ctx items)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-handle-created?

(defn index-handle-created [ctx]
  (let [location (:location_id ctx)]
    {:headers {"Location" location}
     :body    (json/encode {:location location
                            :status "OK"
                            :version "4"})}))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-exists?

(defmulti resource-exists? request-method-from-context)

(defmethod resource-exists? :get [store ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [template_id (-> ctx :request :route-params :template_id)
          item (first (db/execute session
                           (hayt/select :csv_templates
                                        (hayt/where [[= :id template_id]]))))]
      (when item
        {::item item}))))

(defmethod resource-exists? :default [_ _] true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-respond-with-entity?

(defmulti resource-respond-with-entity? request-method-from-context)

(defmethod resource-respond-with-entity? :default [_] true)
(defmethod resource-respond-with-entity? :delete [_] false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-put!

(defn resource-put! [store {request :request}]
  (db/with-session [session (:hecuba-session store)]
    (let [{:keys [multipart-params route-params]} request
          template_id                             (:template_id route-params)]
      (log/info "executing...")
      (let [result (db/execute session (hayt/update :csv_templates
                                                    (hayt/set-columns (payload-from nil multipart-params))
                                                    (hayt/where [[= :id template_id]])))]
        {::location (format templates-resource (:id result))}))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-handle-ok

(defn resource-handle-ok [ctx]
  (let [{:keys [filename name template]} (::item ctx)]
    (ring-response {:headers {"Content-Disposition" (str "attachment; filename=" filename)}
                    :body template})))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; entity-resource-handle-ok

(defn queue-data-generation [store pipe username item]
  (let [entity_id (:entity_id item)
        location (format downloads-status-resource-path username entity_id)
        item     (assoc item :uuid (str entity_id))
        status   (get-status store item)]
    (if (= status "PENDING")
      {:response {:status 303
                  :headers {"Location" location}
                  :body "In Progress"}}
      (do
        (write-status store (assoc (-> item
                                       (assoc :metadata  {:timestamp (t/now)
                                                          :content-type "text/csv"
                                                          :filename "measurements.csv"})
                                       (update-in [:uuid] str "/status")) :status "PENDING"))
        (pipe/submit-item pipe item)
        {:response {:status 202
                    :headers {"Location" location}
                    :body "Accepted"}}))))

(defn entity-resource-handle-ok [store pipe ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [entity_id (-> ctx :kixi.hecuba.api.entities/item :id)
          data?     (-> ctx :request :query-params (get "data"))
          session   (-> ctx :request :session)
          username  (sec/session-username session)
          auth      (sec/current-authentication session)
          item      {:src-name "downloads" :dest :download :type :measurements :entity_id entity_id}]

      (if data?
        (queue-data-generation store pipe username item)
        (ring-response {:headers {"Content-Disposition" (str "attachment; filename=" entity_id "_template.csv")}
                        :body (util/render-items ctx (measurements-download/get-header store entity_id))})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESOURCES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defresource index [store]
  :allowed-methods #{:get :post}
  :available-media-types #{"text/csv"}
  :known-content-type? #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial index-exists? store)
  :malformed? malformed?
  :post! (partial index-post! store)
  :handle-ok index-handle-ok
  :handle-created index-handle-created)

(defresource resource [store]
  :allowed-methods #{:get :delete :put}
  :available-media-types #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial resource-exists? store)
  :new? (constantly false)
  :malformed? malformed?
  :can-put-to-missing? (constantly false)
  :put! (partial resource-put! store)
  :handle-ok (partial resource-handle-ok store))

(defresource entity-resource [store pipeline]
  :allowed-methods #{:get}
  :available-media-types #{"text/csv" "application/edn"}
  :known-content-type? #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial entities/resource-exists? store)
  :handle-ok (partial entity-resource-handle-ok store pipeline))

(ns kixi.hecuba.api.templates
  (:require [cheshire.core :as json]
            [clojure.set :as set]
            [clojure.tools.logging :as log]
            [kixi.hecuba.api.entities :as entities]
            [kixipipe.pipeline :as pipe]
            [kixipipe.storage.s3 :as s3]
            [kixi.hecuba.security :as sec]
            [kixi.hecuba.storage.db :as db]
            [kixi.hecuba.storage.sha1 :as sha1]
            [kixi.hecuba.web-paths :as p]
            [kixi.hecuba.webutil :as util]
            [kixi.hecuba.webutil :refer (request-method-from-context decode-body authorized? stringify-values update-stringified-lists sha1-regex uuid)]
            [liberator.core :refer (defresource)]
            [liberator.representation :refer (ring-response)]
            [qbits.hayt :as hayt]
            [kixi.hecuba.data.measurements.core :refer (get-status write-status)]
            [kixi.hecuba.data.measurements.download :as measurements-download]
            [clj-time.core :as t]))

(def ^:private templates-resource (p/resource-path-string :templates-resource))
(def ^:private entity-templates-resource (p/resource-path-string :entity-templates-resource))
(def ^:private uploads-status-resource-path (p/resource-path-string :uploads-status-resource))
(def ^:private downloads-status-resource-path (p/resource-path-string :downloads-status-resource))

(defn- payload-from
  ([multipart] (payload-from (uuid) multipart))
  ([id multipart]
     (let [{:strs [name template]} multipart
           {:keys [size tempfile content-type filename]} template]
       (cond-> {:name name
                :filename filename
                :template (slurp tempfile)}
               id (assoc :id id)))))

(defn- valid-template-request? [name {:keys [size tempfile content-type filename]}]
  (and (pos? size)
       tempfile
       content-type
       filename
       name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESOURCE FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-exists?

(defmulti index-exists? request-method-from-context)

(defmethod index-exists? :get [store ctx]
  (db/with-session [session (:hecuba-session store)]
    {::items (db/execute session (hayt/select :csv_templates))}))

(defmethod index-exists? :default [store ctx] true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; malformed?

(defmulti malformed? request-method-from-context :default :default)

(defmethod malformed? :post [ctx]
  (let [{:strs [name template]} (-> ctx :request :multipart-params)]
    (not (valid-template-request? name template))))

(defmethod malformed? :default [_] false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-post!

(defn index-post! [store ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [payload (payload-from (-> ctx :request :multipart-params))
          result  (db/execute session
                              (hayt/insert :csv_templates
                                           payload))]
      (log/info "Created new template with name " (:name result))
      {::location (format templates-resource (:id result))})))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-handle-ok?

(defn index-handle-ok [ctx]
    (let [items (::items ctx)]
    (util/render-items ctx items)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; index-handle-created?

(defn index-handle-created [ctx]
  (let [location (:location_id ctx)]
    {:headers {"Location" location}
     :body    (json/encode {:location location
                            :status "OK"
                            :version "4"})}))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-exists?

(defmulti resource-exists? request-method-from-context)

(defmethod resource-exists? :get [store ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [template_id (-> ctx :request :route-params :template_id)
          item (first (db/execute session
                           (hayt/select :csv_templates
                                        (hayt/where [[= :id template_id]]))))]
      (when item
        {::item item}))))

(defmethod resource-exists? :default [_ _] true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-respond-with-entity?

(defmulti resource-respond-with-entity? request-method-from-context)

(defmethod resource-respond-with-entity? :default [_] true)
(defmethod resource-respond-with-entity? :delete [_] false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-put!

(defn resource-put! [store {request :request}]
  (db/with-session [session (:hecuba-session store)]
    (let [{:keys [multipart-params route-params]} request
          template_id                             (:template_id route-params)]
      (log/info "executing...")
      (let [result (db/execute session (hayt/update :csv_templates
                                                    (hayt/set-columns (payload-from nil multipart-params))
                                                    (hayt/where [[= :id template_id]])))]
        {::location (format templates-resource (:id result))}))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-handle-ok

(defn resource-handle-ok [ctx]
  (let [{:keys [filename name template]} (::item ctx)]
    (ring-response {:headers {"Content-Disposition" (str "attachment; filename=" filename)}
                    :body template})))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; entity-resource-handle-ok

(defn queue-data-generation [store pipe username item]
  (let [entity_id (:entity_id item)
        location (format downloads-status-resource-path username entity_id)
        item     (assoc item :uuid (str username "/" entity_id))
        status   (get-status store item)]
    (if (= status "PENDING")
      {:response {:status 303
                  :headers {"Location" location}
                  :body "In Progress"}}
      (do
        (write-status store (assoc (-> item
                                       (assoc :metadata  {:timestamp (t/now)
                                                          :content-type "text/csv"
                                                          :filename "measurements.csv"})
                                       (update-in [:uuid] str "/status")) :status "PENDING"))
        (pipe/submit-item pipe item)
        {:response {:status 202
                    :headers {"Location" location}
                    :body "Accepted"}}))))

(defn entity-resource-handle-ok [store pipe ctx]
  (db/with-session [session (:hecuba-session store)]
    (let [entity_id (-> ctx :request :params :entity_id)
          data?     (-> ctx :request :query-params (get "data"))
          session   (-> ctx :request :session)
          username  (sec/session-username session)
          auth      (sec/current-authentication session)
          item      {:src-name "downloads" :dest :download :type :measurements :entity_id entity_id}]
      (if data?
        (queue-data-generation store pipe username item)
        (ring-response {:headers {"Content-Disposition" (str "attachment; filename=" entity_id "_template.csv")}
                        :body (util/render-items ctx (measurements-download/get-header store entity_id))})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESOURCES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defresource index [store]
  :allowed-methods #{:get :post}
  :available-media-types #{"text/csv"}
  :known-content-type? #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial index-exists? store)
  :malformed? malformed?
  :post! (partial index-post! store)
  :handle-ok index-handle-ok
  :handle-created index-handle-created)

(defresource resource [store]
  :allowed-methods #{:get :delete :put}
  :available-media-types #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial resource-exists? store)
  :new? (constantly false)
  :malformed? malformed?
  :can-put-to-missing? (constantly false)
  :put! (partial resource-put! store)
  :handle-ok (partial resource-handle-ok store))

(defresource entity-resource [store pipeline]
  :allowed-methods #{:get}
  :available-media-types #{"text/csv" "application/edn"}
  :known-content-type? #{"text/csv"}
  :authorized? (authorized? store)
  :exists? (partial entities/resource-exists? store)
  :handle-ok (partial entity-resource-handle-ok store pipeline))

Fix uuid generation for template data download.

We were creating an s3 key with an empty segment, which led to 403
errors from aws.


(ns lazytest.reload)

(defn reload
  "Removes all namespaces named by symbols, then reloads them all."
  [& symbols]
  {:pre (every? symbol? symbols)}
  (doseq [sym symbols]
    (remove-ns sym))
  (apply require :reload symbols))

(ns lazytest.reload)

(defn reload
  "Removes all namespaces named by symbols, then reloads those
  namespaces and all their dependencies."
  [& symbols]
  {:pre (every? symbol? symbols)}
  (doseq [sym symbols] (remove-ns sym))
  (apply require :reload-all symbols))

Fix needed :reload-all in reload

Fix needed :reload-all in reload


(ns metabase.cmd.load-from-h2
  "Commands for loading data from an H2 file into another database."
  (:require [clojure.java.jdbc :as jdbc]
            [clojure.set :as set]
            [colorize.core :as color]
            (korma [core :as k]
                   [db :as kdb])
            [metabase.config :as config]
            [metabase.db :as db]
            (metabase.models [activity :refer [Activity]]
                             [card :refer [Card]]
                             [card-favorite :refer [CardFavorite]]
                             [card-label :refer [CardLabel]]
                             [dashboard :refer [Dashboard]]
                             [dashboard-card :refer [DashboardCard]]
                             [dashboard-card-series :refer [DashboardCardSeries]]
                             [database :refer [Database]]
                             [dependency :refer [Dependency]]
                             [field :refer [Field]]
                             [field-values :refer [FieldValues]]
                             [foreign-key :refer [ForeignKey]]
                             [label :refer [Label]]
                             [metric :refer [Metric]]
                             [pulse :refer [Pulse]]
                             [pulse-card :refer [PulseCard]]
                             [pulse-channel :refer [PulseChannel]]
                             [pulse-channel-recipient :refer [PulseChannelRecipient]]
                             [query-execution :refer [QueryExecution]]
                             [raw-table :refer [RawTable]]
                             [raw-column :refer [RawColumn]]
                             [revision :refer [Revision]]
                             [segment :refer [Segment]]
                             [session :refer [Session]]
                             [setting :refer [Setting]]
                             [table :refer [Table]]
                             [user :refer [User]]
                             [view-log :refer [ViewLog]])
            [metabase.util :as u]))

(def ^:private entities
  "Entities in the order they should be serialized/deserialized.
   This is done so we make sure that we load load instances of entities before others
   that might depend on them, e.g. `Databases` before `Tables` before `Fields`."
  [Database
   RawTable
   RawColumn
   User
   Setting
   Dependency
   Table
   Field
   FieldValues
   ForeignKey
   Segment
   Metric
   Revision
   ViewLog
   Session
   Dashboard
   Card
   CardFavorite
   DashboardCard
   DashboardCardSeries
   Activity
   QueryExecution
   Pulse
   PulseCard
   PulseChannel
   PulseChannelRecipient
   Label
   CardLabel])

(def ^:private self-referencing-entities
  "Entities that have a column with and FK that points back to the same table."
  #{RawColumn Field})

(def ^:private entities-without-autoinc-ids
  "Entities that do NOT use an auto incrementing ID column."
  #{Setting Session})

(defn- insert-entity [e objs]
  (print (u/format-color 'blue "Transfering %d instances of %s..." (count objs) (:name e)))
  (flush)
  ;; The connection closes prematurely on occasion when we're inserting thousands of rows at once. Break into smaller chunks so connection stays alive
  (doseq [chunk (partition-all 300 objs)]
    (print (color/blue \.))
    (flush)
    (k/insert e (k/values (if (= e DashboardCard)
                            ;; mini-HACK to fix korma/h2 lowercasing these couple attributes
                            ;; luckily this is the only place in our schema where we have camel case names
                            (mapv #(set/rename-keys % {:sizex :sizeX, :sizey :sizeY}) chunk)
                            chunk))))
  (println (color/green "[OK]")))

(defn- insert-self-referencing-entity [e objs]
  (let [self-ref-attr    (condp = e
                           RawColumn :fk_target_column_id
                           Field     :fk_target_field_id)
        self-referencing (filter self-ref-attr objs)
        others           (set/difference (set objs) (set self-referencing))]
    ;; first insert the non-self-referencing objects
    (insert-entity e others)
    ;; then insert the rest, which should be safe to insert now
    (insert-entity e self-referencing)))

(defn- set-postgres-sequence-values []
  (print (u/format-color 'blue "Setting postgres sequence ids to proper values..."))
  (flush)
  (jdbc/with-db-transaction [conn (db/jdbc-details @db/db-connection-details)]
    (doseq [e    (filter #(not (contains? entities-without-autoinc-ids %)) entities)
            :let [table-name (:table e)
                  seq-name   (str table-name "_id_seq")
                  sql        (format "SELECT setval('%s', COALESCE((SELECT MAX(id) FROM %s), 1), true) as val" seq-name table-name)]]
      (jdbc/db-query-with-resultset conn [sql] :val)))
  (println (color/green "[OK]")))

(defn load-from-h2
  "Transfer data from existing H2 database to the newly created (presumably MySQL or Postgres) DB specified by env vars.
   Intended as a tool for upgrading from H2 to a 'real' Database.

   Defaults to using `@metabase.db/db-file` as the connection string."
  [h2-connection-string-or-nil]
  (db/setup-db)
  (let [h2-filename (or h2-connection-string-or-nil @metabase.db/db-file)]
    ;; TODO - would be nice to add `ACCESS_MODE_DATA=r` but it doesn't work with `AUTO_SERVER=TRUE`
    (jdbc/with-db-connection [h2-spec (db/jdbc-details {:type :h2, :db (str h2-filename ";IFEXISTS=TRUE")})]
      (kdb/transaction
        (doseq [e     entities
                :let  [objs (jdbc/query h2-spec [(str "SELECT * FROM " (:table e))])]
                :when (seq objs)]
          (if-not (contains? self-referencing-entities e)
            (insert-entity e objs)
            (insert-self-referencing-entity e objs)))))

    ;; if we are loading into a postgres db then we need to update sequence nextvals
    (when (= (config/config-str :mb-db-type) "postgres")
      (set-postgres-sequence-values))))

(ns metabase.cmd.load-from-h2
  "Commands for loading data from an H2 file into another database."
  (:require [clojure.java.jdbc :as jdbc]
            [clojure.set :as set]
            [colorize.core :as color]
            (korma [core :as k]
                   [db :as kdb])
            [medley.core :as m]
            [metabase.config :as config]
            [metabase.db :as db]
            (metabase.models [activity :refer [Activity]]
                             [card :refer [Card]]
                             [card-favorite :refer [CardFavorite]]
                             [card-label :refer [CardLabel]]
                             [dashboard :refer [Dashboard]]
                             [dashboard-card :refer [DashboardCard]]
                             [dashboard-card-series :refer [DashboardCardSeries]]
                             [database :refer [Database]]
                             [dependency :refer [Dependency]]
                             [field :refer [Field]]
                             [field-values :refer [FieldValues]]
                             [foreign-key :refer [ForeignKey]]
                             [label :refer [Label]]
                             [metric :refer [Metric]]
                             [pulse :refer [Pulse]]
                             [pulse-card :refer [PulseCard]]
                             [pulse-channel :refer [PulseChannel]]
                             [pulse-channel-recipient :refer [PulseChannelRecipient]]
                             [query-execution :refer [QueryExecution]]
                             [raw-table :refer [RawTable]]
                             [raw-column :refer [RawColumn]]
                             [revision :refer [Revision]]
                             [segment :refer [Segment]]
                             [session :refer [Session]]
                             [setting :refer [Setting]]
                             [table :refer [Table]]
                             [user :refer [User]]
                             [view-log :refer [ViewLog]])
            [metabase.util :as u]))

(def ^:private entities
  "Entities in the order they should be serialized/deserialized.
   This is done so we make sure that we load load instances of entities before others
   that might depend on them, e.g. `Databases` before `Tables` before `Fields`."
  [Database
   RawTable
   RawColumn
   User
   Setting
   Dependency
   Table
   Field
   FieldValues
   ForeignKey
   Segment
   Metric
   Revision
   ViewLog
   Session
   Dashboard
   Card
   CardFavorite
   DashboardCard
   DashboardCardSeries
   Activity
   QueryExecution
   Pulse
   PulseCard
   PulseChannel
   PulseChannelRecipient
   Label
   CardLabel])

(def ^:private self-referencing-entities
  "Entities that have a column with and FK that points back to the same table."
  #{RawColumn Field})

(def ^:private entities-without-autoinc-ids
  "Entities that do NOT use an auto incrementing ID column."
  #{Setting Session})

(def ^:private ^:dynamic *db-conn*
  "Active database connection to the target database we are loading into."
  nil)

(defn- insert-entity [e objs]
  (print (u/format-color 'blue "Transfering %d instances of %s..." (count objs) (:name e)))
  (flush)
  ;; The connection closes prematurely on occasion when we're inserting thousands of rows at once. Break into smaller chunks so connection stays alive
  (doseq [chunk (partition-all 300 objs)]
    (print (color/blue \.))
    (flush)
    (k/insert e (k/values (if (= e DashboardCard)
                            ;; mini-HACK to fix korma/h2 lowercasing these couple attributes
                            ;; luckily this is the only place in our schema where we have camel case names
                            (mapv #(set/rename-keys % {:sizex :sizeX, :sizey :sizeY}) chunk)
                            chunk))))
  (println (color/green "[OK]")))

(defn- insert-self-referencing-entity [e objs]
  (let [self-ref-attr    (condp = e
                           RawColumn :fk_target_column_id
                           Field     :fk_target_field_id)
        self-referencing (filter self-ref-attr objs)
        others           (set/difference (set objs) (set self-referencing))]
    ;; first insert the non-self-referencing objects
    (insert-entity e others)
    ;; then insert the rest, which should be safe to insert now
    (insert-entity e self-referencing)))

(defn- set-postgres-sequence-values []
  (print (u/format-color 'blue "Setting postgres sequence ids to proper values..."))
  (flush)
  (doseq [e    (filter #(not (contains? entities-without-autoinc-ids %)) entities)
          :let [table-name (:table e)
                seq-name   (str table-name "_id_seq")
                sql        (format "SELECT setval('%s', COALESCE((SELECT MAX(id) FROM %s), 1), true) as val" seq-name table-name)]]
    (jdbc/db-query-with-resultset *db-conn* [sql] :val))
  (println (color/green "[OK]")))

(defn load-from-h2
  "Transfer data from existing H2 database to the newly created (presumably MySQL or Postgres) DB specified by env vars.
   Intended as a tool for upgrading from H2 to a 'real' Database.

   Defaults to using `@metabase.db/db-file` as the connection string."
  [h2-connection-string-or-nil]
  (db/setup-db)
  (let [h2-filename (or h2-connection-string-or-nil @metabase.db/db-file)]
    ;; NOTE: would be nice to add `ACCESS_MODE_DATA=r` but it doesn't work with `AUTO_SERVER=TRUE`
    ;; connect to H2 database, which is what we are migrating from
    (jdbc/with-db-connection [h2-conn (db/jdbc-details {:type :h2, :db (str h2-filename ";IFEXISTS=TRUE")})]
      (kdb/transaction
        (doseq [e     entities
                :let  [objs (->> (jdbc/query h2-conn [(str "SELECT * FROM " (:table e))])
                                 ;; we apply jdbc-clob->str to all row values because H2->Postgres
                                 ;; gets messed up if the value is left as a clob
                                 (map #(m/map-vals u/jdbc-clob->str %)))]
                :when (seq objs)]
          (if-not (contains? self-referencing-entities e)
            (insert-entity e objs)
            (insert-self-referencing-entity e objs)))))

    ;; if we are loading into a postgres db then we need to update sequence nextvals
    (when (= (config/config-str :mb-db-type) "postgres")
      (jdbc/with-db-transaction [targetdb-conn (db/jdbc-details @db/db-connection-details)]
        (binding [*db-conn* targetdb-conn]
          (set-postgres-sequence-values))))))

fix issue with postgres driver treatment of clob values, which was causing us to lose some data in the migration.


(ns clj-money.entities
  (:require [reagent.core :as r]
            [reagent-forms.core :refer [bind-fields]]
            [secretary.core :as secretary :include-macros true]
            [clj-money.util :as util]
            [clj-money.data :as data]
            [clj-money.state :as state]
            [clj-money.notifications :as notify]
            [clj-money.dom :refer [app-element]]
            [clj-money.layout :refer [with-layout]]
            [clj-money.forms :refer [text-input
                                     radio-buttons
                                     required]]))

(defn- delete
  [entity]
  (when (js/confirm "Are you sure you want to delete this entity?")
    (data/delete-entity entity
                        (fn []
                          (swap! state/entities (fn [old-list]
                                                  (remove
                                                    #(= (:id %)
                                                        (:id entity))
                                                    old-list))))
                        notify/danger)))

(def ^:private entity-form
  [:form
   (text-input :name :required)
   (radio-buttons :settings.inventory-method ["fifo" "lifo"])])

(defn- create-entity
  [entity]
  (data/create-entity entity
                      (fn [created]
                        (swap! state/entities #(conj % created))
                        (secretary/dispatch! "/entities"))
                      #(notify/danger %)))

(defn- new-entity []
  (let [entity (r/atom {})]
    (with-layout
      [:div.row
       [:div.col-md-6
        [:h1 "New Entity"]
        [bind-fields entity-form entity]
        [:button.btn.btn-primary {:on-click #(create-entity @entity)}
         [:span.glyphicon.glyphicon-ok {:aria-hidden "true"}]
         (util/space)
         "Save"]
        (util/space)
        [:a.btn.btn-danger {:href "/entities"}
         [:span.glyphicon.glyphicon-ban-circle {:aria-hidden "true"}]
         (util/space) "Cancel"] ]])))

(defn find-entity
  [id]
  (->> @state/entities
       (filter #(= id (:id %)))
       first))

(defn- relay-updated-entity
  "Accepts an entity and replaces the corresponding enty
  in state/entities"
  [entity]
  (swap! state/entities
         #(map (fn [e]

                 (.log js/console "test against " (prn-str e))

                 (if (= (:id e)  (:id entity))
                   entity
                   e))
               %)))

(defn- save-entity
  [entity]
  (data/update-entity entity
                      (fn [entity]
                        (relay-updated-entity entity)
                        (secretary/dispatch! "/entities"))
                      #(notify/danger %)))

(defn edit-entity
  [id]
  (let [entity (r/atom (-> id js/parseInt find-entity))]
    (with-layout
      [:div.row
       [:div.col-md-6
        [:h1 "Edit Entity"]
        [bind-fields entity-form entity]
        [:button.btn.btn-primary {:type :button
                                  :on-click #(save-entity @entity)}
         [:span.glyphicon.glyphicon-ok {:aria-hidden "true"}]
         (util/space) "Save"]
        (util/space)
        [:button.btn.btn-danger {:on-click #(secretary/dispatch! "/entities")}
         [:span.glyphicon.glyphicon-ban-circle {:aria-hidden "true"}]
         (util/space) "Cancel"]]])))

(defn- entity-row
  [entity]
  ^{:key entity}
  [:tr
   [:td
    (:name entity)]
   [:td
    [:div.btn-group
     [:a.btn.btn-xs.btn-info {:href (util/path :entities (:id entity) :edit)
                              :title "Click here to edit this entity."}
      [:span.glyphicon.glyphicon-pencil {:aria-hidden true}]]
     [:a.btn.btn-xs.btn-danger {:on-click #(delete entity)
                                :title "Click here to remove this entity."}
      [:span.glyphicon.glyphicon-remove {:aria-hidden true}]]]]])

(defn- entity-table
  []
  [:section
  [:table.table.table-striped.table-hover
   [:tbody
    [:tr
     [:th.col-sm-10 "Name"]
     [:th.col-sm-2 " "]]
    (for [entity @state/entities]
      (entity-row entity))]]])

(defn entities-page []
  (with-layout
    [:div.row
     [:div.col-md-6
      [:h1 "Entities"]
      [entity-table]
      [:a.btn.btn-primary {:href "/entities/new"}
       [:span.glyphicon.glyphicon-plus {:aria-hidden true}]
       (util/space)
       "Add"]]]))

(secretary/defroute new-entity-path "/entities/new" []
  (r/render [new-entity] (app-element)))

(secretary/defroute entity-path "/entities/:id/edit" {id :id}
  (r/render [edit-entity id] (app-element)))

(secretary/defroute entities-path "/entities" []
  (r/render [entities-page] (app-element)))

(ns clj-money.entities
  (:require [reagent.core :as r]
            [reagent-forms.core :refer [bind-fields]]
            [secretary.core :as secretary :include-macros true]
            [clj-money.util :as util]
            [clj-money.data :as data]
            [clj-money.state :as state]
            [clj-money.notifications :as notify]
            [clj-money.dom :refer [app-element]]
            [clj-money.layout :refer [with-layout]]
            [clj-money.forms :refer [text-input
                                     radio-buttons
                                     required]]))

(defn- delete
  [entity]
  (when (js/confirm "Are you sure you want to delete this entity?")
    (data/delete-entity entity
                        (fn []
                          (swap! state/entities (fn [old-list]
                                                  (remove
                                                    #(= (:id %)
                                                        (:id entity))
                                                    old-list))))
                        notify/danger)))

(def ^:private entity-form
  [:form
   (text-input :name :required)
   (radio-buttons :settings.inventory-method ["fifo" "lifo"])])

(defn- create-entity
  [entity]
  (data/create-entity entity
                      (fn [created]
                        (swap! state/entities #(conj % created))
                        (secretary/dispatch! "/entities"))
                      #(notify/danger %)))

(defn- new-entity []
  (let [entity (r/atom {})]
    (with-layout
      [:div.row
       [:div.col-md-6
        [:h1 "New Entity"]
        [bind-fields entity-form entity]
        [:button.btn.btn-primary {:on-click #(create-entity @entity)}
         [:span.glyphicon.glyphicon-ok {:aria-hidden "true"}]
         (util/space)
         "Save"]
        (util/space)
        [:a.btn.btn-danger {:href "/entities"}
         [:span.glyphicon.glyphicon-ban-circle {:aria-hidden "true"}]
         (util/space) "Cancel"] ]])))

(defn find-entity
  [id]
  (->> @state/entities
       (filter #(= id (:id %)))
       first))

(defn- relay-updated-entity
  "Accepts an entity and replaces the corresponding enty
  in state/entities"
  [entity]
  (swap! state/entities
         #(map (fn [e]
                 (if (= (:id e)  (:id entity))
                   entity
                   e))
               %)))

(defn- save-entity
  [entity]
  (data/update-entity entity
                      (fn [entity]
                        (relay-updated-entity entity)
                        (secretary/dispatch! "/entities"))
                      #(notify/danger %)))

(defn edit-entity
  [id]
  (let [entity (r/atom (-> id js/parseInt find-entity))]
    (with-layout
      [:div.row
       [:div.col-md-6
        [:h1 "Edit Entity"]
        [bind-fields entity-form entity]
        [:button.btn.btn-primary {:type :button
                                  :on-click #(save-entity @entity)}
         [:span.glyphicon.glyphicon-ok {:aria-hidden "true"}]
         (util/space) "Save"]
        (util/space)
        [:button.btn.btn-danger {:on-click #(secretary/dispatch! "/entities")}
         [:span.glyphicon.glyphicon-ban-circle {:aria-hidden "true"}]
         (util/space) "Cancel"]]])))

(defn- entity-row
  [entity]
  ^{:key entity}
  [:tr
   [:td
    (:name entity)]
   [:td
    [:div.btn-group
     [:a.btn.btn-xs.btn-info {:href (util/path :entities (:id entity) :edit)
                              :title "Click here to edit this entity."}
      [:span.glyphicon.glyphicon-pencil {:aria-hidden true}]]
     [:a.btn.btn-xs.btn-danger {:on-click #(delete entity)
                                :title "Click here to remove this entity."}
      [:span.glyphicon.glyphicon-remove {:aria-hidden true}]]]]])

(defn- entity-table
  []
  [:section
  [:table.table.table-striped.table-hover
   [:tbody
    [:tr
     [:th.col-sm-10 "Name"]
     [:th.col-sm-2 " "]]
    (for [entity @state/entities]
      (entity-row entity))]]])

(defn entities-page []
  (with-layout
    [:div.row
     [:div.col-md-6
      [:h1 "Entities"]
      [entity-table]
      [:a.btn.btn-primary {:href "/entities/new"}
       [:span.glyphicon.glyphicon-plus {:aria-hidden true}]
       (util/space)
       "Add"]]]))

(secretary/defroute new-entity-path "/entities/new" []
  (r/render [new-entity] (app-element)))

(secretary/defroute entity-path "/entities/:id/edit" {id :id}
  (r/render [edit-entity id] (app-element)))

(secretary/defroute entities-path "/entities" []
  (r/render [entities-page] (app-element)))

remove trace output

remove trace output


(ns
    ^{:doc "Provides a simple key/value configuration system with support for automatically persisting to a file on disk.  The config file is serialized clojure code which is easily editable as a text file."
      :author "Jeff Rose"}
  overtone.config.file-store
  (:import [java.io FileOutputStream FileInputStream])
  (:use [clojure.pprint]))

(defonce config*  (ref {}))
(defonce STORE :file)
(defonce store-path* (ref false))

(defn- storage [& args] STORE)

;; Store interface:
(defmulti save-config    storage)
(defmulti restore-config storage)

(def F-LOCK :lock)

; Simple flat-file based storage
(defmethod save-config :file
  [path data]
  (locking F-LOCK
    (spit path (with-out-str (pprint data)))))

(defmethod restore-config :file
  [path]
  (with-open [file (FileInputStream. path)]
    (read-string (slurp file))))

(defn- config-watcher [k r old-conf new-conf]
  (save-config @store-path* @config*))

(defn live-config
  "Use the configuration database located at the given path, restoring the
  current config values if it already exists, and optionally persisting any
  config-value changes as they occur.

  (live-config \"~/.app-config\")

  Anytime the config* ref is modified it will be written to the config file.  Beyond that
  it's just a normal old ref.
  (:n-handlers @config*) ; get the current config setting
  (dosync (alter config* assoc :n-handlers 10)) ; set it to 10
  "
  [path & [initial-value]]
  (dosync
    (ref-set config* (or initial-value
                         (restore-config path)))
    (ref-set store-path* path))
  (add-watch config* :live-config config-watcher))

(ns
    ^{:doc "Provides a simple key/value configuration system with support for automatically persisting to a file on disk.  The config file is serialized clojure code which is easily editable as a text file."
      :author "Jeff Rose"}
  overtone.config.file-store
  (:import [java.io FileOutputStream FileInputStream])
  (:use [clojure.pprint]))

(defonce config*  (ref {}))
(defonce STORE :file)
(defonce store-path* (ref false))

(defn- storage [& args] STORE)

;; Store interface:
(defmulti save-config    storage)
(defmulti restore-config storage)

(def F-LOCK :lock)

; Simple flat-file based storage
(defmethod save-config :file
  [path data]
  (locking F-LOCK
    (spit path (with-out-str (pprint data)))))

(defmethod restore-config :file
  [path]
  (with-open [file (FileInputStream. path)]
    (read-string (slurp file))))

(defn- config-watcher [k r old-conf new-conf]
  (save-config @store-path* @config*))

(defn live-config
  "Use the configuration database located at the given path, restoring
  the current config values if it already exists, and optionally
  persisting any config-value changes as they occur.

  (live-config \"~/.app-config\")

  Anytime the config* ref is modified it will be written to the config
  file.  Beyond that it's just a normal old ref.
  (:n-handlers @config*) ; get the current config setting
  (dosync (alter config* assoc :n-handlers 10)) ; set it to 10"
  [path & [initial-value]]
  (dosync
    (ref-set config* (or initial-value
                         (restore-config path)))
    (ref-set store-path* path))
  (add-watch config* :live-config config-watcher))

tidy up docstings

tidy up docstings


(ns slide-explorer.view
  (:import (javax.swing AbstractAction JComponent JFrame JPanel JLabel KeyStroke)
           (java.awt Color Graphics Graphics2D Rectangle RenderingHints Window)
           (java.util UUID)
           (java.awt.event ComponentAdapter MouseAdapter WindowAdapter)
           (org.micromanager.utils GUIUpdater))
  (:use [org.micromanager.mm :only (edt)]
        [slide-explorer.image :only (crop overlay lut-object)]))

(defmacro timer [expr]
  `(let [ret# (time ~expr)]
     (println '~expr)
     ret#))

;; tile/pixels

(defn tile-to-pixels [[nx ny] [tile-width tile-height] tile-zoom]
  [(int (* (Math/pow 2.0 tile-zoom) nx tile-width))
   (int (* (Math/pow 2.0 tile-zoom) ny tile-height))])

(defn round-int
  "Round x to the nearest integer."
  [x]
  (Math/round (double x)))

(defn tiles-in-pixel-rectangle
  "Returns a list of tile indices found in a given pixel rectangle."
  [[l t b r] [tile-width tile-height]]
  (let [nl (round-int (/ l tile-width))
        nr (round-int (/ r tile-width))
        nt (round-int (/ t tile-height))
        nb (round-int (/ b tile-height))]
    (for [nx (range nl (inc nr))
          ny (range nt (inc nb))]
      [nx ny])))

;; gui utilities

(defn reference-viewer [reference key]
  (let [frame (JFrame. key)
        label (JLabel.)]
    (.add (.getContentPane frame) label)
    (add-watch reference key
               (fn [key reference old-state new-state]
                 (edt (.setText label (.toString new-state)))))
    (doto frame
      (.addWindowListener
        (proxy [WindowAdapter] []
          (windowClosing [e]
                         (remove-watch reference key))))
      .show))
  reference)

(defn bind-key
  "Maps an input-key on a swing component to an action,
  such that action-fn is executed when key is pressed."
  [component input-key action-fn global?]
  (let [im (.getInputMap component (if global?
                                     JComponent/WHEN_IN_FOCUSED_WINDOW
                                     JComponent/WHEN_FOCUSED))
        am (.getActionMap component)
        input-event (KeyStroke/getKeyStroke input-key)
        action
          (proxy [AbstractAction] []
            (actionPerformed [e]
                (action-fn)))
        uuid (.. UUID randomUUID toString)]
    (.put im input-event uuid)
    (.put am uuid action)))

(defn bind-window-key
  [window input-key action-fn]
  (bind-key (.getContentPane window) input-key action-fn true))

(defn- default-screen-device [] ; borrowed from see-saw
  (->
    (java.awt.GraphicsEnvironment/getLocalGraphicsEnvironment)
    .getDefaultScreenDevice))

(defn full-screen!
  "Make the given window/frame full-screen. Pass nil to return all windows
to normal size."
  ([^java.awt.GraphicsDevice device window]
    (if window
      (when (not= (.getFullScreenWindow device) window)
        (.dispose window)
        (.setUndecorated window true)
        (.setFullScreenWindow device window)
        (.show window))
      (when-let [window (.getFullScreenWindow device)]
        (.dispose window)
        (.setFullScreenWindow device nil)
        (.setUndecorated window false)
        (.show window)))
    window)
  ([window]
    (full-screen! (default-screen-device) window)))

(defn setup-fullscreen [window]
  (bind-window-key window "F" #(full-screen! window))
  (bind-window-key window "ESCAPE" #(full-screen! nil)))

(defn enable-anti-aliasing
  ([^Graphics g]
    (enable-anti-aliasing g true))
  ([^Graphics g on]
    (let [graphics2d (cast Graphics2D g)]
      (.setRenderingHint graphics2d
                         RenderingHints/KEY_ANTIALIASING
                         (if on
                           RenderingHints/VALUE_ANTIALIAS_ON
                           RenderingHints/VALUE_ANTIALIAS_OFF)))))

(defn draw-image [g image x y clip-bounds]
  (let [image-rect (Rectangle. x y 512 512)]
    (if (.intersects image-rect clip-bounds)
      (do ;(println "drawn")
          (.drawImage g image x y nil))
      ;(println "not drawn")
      )))

(defn paint-tiles [^Graphics2D g available-tiles zoom clip-bounds [tile-width tile-height]]
  ;(println "paint-tiles")
  ;(println (System/currentTimeMillis))
  ;(timer
  (doseq [[{:keys [nx ny nz nt nc]} image] (get available-tiles zoom)]
    (when image
      (let [[x y] (tile-to-pixels [nx ny] [tile-width tile-height] zoom)]
        (draw-image g image x y clip-bounds)
          ))
    ;)
    ))

(defn paint-screen [graphics screen-state available-tiles]
  (let [original-transform (.getTransform graphics)]
    (doto graphics
      (.setClip 0 0 (:width @screen-state) (:height @screen-state))
      (.translate (+ (:x @screen-state) (/ (:width @screen-state) 2))
                  (+ (:y @screen-state) (/ (:height @screen-state) 2)))
      ;(.rotate @angle)
      enable-anti-aliasing
      (paint-tiles @available-tiles (:zoom @screen-state) (.getClipBounds graphics) [512 512])
      (.setColor Color/YELLOW)
      (.fillOval -30 -30
                 60 60)
      (.setTransform original-transform)
      (.setColor Color/YELLOW)
      (.drawString (str @screen-state)
                   (int 0)
                   (int (- (:height @screen-state) 10))))))

(defn handle-drags [component position-atom]
  (let [drag-origin (atom nil)
        mouse-adapter
        (proxy [MouseAdapter] []
          (mousePressed [e]
                        (reset! drag-origin {:x (.getX e) :y (.getY e)}))
          (mouseReleased [e]
                         (reset! drag-origin nil))
          (mouseDragged [e]
                        (let [x (.getX e) y (.getY e)]
                          (swap! position-atom update-in [:x]
                                 + (- x (:x @drag-origin)))
                          (swap! position-atom update-in [:y]
                                 + (- y (:y @drag-origin)))
                          (reset! drag-origin {:x x :y y}))))]
    (doto component
      (.addMouseListener mouse-adapter)
      (.addMouseMotionListener mouse-adapter))
    position-atom))

(defn handle-wheel [component z-atom]
  (.addMouseWheelListener component
    (proxy [MouseAdapter] []
      (mouseWheelMoved [e]
                       (swap! z-atom update-in [:z]
                              + (.getWheelRotation e)))))
  z-atom)

(defn handle-resize [component size-atom]
  (let [update-size #(let [bounds (.getBounds component)]
                       (swap! size-atom merge
                              {:width (.getWidth bounds)
                               :height (.getHeight bounds)}))]
    (update-size)
    (.addComponentListener component
      (proxy [ComponentAdapter] []
        (componentResized [e]
                          (update-size)))))
  size-atom)

(defn handle-zoom [window zoom-atom]
  (bind-window-key window "ADD" #(swap! zoom-atom update-in [:zoom] inc))
  (bind-window-key window "SUBTRACT" #(swap! zoom-atom update-in [:zoom] dec)))

(defn display-follow [panel reference]
  (add-watch reference "display"
    (fn [_ _ _ _]
      (.repaint panel))))

(defn main-panel [screen-state available-tiles]
  (doto
    (let [updater (GUIUpdater.)]
      (proxy [JPanel] []
        (paintComponent [^Graphics graphics]
                        (proxy-super paintComponent graphics)
                        (paint-screen graphics screen-state available-tiles))
        (repaint []
                 (.post updater #(proxy-super repaint)))))
    (.setBackground Color/BLACK)))

(defn main-frame []
  (doto (JFrame. "Slide Explorer II")
    .show
    (.setBounds 10 10 500 500)))

(defn show [available-tiles]
  (let [screen-state (atom (sorted-map :x 0 :y 0 :z 0 :zoom 0))
        panel (main-panel screen-state available-tiles)
        frame (main-frame)]
    (def at available-tiles)
    (def ss screen-state)
    (def f frame)
    (def pnl panel)
    (.add (.getContentPane frame) panel)
    (setup-fullscreen frame)
    (handle-drags panel screen-state)
    (handle-wheel panel screen-state)
    (handle-resize panel screen-state)
    (handle-zoom frame screen-state)
    (display-follow panel screen-state)
    (display-follow panel available-tiles)
    frame))

(ns slide-explorer.view
  (:import (javax.swing AbstractAction JComponent JFrame JPanel JLabel KeyStroke)
           (java.awt Color Graphics Graphics2D Rectangle RenderingHints Window)
           (java.util UUID)
           (java.awt.event ComponentAdapter MouseAdapter WindowAdapter)
           (org.micromanager.utils GUIUpdater))
  (:use [org.micromanager.mm :only (edt)]
        [slide-explorer.image :only (crop overlay lut-object)]))

(defmacro timer [expr]
  `(let [ret# (time ~expr)]
     (println '~expr)
     ret#))

;; tile/pixels

(defn tile-to-pixels [[nx ny] [tile-width tile-height] tile-zoom]
  [(int (* (Math/pow 2.0 tile-zoom) nx tile-width))
   (int (* (Math/pow 2.0 tile-zoom) ny tile-height))])

(defn tiles-in-pixel-rectangle
  "Returns a list of tile indices found in a given pixel rectangle."
  [rectangle [tile-width tile-height]]
  (let [nl (Math/floor (/ (.x rectangle) tile-width))
        nr (Math/floor (/ (+ -1 (.getWidth rectangle) (.x rectangle)) tile-width))
        nt (Math/floor (/ (.y rectangle) tile-height))
        nb (Math/floor (/ (+ -1 (.getHeight rectangle) (.y rectangle)) tile-height))]
    (for [nx (range nl (inc nr))
          ny (range nt (inc nb))]
      [nx ny])))

;; gui utilities

(defn reference-viewer [reference key]
  (let [frame (JFrame. key)
        label (JLabel.)]
    (.add (.getContentPane frame) label)
    (add-watch reference key
               (fn [key reference old-state new-state]
                 (edt (.setText label (.toString new-state)))))
    (doto frame
      (.addWindowListener
        (proxy [WindowAdapter] []
          (windowClosing [e]
                         (remove-watch reference key))))
      .show))
  reference)

(defn bind-key
  "Maps an input-key on a swing component to an action,
  such that action-fn is executed when key is pressed."
  [component input-key action-fn global?]
  (let [im (.getInputMap component (if global?
                                     JComponent/WHEN_IN_FOCUSED_WINDOW
                                     JComponent/WHEN_FOCUSED))
        am (.getActionMap component)
        input-event (KeyStroke/getKeyStroke input-key)
        action
          (proxy [AbstractAction] []
            (actionPerformed [e]
                (action-fn)))
        uuid (.. UUID randomUUID toString)]
    (.put im input-event uuid)
    (.put am uuid action)))

(defn bind-window-key
  [window input-key action-fn]
  (bind-key (.getContentPane window) input-key action-fn true))

(defn- default-screen-device [] ; borrowed from see-saw
  (->
    (java.awt.GraphicsEnvironment/getLocalGraphicsEnvironment)
    .getDefaultScreenDevice))

(defn full-screen!
  "Make the given window/frame full-screen. Pass nil to return all windows
to normal size."
  ([^java.awt.GraphicsDevice device window]
    (if window
      (when (not= (.getFullScreenWindow device) window)
        (.dispose window)
        (.setUndecorated window true)
        (.setFullScreenWindow device window)
        (.show window))
      (when-let [window (.getFullScreenWindow device)]
        (.dispose window)
        (.setFullScreenWindow device nil)
        (.setUndecorated window false)
        (.show window)))
    window)
  ([window]
    (full-screen! (default-screen-device) window)))

(defn setup-fullscreen [window]
  (bind-window-key window "F" #(full-screen! window))
  (bind-window-key window "ESCAPE" #(full-screen! nil)))

(defn enable-anti-aliasing
  ([^Graphics g]
    (enable-anti-aliasing g true))
  ([^Graphics g on]
    (let [graphics2d (cast Graphics2D g)]
      (.setRenderingHint graphics2d
                         RenderingHints/KEY_ANTIALIASING
                         (if on
                           RenderingHints/VALUE_ANTIALIAS_ON
                           RenderingHints/VALUE_ANTIALIAS_OFF)))))

(defn draw-image [g image x y clip-bounds]
  (let [image-rect (Rectangle. x y 512 512)]
    (if (.intersects image-rect clip-bounds)
      (do ;(println "drawn")
          (.drawImage g image x y nil))
      ;(println "not drawn")
      )))

(defn paint-tiles [^Graphics2D g available-tiles zoom clip-bounds [tile-width tile-height]]
  ;(println "paint-tiles")
  ;(println (System/currentTimeMillis))
  ;(timer
  (doseq [[{:keys [nx ny nz nt nc]} image] (get available-tiles zoom)]
    (when image
      (let [[x y] (tile-to-pixels [nx ny] [tile-width tile-height] zoom)]
        (draw-image g image x y clip-bounds)
          ))
    ;)
    ))

(defn paint-screen [graphics screen-state available-tiles]
  (let [original-transform (.getTransform graphics)]
    (doto graphics
      (.setClip 0 0 (:width @screen-state) (:height @screen-state))
      (.translate (+ (:x @screen-state) (/ (:width @screen-state) 2))
                  (+ (:y @screen-state) (/ (:height @screen-state) 2)))
      ;(.rotate @angle)
      enable-anti-aliasing
      (paint-tiles @available-tiles (:zoom @screen-state) (.getClipBounds graphics) [512 512])
      (.setColor Color/YELLOW)
      (.fillOval -30 -30
                 60 60)
      (.setTransform original-transform)
      (.setColor Color/YELLOW)
      (.drawString (str @screen-state)
                   (int 0)
                   (int (- (:height @screen-state) 10))))))

(defn handle-drags [component position-atom]
  (let [drag-origin (atom nil)
        mouse-adapter
        (proxy [MouseAdapter] []
          (mousePressed [e]
                        (reset! drag-origin {:x (.getX e) :y (.getY e)}))
          (mouseReleased [e]
                         (reset! drag-origin nil))
          (mouseDragged [e]
                        (let [x (.getX e) y (.getY e)]
                          (swap! position-atom update-in [:x]
                                 + (- x (:x @drag-origin)))
                          (swap! position-atom update-in [:y]
                                 + (- y (:y @drag-origin)))
                          (reset! drag-origin {:x x :y y}))))]
    (doto component
      (.addMouseListener mouse-adapter)
      (.addMouseMotionListener mouse-adapter))
    position-atom))

(defn handle-wheel [component z-atom]
  (.addMouseWheelListener component
    (proxy [MouseAdapter] []
      (mouseWheelMoved [e]
                       (swap! z-atom update-in [:z]
                              + (.getWheelRotation e)))))
  z-atom)

(defn handle-resize [component size-atom]
  (let [update-size #(let [bounds (.getBounds component)]
                       (swap! size-atom merge
                              {:width (.getWidth bounds)
                               :height (.getHeight bounds)}))]
    (update-size)
    (.addComponentListener component
      (proxy [ComponentAdapter] []
        (componentResized [e]
                          (update-size)))))
  size-atom)

(defn handle-zoom [window zoom-atom]
  (bind-window-key window "ADD" #(swap! zoom-atom update-in [:zoom] inc))
  (bind-window-key window "SUBTRACT" #(swap! zoom-atom update-in [:zoom] dec)))

(defn display-follow [panel reference]
  (add-watch reference "display"
    (fn [_ _ _ _]
      (.repaint panel))))

(defn main-panel [screen-state available-tiles]
  (doto
    (let [updater (GUIUpdater.)]
      (proxy [JPanel] []
        (paintComponent [^Graphics graphics]
                        (proxy-super paintComponent graphics)
                        (paint-screen graphics screen-state available-tiles))
        (repaint []
                 (.post updater #(proxy-super repaint)))))
    (.setBackground Color/BLACK)))

(defn main-frame []
  (doto (JFrame. "Slide Explorer II")
    .show
    (.setBounds 10 10 500 500)))

(defn show [available-tiles]
  (let [screen-state (atom (sorted-map :x 0 :y 0 :z 0 :zoom 0))
        panel (main-panel screen-state available-tiles)
        frame (main-frame)]
    (def at available-tiles)
    (def ss screen-state)
    (def f frame)
    (def pnl panel)
    (.add (.getContentPane frame) panel)
    (setup-fullscreen frame)
    (handle-drags panel screen-state)
    (handle-wheel panel screen-state)
    (handle-resize panel screen-state)
    (handle-zoom frame screen-state)
    (display-follow panel screen-state)
    (display-follow panel available-tiles)
    frame))

fix mistake in tiles-in-pixel-rectangle

fix mistake in tiles-in-pixel-rectangle

git-svn-id: 03a8048b5ee8463be5048a3801110fb50f378627@9385 d0ab736e-dc22-4aeb-8dc9-08def0aa14fd


(ns circle.backend.action.rvm
  "actions for dealing with RVM during builds"
  (:require [circle.backend.action :as action])
  (:use [circle.backend.build :only (checkout-dir)])
  (:require [circle.sh :as sh])
  (:use [circle.backend.action.bash :only (remote-bash-build bash)]))

(defn trust []
  (action/action
   :name "rvm trust"
   :act-fn (fn [build]
             (let [dir (checkout-dir build)]
               (remote-bash-build build (sh/q (rvm rvmrc trust ~dir)))))))

(defn rvm-use []
  (action/action
   :name "rvm use"
   :act-fn (fn [build]
             (let [dir (checkout-dir build)]
               (remote-bash-build build (sh/q (rvm use "1.9.2@circle-build" --default)))))))

Add rvm-use

Add rvm-use


(ns clj-money.models.accounts
  (:refer-clojure :exclude [update])
  (:require [clojure.pprint :refer [pprint]]
            [clojure.set :refer [rename-keys]]
            [schema.core :as s]
            [clj-money.validation :as validation]
            [clj-money.models.helpers :refer [storage]]
            [clj-money.models.storage :refer [create-account
                                              find-account-by-id
                                              find-accounts-by-name
                                              select-accounts-by-entity-id
                                              update-account
                                              delete-account]])
  (:import java.math.BigDecimal))

(def account-types
  "The list of valid account types in standard presentation order"
  [:asset :liability :equity :income :expense])

(def NewAccount
  {:entity-id s/Int
   :name s/Str
   :type (s/enum :asset :liability :equity :income :expense)
   (s/optional-key :parent-id) s/Int})

(def Account
  {:id s/Int
   :entity-id s/Int
   (s/optional-key :balance) BigDecimal
   (s/optional-key :name) s/Str
   (s/optional-key :type) (s/enum :asset :liability :equity :income :expense)
   (s/optional-key :parent-id) s/Int
   (s/optional-key :created-at) s/Any
   (s/optional-key :updated-at) s/Any})

(declare find-by-id)
(defn- before-validation
  "Adjust account data for validation"
  [storage account]
  (cond-> account

    ; If no entity is specified, try to look it up
    (and (:id account) (nil? (:entity-id account)))
    (assoc :entity-id (:entity-id (find-by-id storage
                                              (Integer. (:id account)))))

    ; make sure type is a keyword
    (string? (:type account))
    (update-in [:type] keyword)

    ; strip out empty string for parent-id
    (and (string? (:parent-id account))
         (empty? (:parent-id account)))
    (dissoc :parent-id)))

(defn- before-create
  "Adjust account data prior to creation"
  [storage account]
  (assoc account :balance (bigdec 0)))

(defn- before-save
  "Adjusts account data for saving in the database"
  [storage account]
  (cond-> account
    ; convert account type from keyword to string
    (:type account) (update-in [:type] name)))

(defn- prepare-for-return
  "Adjusts account data read from the database for use"
  [account]
  (cond-> account

    ; Remove :parent-id if it's nil
    (and
      (contains? account :parent-id)
      (nil? (:parent-id account)))
    (dissoc :parent-id)

    ; :type should already be present
    ; and should be a keyword
    true
    (update-in [:type] keyword)))

(defn- name-must-be-unique
  "Validation rule function that ensures an account
  name is unique within an entity"
  [storage {account-name :name entity-id :entity-id :as model}]
  {:model model
   :errors (let [existing (when (and account-name entity-id)
                            (->> (find-accounts-by-name storage entity-id account-name)
                                 (remove #(= (:id %) (:id model)))
                                 (filter #(= (:parent-id %) (:parent-id model)))))]
             (if (seq existing)
               [[:name "Name is already in use"]]
               []))})

(defn- must-have-same-type-as-parent
  "Validation rule that ensure an account
  has the same type as its parent"
  [storage {:keys [parent-id type] :as model}]
  {:model model
   :errors (if (and type
                    parent-id
                    (let [parent (find-by-id storage parent-id)]
                      (not (= type
                              (:type parent)))))
             [[:type "Type must match the parent type"]]
             [])})

(defn- validation-rules
  "Returns the account validation rules"
  [storage schema]
  [(partial validation/apply-schema schema)
   (partial name-must-be-unique storage)
   (partial must-have-same-type-as-parent storage)])

(defn- validate-new-account
  [storage account]
  (validation/validate-model account (validation-rules storage NewAccount)))

(defn- validate-account
  [storage account]
  (validation/validate-model account (validation-rules storage Account)))

(defn create
  "Creates a new account in the system"
  [storage-spec account]
  (let [storage (storage storage-spec)
        validated (->> account
                       (before-validation storage)
                       (validate-new-account storage))]
    (if (validation/has-error? validated)
      validated
      (->> validated
           (before-create storage)
           (before-save storage)
           (create-account storage)
           prepare-for-return))))

(defn find-by-id
  "Returns the account having the specified id"
  [storage-spec id]
  (prepare-for-return
    (find-account-by-id (storage storage-spec) id)))

(defn reload
  "Returns a fresh copy of the specified account from the data store"
  [storage-spec {:keys [id]}]
  (find-by-id storage-spec id))

(defn select-by-entity-id
  "Returns a list of all accounts in the system"
  [storage-spec entity-id]
  (map prepare-for-return
       (select-accounts-by-entity-id (storage storage-spec)
                                     entity-id)))

(defn- append-children
  [account all-accounts]
  (let [children (->> all-accounts
                      (filter #(= (:id account) (:parent-id %)))
                      (map #(append-children % all-accounts))
                      (sort-by :name)
                      vec)]
    (assoc account :children children
                   :children-balance (reduce #(+ %1 (:balance %2) (:children-balance %2))
                                             0
                                             children))))

(defn select-nested-by-entity-id
  "Returns the accounts for the entity with children nested under
  parents and parents grouped by type"
  ([storage-spec entity-id] (select-nested-by-entity-id storage-spec entity-id account-types))
  ([storage-spec entity-id types]
  (let [all (select-by-entity-id storage-spec entity-id)
        grouped (->> all
                     (remove :parent-id)
                     (map #(append-children % all))
                     (group-by :type))]
    (map #(hash-map :type % :accounts (or (% grouped) [])) types))))

(defn update
  "Updates the specified account"
  [storage-spec account]
  (let [st (storage storage-spec)
        validated (->> account
                       (before-validation st)
                       (validate-account st))]
    (if (validation/has-error? validated)
      validated
      (do
        (->> validated
             (before-save st)
             (update-account st))
        (->> validated
             :id
             (find-by-id st)
             prepare-for-return)))))

(defn delete
  "Removes the account from the system"
  [storage-spec id]
  (delete-account (storage storage-spec) id))

(defn- left-side?
  "Returns truthy if the specified account is asset or expense, falsey if anything else"
  [account]
  (#{:asset :expense} (:type account)))

(defn polarize-amount
  "Adjusts the polarity of an amount as appropriate given
  a transaction item action and the type of the associated account"
  [storage-spec transaction-item]
  (let [account (find-by-id storage-spec (:account-id transaction-item))
        polarizer (* (if (left-side? account) 1 -1)
                     (if (= :debit (:action transaction-item)) 1 -1))]
    (* (:amount transaction-item) polarizer)))

reformat select-nested-by-entity-id

reformat select-nested-by-entity-id


(ns decktouch.card-list
  (:require [reagent.core :as reagent]
            [decktouch.card-display :as card-display]))

(defn card-img [url]
  [:img {:src url
         :style (js-obj "width" "240" "height" "340")}])

(defn card-in-list [card card-id]
  (let [multiverseId (get card "multiverseId")
        image-link (str "https://api.mtgdb.info/content/hi_res_card_images/" multiverseId ".jpg")]
  [:li
    [:a {:id card-id
         :data-toggle "tooltip"
         :data-placement "bottom"
         :data-html true
         :data-trigger "hover"
         :title (reagent/render-component-to-string [card-img image-link])
         :onClick (fn [] (reset! card-display/url image-link))}
         (str (get card "name"))]]))

(defn card-in-list-did-mount [card-id]
    (.popover (js/$ (str "#" card-id))))

(defn card-in-list-component [card]
  (let [card-id (str (clojure.string/replace (get card "imageName") #"\W" "_"))]
    (reagent/create-class {:render #(card-in-list card card-id)
                           :component-did-mount #(card-in-list-did-mount card-id)
                           })))

(defn is-card-of-type? [card type]
  (contains? (set (get card "types")) type))

(defn filter-cards-by-type [cards type]
  (filter (fn [card] (let [c (js->clj card)]
                       (is-card-of-type? c type))) cards))

(defn remove-cards-by-type [cards type]
  (filter #(not (is-card-of-type? % type)) cards))

(defn card-type-list [cards type]
  (let [filtered-cards-by-type (filter-cards-by-type cards type)]
    (if (not-empty filtered-cards-by-type)
      [:div
        [:p type]
        [:ul
          (for [card (filter-cards-by-type cards type)]
               ^{:key (get card "imageName")} [card-in-list-component card])]])))

(defn component [cards]
  (if (empty? cards)
    [:strong "Add some cards!"]
    ;; else
    [:div.row
      [:div.col-md-6
        [card-type-list cards "Creature"]
        [card-type-list cards "Land"]]
      (let [noncreature-cards (remove-cards-by-type cards "Creature")]
        [:div.col-md-6
          [card-type-list cards "Planeswalker"]
          [card-type-list cards "Instant"]
          [card-type-list cards "Sorcery"]
          [card-type-list noncreature-cards "Enchantment"]
          [card-type-list noncreature-cards "Artifact"]])]))

(ns decktouch.card-list
  (:require [reagent.core :as reagent]
            [decktouch.card-display :as card-display]))

(defn card-img [url]
  [:img {:src url
         :style (js-obj "width" "240" "height" "340")}])

(defn card-in-list [card card-id]
  (let [multiverseId (get card "multiverseId")
        image-link (str "https://api.mtgdb.info/content/hi_res_card_images/" multiverseId ".jpg")]
  [:li
    [:a {:id card-id
         :data-toggle "tooltip"
         :data-placement "bottom"
         :data-html true
         :data-trigger "hover"
         :data-content (reagent/render-component-to-string [card-img image-link])
         :onClick (fn [] (reset! card-display/url image-link))}
         (str (get card "name"))]]))

(defn card-in-list-did-mount [card-id]
    (.popover (js/$ (str "#" card-id))))

(defn card-in-list-component [card]
  (let [card-id (str (clojure.string/replace (get card "imageName") #"\W" "_"))]
    (reagent/create-class {:render #(card-in-list card card-id)
                           :component-did-mount #(card-in-list-did-mount card-id)
                           })))

(defn is-card-of-type? [card type]
  (contains? (set (get card "types")) type))

(defn filter-cards-by-type [cards type]
  (filter (fn [card] (let [c (js->clj card)]
                       (is-card-of-type? c type))) cards))

(defn remove-cards-by-type [cards type]
  (filter #(not (is-card-of-type? % type)) cards))

(defn card-type-list [cards type]
  (let [filtered-cards-by-type (filter-cards-by-type cards type)]
    (if (not-empty filtered-cards-by-type)
      [:div
        [:p type]
        [:ul
          (for [card (filter-cards-by-type cards type)]
               ^{:key (get card "imageName")} [card-in-list-component card])]])))

(defn component [cards]
  (if (empty? cards)
    [:strong "Add some cards!"]
    ;; else
    [:div.row
      [:div.col-md-6
        [card-type-list cards "Creature"]
        [card-type-list cards "Land"]]
      (let [noncreature-cards (remove-cards-by-type cards "Creature")]
        [:div.col-md-6
          [card-type-list cards "Planeswalker"]
          [card-type-list cards "Instant"]
          [card-type-list cards "Sorcery"]
          [card-type-list noncreature-cards "Enchantment"]
          [card-type-list noncreature-cards "Artifact"]])]))

Fix weird title bar on card popover

Fix weird title bar on card popover