(ns blocks.core
  "Block storage API. Functions which may cause IO to occur are marked with
  bangs.

  For example `(read! \"foo\")` doesn't have side-effects, but `(read!
  some-input-stream)` will consume bytes from the stream.

  When blocks are returned from a block store, they may include 'stat' metadata
  about the blocks, including:

  - `:source`      resource location for the block content
  - `:stored-at`   time block was added to the store
  "
  (:refer-clojure :exclude [get list])
  (:require
    [blocks.data :as data]
    [blocks.meter :as meter]
    [blocks.store :as store]
    [blocks.summary :as sum]
    [byte-streams :as bytes]
    [clojure.java.io :as io]
    [clojure.set :as set]
    [clojure.string :as str]
    [multihash.core :as multihash]
    [multihash.digest :as digest])
  (:import
    (blocks.data
      Block
      PersistentBytes)
    java.io.File
    multihash.core.Multihash
    org.apache.commons.io.input.CountingInputStream))

(def default-algorithm
  "The hashing algorithm used if not specified in functions which create blocks."
  :sha2-256)

;; ## Stat Metadata

(defn with-stats
  "Returns the given block with updated stat metadata."
  [block stats]
  (vary-meta block assoc :block/stats stats))

(defn meta-stats
  "Returns stat information from a block's metadata, if present."
  [block]
  (:block/stats (meta block)))

;; ## Block IO

(defn loaded?
  "True if the block's content is already loaded into memory."
  [block]
  (data/loaded? block))

(defn lazy?
  "True if the given block reads its content on-demand."
  [block]
  (not (data/loaded? block)))

(defn from-file
  "Creates a lazy block from a local file. The file is read once to calculate
  the identifier."
  ([file]
   (from-file file default-algorithm))
  ([file algorithm]
   (let [file (io/file file)
         hash-fn (data/checked-hasher algorithm)
         reader #(io/input-stream file)
         id (hash-fn (reader))]
     (data/lazy-block id (.length file) reader))))

(defn open
  "Opens an input stream to read the contents of the block.

  If `start` and `end` are given, the input stream will only return content
  from the starting index byte to the byte before the end index. For example,
  opening a block with size _n_ with `(open block 0 n)` would return the full
  block contents."
  (^java.io.InputStream
   [block]
   (data/content-stream block nil nil))
  (^java.io.InputStream
   [block start end]
   (when-not (and (integer? start)
                  (integer? end)
                  (not= start end)
                  (<= 0 start end (:size block)))
     (throw (IllegalArgumentException.
              (format "Range bounds must be distinct integers within block bounds: [0, %d]"
                      (:size block)))))
   (data/content-stream block start end)))

(defn read!
  "Reads data into memory from the given source and hashes it to identify the
  block."
  ([source]
   (read! source default-algorithm))
  ([source algorithm]
   (data/read-block algorithm source)))

(defn write!
  "Writes block content to an output stream."
  [block out]
  (with-open [stream (open block)]
    (bytes/transfer stream out)))

(defn load!
  "Returns a loaded version of the given block. If the block is lazy, the
  stream is read into memory and returned as a new block. If the block is
  already loaded, it is returned unchanged.

  The returned block will have the same extra attributes and metadata as the one
  given."
  [^Block block]
  (if (lazy? block)
    (let [content (with-open [stream (open block)]
                    (bytes/to-byte-array stream))]
      (Block. (:id block)
              (count content)
              (PersistentBytes/wrap content)
              (._attrs block)
              (meta block)))
    ; Block is already loaded.
    block))

(defn validate!
  "Checks a block to verify that it confirms to the expected schema and has a
  valid identifier for its content. Returns nil if the block is valid, or
  throws an exception on any error."
  [block]
  (let [id (:id block)
        size (:size block)]
    (when-not (instance? Multihash id)
      (throw (IllegalStateException.
               (str "Block id is not a multihash: " (pr-str id)))))
    (when (neg? size)
      (throw (IllegalStateException.
               (str "Block " id " has negative size: " size))))
    (with-open [stream (CountingInputStream. (open block))]
      (when-not (digest/test id stream)
        (throw (IllegalStateException.
                 (str "Block " id " has mismatched content"))))
      (when (not= size (.getByteCount stream))
        (throw (IllegalStateException.
                 (str "Block " id " reports size " size " but has actual size "
                      (.getByteCount stream))))))))

;; ## Storage API

(defn ->store
  "Constructs a new block store from a URI by dispatching on the scheme. The
  store will be returned in an initialized (but not started) state."
  [uri]
  (store/initialize uri))

(defmacro ^:private measure-method
  "Anophoric macro to measure a store method."
  [[method-kw args] & body]
  `(meter/measure-method*
     ~'store ~method-kw ~args
     (fn body# [] ~@body)))

(defn stat
  "Returns a map with an `:id` and `:size` but no content. The returned map
  may contain additional data like the date stored. Returns nil if the store
  does not contain the identified block."
  [store id]
  (when id
    (when-not (instance? Multihash id)
      (throw (IllegalArgumentException.
               (str "Id value must be a multihash, got: " (pr-str id)))))
    (measure-method [::stat id]
      (store/-stat store id))))

(defn list
  "Enumerates the stored blocks, returning a lazy sequence of block stats sorted
  by id. Iterating over the list may result in additional operations to read
  from the backing data store.

  - `:algorithm`  only return blocks using this hash algorithm
  - `:after`      list blocks whose id (in hex) lexically follows this string
  - `:limit`      restrict the maximum number of results returned
  "
  [store & opts]
  (let [allowed-keys #{:algorithm :after :limit}
        opts-map (cond
                   (empty? opts) nil
                   (and (= 1 (count opts)) (map? (first opts))) (first opts)
                   :else (apply hash-map opts))
        bad-opts (set/difference (set (keys opts-map)) allowed-keys)]
    (when (not-empty bad-opts)
      (throw (IllegalArgumentException.
               (str "Invalid options passed to list: "
                    (str/join " " bad-opts)))))
    (when-let [algorithm (:algorithm opts-map)]
      (when-not (keyword? algorithm)
        (throw (IllegalArgumentException.
                 (str "Option :algorithm is not a keyword: "
                      (pr-str algorithm))))))
    (when-let [after (:after opts-map)]
      (when-not (and (string? after) (re-matches #"^[0-9a-fA-F]*$" after))
        (throw (IllegalArgumentException.
                 (str "Option :after is not a hex string: "
                      (pr-str after))))))
    (when-let [limit (:limit opts-map)]
      (when-not (and (integer? limit) (pos? limit))
        (throw (IllegalArgumentException.
                 (str "Option :limit is not a positive integer: "
                      (pr-str limit))))))
    (measure-method [::list opts-map]
      (store/-list store opts-map))))

(defn get
  "Loads content for a multihash and returns a block record. Returns nil if no
  block is stored for that id.

  The returned block is checked to make sure the id matches the requested
  multihash."
  [store id]
  (when-not (instance? Multihash id)
    (throw (IllegalArgumentException.
             (str "Id value must be a multihash, got: " (pr-str id)))))
  (let [block (measure-method [::get id]
                (store/-get store id))]
    (when block
      (when-not (= id (:id block))
        (throw (RuntimeException.
                 (str "Asked for block " id " but got " (:id block)))))
      (meter/metered-block store ::meter/io-read block))))

(defn put!
  "Saves a block into the store. Returns the block record, updated with stat
  metadata."
  [store block]
  (when block
    (when-not (instance? Block block)
      (throw (IllegalArgumentException.
               (str "Argument must be a block, got: " (pr-str block)))))
    (data/merge-blocks
      block
      (measure-method [::put! block]
        (->> block
             (meter/metered-block store ::meter/io-write)
             (store/-put! store)
             (meter/metered-block store ::meter/io-read))))))

(defn store!
  "Stores content from a byte source in a block store and returns the block
  record.

  If the source is a file, it will be streamed into the store. Otherwise, the
  content is read into memory, so this may not be suitable for large sources."
  ([store source]
   (store! store source default-algorithm))
  ([store source algorithm]
   (let [block (if (instance? File source)
                 (from-file source algorithm)
                 (read! source algorithm))]
     (when (pos? (:size block))
       (put! store block)))))

(defn delete!
  "Removes a block from the store. Returns true if the block was found and
  removed."
  [store id]
  (when id
    (measure-method [::delete! id]
      (store/-delete! store id))))

;; ## Batch API

(defn- validate-collection-of
  "Validates that the given argument is a collection of a certain class of
  entries."
  [cls xs]
  (when-not (coll? xs)
    (throw (IllegalArgumentException.
             (str "Argument must be a collection: " (pr-str xs)))))
  (when-let [bad-entries (seq (filter (complement (partial instance? cls)) xs))]
    (throw (IllegalArgumentException.
             (str "Collection entries must be " cls " values: "
                  (pr-str bad-entries))))))

(defn get-batch
  "Retrieves a batch of blocks identified by a collection of multihashes.
  Returns a sequence of the requested blocks in no particular order. Any blocks
  which were not found in the store are omitted from the result."
  [store ids]
  (validate-collection-of Multihash ids)
  (if (satisfies? store/BatchingStore store)
    (measure-method [::get-batch ids]
      (keep (partial meter/metered-block store ::meter/io-read)
            (store/-get-batch store ids)))
    (doall (keep (partial get store) ids))))

(defn put-batch!
  "Saves a collection of blocks into the store. Returns a sequence of the
  stored blocks, in no particular order.

  This is not guaranteed to be an atomic operation; readers may be able to see
  the store in a partially-updated state."
  [store blocks]
  (validate-collection-of Block blocks)
  (if-let [blocks (seq (remove nil? blocks))]
    (if (satisfies? store/BatchingStore store)
      (measure-method [::put-batch! blocks]
        (->> blocks
             (map (partial meter/metered-block store ::meter/io-write))
             (store/-put-batch! store)
             (map (partial meter/metered-block store ::meter/io-read))))
      (mapv (partial put! store) blocks))
    []))

(defn delete-batch!
  "Removes a batch of blocks from the store, identified by a collection of
  multihashes. Returns a set of ids for the blocks which were found and
  deleted.

  This is not guaranteed to be an atomic operation; readers may be able to see
  the store in a partially-deleted state."
  [store ids]
  (validate-collection-of Multihash ids)
  (if (satisfies? store/BatchingStore store)
    (measure-method [::delete-batch! ids]
      (set (store/-delete-batch! store ids)))
    (set (filter (partial delete! store) ids))))

;; ## Storage Utilities

(defn erase!!
  "Completely removes any data associated with the store. After this call, the
  store should be empty. This is not guaranteed to be an atomic operation!"
  [store]
  (if (satisfies? store/ErasableStore store)
    (measure-method [::erase!! nil]
      (store/-erase! store))
    (run! (comp (partial delete! store) :id)
          (store/-list store nil))))

(defn scan
  "Scans all the blocks in the store, building up a store-level summary. If
  given, the predicate function will be called with each block in the store.
  By default, all blocks are scanned."
  ([store]
   (scan store nil))
  ([store p]
   (-> (store/-list store nil)
       (cond->> p (filter p))
       (->> (reduce sum/update (sum/init))))))

(defn sync!
  "Synchronize blocks from the `source` store to the `dest` store. Returns a
  summary of the copied blocks. Options may include:

  - `:filter` a function to run on every block stats before it is copied to the
    `dest` store. If the function returns a falsey value, the block will not be
    copied."
  [source dest & {:as opts}]
  (-> (store/missing-blocks
        (store/-list source nil)
        (store/-list dest nil))
      (cond->>
        (:filter opts) (filter (:filter opts)))
      (->> (reduce
             (fn copy-block
               [summary stat]
               (put! dest (get source (:id stat)))
               (sum/update summary stat))
             (sum/init)))))

(ns blocks.core
  "Block storage API. Functions which may cause IO to occur are marked with
  bangs.

  For example `(read! \"foo\")` doesn't have side-effects, but `(read!
  some-input-stream)` will consume bytes from the stream.

  When blocks are returned from a block store, they may include 'stat' metadata
  about the blocks, including:

  - `:source`      resource location for the block content
  - `:stored-at`   time block was added to the store
  "
  (:refer-clojure :exclude [get list])
  (:require
    [blocks.data :as data]
    [blocks.meter :as meter]
    [blocks.store :as store]
    [blocks.summary :as sum]
    [byte-streams :as bytes]
    [clojure.java.io :as io]
    [clojure.set :as set]
    [clojure.string :as str]
    [multihash.core :as multihash]
    [multihash.digest :as digest])
  (:import
    (blocks.data
      Block
      PersistentBytes)
    java.io.File
    multihash.core.Multihash
    org.apache.commons.io.input.CountingInputStream))

(def default-algorithm
  "The hashing algorithm used if not specified in functions which create blocks."
  :sha2-256)

;; ## Stat Metadata

(defn with-stats
  "Returns the given block with updated stat metadata."
  [block stats]
  (vary-meta block assoc :block/stats stats))

(defn meta-stats
  "Returns stat information from a block's metadata, if present."
  [block]
  (:block/stats (meta block)))

;; ## Block IO

(defn loaded?
  "True if the block's content is already loaded into memory."
  [block]
  (data/loaded? block))

(defn lazy?
  "True if the given block reads its content on-demand."
  [block]
  (not (data/loaded? block)))

(defn from-file
  "Creates a lazy block from a local file. The file is read once to calculate
  the identifier."
  ([file]
   (from-file file default-algorithm))
  ([file algorithm]
   (let [file (io/file file)
         hash-fn (data/checked-hasher algorithm)
         reader #(io/input-stream file)
         id (hash-fn (reader))]
     (data/lazy-block id (.length file) reader))))

(defn open
  "Opens an input stream to read the contents of the block.

  If `start` and `end` are given, the input stream will only return content
  from the starting index byte to the byte before the end index. For example,
  opening a block with size _n_ with `(open block 0 n)` would return the full
  block contents."
  (^java.io.InputStream
   [block]
   (data/content-stream block nil nil))
  (^java.io.InputStream
   [block start end]
   (when-not (and (integer? start)
                  (integer? end)
                  (not= start end)
                  (<= 0 start end (:size block)))
     (throw (IllegalArgumentException.
              (format "Range bounds must be distinct integers within block bounds: [0, %d]"
                      (:size block)))))
   (data/content-stream block start end)))

(defn read!
  "Reads data into memory from the given source and hashes it to identify the
  block."
  ([source]
   (read! source default-algorithm))
  ([source algorithm]
   (data/read-block algorithm source)))

(defn write!
  "Writes block content to an output stream."
  [block out]
  (with-open [stream (open block)]
    (bytes/transfer stream out)))

(defn load!
  "Returns a loaded version of the given block. If the block is lazy, the
  stream is read into memory and returned as a new block. If the block is
  already loaded, it is returned unchanged.

  The returned block will have the same extra attributes and metadata as the one
  given."
  [^Block block]
  (if (lazy? block)
    (let [content (with-open [stream (open block)]
                    (bytes/to-byte-array stream))]
      (Block. (:id block)
              (count content)
              (PersistentBytes/wrap content)
              (._attrs block)
              (meta block)))
    ; Block is already loaded.
    block))

(defn validate!
  "Checks a block to verify that it confirms to the expected schema and has a
  valid identifier for its content. Returns nil if the block is valid, or
  throws an exception on any error."
  [block]
  (let [id (:id block)
        size (:size block)]
    (when-not (instance? Multihash id)
      (throw (IllegalStateException.
               (str "Block id is not a multihash: " (pr-str id)))))
    (when (neg? size)
      (throw (IllegalStateException.
               (str "Block " id " has negative size: " size))))
    (with-open [stream (CountingInputStream. (open block))]
      (when-not (digest/test id stream)
        (throw (IllegalStateException.
                 (str "Block " id " has mismatched content"))))
      (when (not= size (.getByteCount stream))
        (throw (IllegalStateException.
                 (str "Block " id " reports size " size " but has actual size "
                      (.getByteCount stream))))))))

;; ## Storage API

(defn ->store
  "Constructs a new block store from a URI by dispatching on the scheme. The
  store will be returned in an initialized (but not started) state."
  [uri]
  (store/initialize uri))

(defmacro ^:private measure-method
  "Anophoric macro to measure a store method."
  [[method-kw args] & body]
  `(meter/measure-method*
     ~'store ~method-kw ~args
     (fn body# [] ~@body)))

(defn stat
  "Returns a map with an `:id` and `:size` but no content. The returned map
  may contain additional data like the date stored. Returns nil if the store
  does not contain the identified block."
  [store id]
  (when id
    (when-not (instance? Multihash id)
      (throw (IllegalArgumentException.
               (str "Id value must be a multihash, got: " (pr-str id)))))
    (measure-method [::stat id]
      (store/-stat store id))))

(defn list
  "Enumerates the stored blocks, returning a lazy sequence of block stats sorted
  by id. Iterating over the list may result in additional operations to read
  from the backing data store.

  - `:algorithm`  only return blocks using this hash algorithm
  - `:after`      list blocks whose id (in hex) lexically follows this string
  - `:limit`      restrict the maximum number of results returned
  "
  [store & opts]
  (let [allowed-keys #{:algorithm :after :limit}
        opts-map (cond
                   (empty? opts) nil
                   (and (= 1 (count opts))
                        (or (map? (first opts))
                            (nil? (first opts))))
                     (first opts)
                   :else (apply hash-map opts))
        bad-opts (set/difference (set (keys opts-map)) allowed-keys)]
    (when (not-empty bad-opts)
      (throw (IllegalArgumentException.
               (str "Invalid options passed to list: "
                    (str/join " " bad-opts)))))
    (when-let [algorithm (:algorithm opts-map)]
      (when-not (keyword? algorithm)
        (throw (IllegalArgumentException.
                 (str "Option :algorithm is not a keyword: "
                      (pr-str algorithm))))))
    (when-let [after (:after opts-map)]
      (when-not (and (string? after) (re-matches #"^[0-9a-fA-F]*$" after))
        (throw (IllegalArgumentException.
                 (str "Option :after is not a hex string: "
                      (pr-str after))))))
    (when-let [limit (:limit opts-map)]
      (when-not (and (integer? limit) (pos? limit))
        (throw (IllegalArgumentException.
                 (str "Option :limit is not a positive integer: "
                      (pr-str limit))))))
    (measure-method [::list opts-map]
      (store/-list store opts-map))))

(defn get
  "Loads content for a multihash and returns a block record. Returns nil if no
  block is stored for that id.

  The returned block is checked to make sure the id matches the requested
  multihash."
  [store id]
  (when-not (instance? Multihash id)
    (throw (IllegalArgumentException.
             (str "Id value must be a multihash, got: " (pr-str id)))))
  (let [block (measure-method [::get id]
                (store/-get store id))]
    (when block
      (when-not (= id (:id block))
        (throw (RuntimeException.
                 (str "Asked for block " id " but got " (:id block)))))
      (meter/metered-block store ::meter/io-read block))))

(defn put!
  "Saves a block into the store. Returns the block record, updated with stat
  metadata."
  [store block]
  (when block
    (when-not (instance? Block block)
      (throw (IllegalArgumentException.
               (str "Argument must be a block, got: " (pr-str block)))))
    (data/merge-blocks
      block
      (measure-method [::put! block]
        (->> block
             (meter/metered-block store ::meter/io-write)
             (store/-put! store)
             (meter/metered-block store ::meter/io-read))))))

(defn store!
  "Stores content from a byte source in a block store and returns the block
  record.

  If the source is a file, it will be streamed into the store. Otherwise, the
  content is read into memory, so this may not be suitable for large sources."
  ([store source]
   (store! store source default-algorithm))
  ([store source algorithm]
   (let [block (if (instance? File source)
                 (from-file source algorithm)
                 (read! source algorithm))]
     (when (pos? (:size block))
       (put! store block)))))

(defn delete!
  "Removes a block from the store. Returns true if the block was found and
  removed."
  [store id]
  (when id
    (measure-method [::delete! id]
      (store/-delete! store id))))

;; ## Batch API

(defn- validate-collection-of
  "Validates that the given argument is a collection of a certain class of
  entries."
  [cls xs]
  (when-not (coll? xs)
    (throw (IllegalArgumentException.
             (str "Argument must be a collection: " (pr-str xs)))))
  (when-let [bad-entries (seq (filter (complement (partial instance? cls)) xs))]
    (throw (IllegalArgumentException.
             (str "Collection entries must be " cls " values: "
                  (pr-str bad-entries))))))

(defn get-batch
  "Retrieves a batch of blocks identified by a collection of multihashes.
  Returns a sequence of the requested blocks in no particular order. Any blocks
  which were not found in the store are omitted from the result."
  [store ids]
  (validate-collection-of Multihash ids)
  (if (satisfies? store/BatchingStore store)
    (measure-method [::get-batch ids]
      (keep (partial meter/metered-block store ::meter/io-read)
            (store/-get-batch store ids)))
    (doall (keep (partial get store) ids))))

(defn put-batch!
  "Saves a collection of blocks into the store. Returns a sequence of the
  stored blocks, in no particular order.

  This is not guaranteed to be an atomic operation; readers may be able to see
  the store in a partially-updated state."
  [store blocks]
  (validate-collection-of Block blocks)
  (if-let [blocks (seq (remove nil? blocks))]
    (if (satisfies? store/BatchingStore store)
      (measure-method [::put-batch! blocks]
        (->> blocks
             (map (partial meter/metered-block store ::meter/io-write))
             (store/-put-batch! store)
             (map (partial meter/metered-block store ::meter/io-read))))
      (mapv (partial put! store) blocks))
    []))

(defn delete-batch!
  "Removes a batch of blocks from the store, identified by a collection of
  multihashes. Returns a set of ids for the blocks which were found and
  deleted.

  This is not guaranteed to be an atomic operation; readers may be able to see
  the store in a partially-deleted state."
  [store ids]
  (validate-collection-of Multihash ids)
  (if (satisfies? store/BatchingStore store)
    (measure-method [::delete-batch! ids]
      (set (store/-delete-batch! store ids)))
    (set (filter (partial delete! store) ids))))

;; ## Storage Utilities

(defn erase!!
  "Completely removes any data associated with the store. After this call, the
  store should be empty. This is not guaranteed to be an atomic operation!"
  [store]
  (if (satisfies? store/ErasableStore store)
    (measure-method [::erase!! nil]
      (store/-erase! store))
    (run! (comp (partial delete! store) :id)
          (store/-list store nil))))

(defn scan
  "Scans all the blocks in the store, building up a store-level summary. If
  given, the predicate function will be called with each block in the store.
  By default, all blocks are scanned."
  ([store]
   (scan store nil))
  ([store p]
   (-> (store/-list store nil)
       (cond->> p (filter p))
       (->> (reduce sum/update (sum/init))))))

(defn sync!
  "Synchronize blocks from the `source` store to the `dest` store. Returns a
  summary of the copied blocks. Options may include:

  - `:filter` a function to run on every block stats before it is copied to the
    `dest` store. If the function returns a falsey value, the block will not be
    copied."
  [source dest & {:as opts}]
  (-> (store/missing-blocks
        (store/-list source nil)
        (store/-list dest nil))
      (cond->>
        (:filter opts) (filter (:filter opts)))
      (->> (reduce
             (fn copy-block
               [summary stat]
               (put! dest (get source (:id stat)))
               (sum/update summary stat))
             (sum/init)))))

Fix nil passed to block/list as options map.


;;;
;;;   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 "cli4clj allows to create simple interactive command line interfaces for Clojure applications.
          For an example usage scenario please see the namespace cli4clj.example."}
  cli4clj.cli
  (:use
    [clojure.main :only [repl skip-if-eol skip-whitespace]]
    [clojure.string :only [blank? split]]
    clj-assorted-utils.util)
  (:import
    (java.io PushbackReader StringReader)
    (jline.console ConsoleReader)
    (jline.console.completer StringsCompleter)))

(defn cli-repl-print
  [arg]
  (if (not (nil? arg))
    (prn arg)))

(defn cli-repl-prompt
  []
  (print "cli# "))

(defn create-repl-read-fn
  [cmds]
  "The created read function is largely based on the exisiting repl read function:
   http://clojure.github.io/clojure/clojure.main-api.html#clojure.main/repl-read
   The main difference is that if the first argument on a line is a keyword,
   all elements on that line will be forwarded in a vector instead of being
   forwarded seperately."
  (fn [request-prompt request-exit]
    (or ({:line-start request-prompt :stream-end request-exit}
         (skip-whitespace *in*))
        (loop [v []]
          (let [input (read {:read-cond :allow} *in*)]
            (if (and (not (symbol? input)) (empty? v))
              (do
                (skip-if-eol *in*)
                input)
              (if (= :line-start (skip-whitespace *in*))
                (conj v input)
                (recur (conj v input)))))))))

(defn create-jline-read-fn
  [cmds]
  (let [in-rdr (doto (ConsoleReader.) (.addCompleter (StringsCompleter. (map name (keys cmds)))))
        rdr-fn (create-repl-read-fn cmds)]
    (fn [request-prompt request-exit]
      (binding [*in* (PushbackReader. (StringReader. (str (.readLine in-rdr) "\n")))]
        (rdr-fn request-prompt request-exit)))))

(defn resolve-cmd-alias
  [input-cmd cmds]
  (if (keyword? (cmds input-cmd))
    (cmds input-cmd)
    input-cmd))

(defn create-cli-eval-fn
  [cmds allow-eval print-err]
  (fn [arg]
    (if (and (vector? arg) (contains? cmds (keyword (first arg))))
      (let [cmd (resolve-cmd-alias (keyword (first arg)) cmds)]
        (try
          (apply
            (get-in cmds [cmd :fn])
            (rest arg))
          (catch Exception e
            (print-err (.getMessage e)))))
      (if allow-eval
        (eval arg)
        (print-err (str "Invalid command: \"" arg "\". Please type \"help\" to get an overview of commands."))))))

(defn create-cli-help-fn
  [cmds]
  (fn []
    (let [command-names (sort (keys cmds))]
      (doseq [c command-names]
        (if (map? (cmds c))
          (do
            (println (str (name c) "\t" (get-in cmds [c :short-info])))
            (when-let [li (get-in cmds [c :long-info])]
              (println (str "\t" (get-in cmds [c :long-info])))))
          (println (str (name c) "\tSee: " (name (cmds c)))))))))

(def cli-mandatory-default-options
  {:cmds {:exit {:fn (fn [] (System/exit 0))
                 :short-info "Exit the CLI."
                 :long-info "Terminate and close the command line interface."}
          :help {:short-info "Show help."
                 :long-info "Display a help text that lists all available commands including further detailed information about these commands."}}})

(defmulti print-err-fn (fn [arg] (= (type arg) Exception)))
(defmethod print-err-fn true [arg]
  (println-err (.getMessage arg)))
(defmethod print-err-fn false [arg]
  (println-err (str arg)))

(def cli-default-options
  {:allow-eval false
   :cmds {:e :exit
          :h :help
          :? :help
          :quit :exit
          :q :exit}
   :eval-factory create-cli-eval-fn
   :help-factory create-cli-help-fn
   :print cli-repl-print
   :print-err print-err-fn
   :prompt cli-repl-prompt
   :read-factory create-jline-read-fn})

(defn merge-options
  [defaults user-options mandatory-defaults]
  (merge-with (fn [a b] (if (and (map? a) (map? b))
                          (merge a b)
                          b))
              defaults user-options mandatory-defaults))

(defn get-cli-opts
  [user-options]
  (let [merged-opts (merge-options cli-default-options user-options cli-mandatory-default-options)]
    (assoc-in merged-opts [:cmds :help :fn] ((merged-opts :help-factory) (merged-opts :cmds)))))

(defn start-cli
  ([]
    (start-cli {}))
  ([user-options]
    (let [options (get-cli-opts user-options)]
      (repl
        :eval ((options :eval-factory) (options :cmds) (options :allow-eval) (options :print-err))
        :print (options :print)
        :prompt (options :prompt)
        :read ((options :read-factory) (options :cmds))))))

(defn cmd-vector-to-test-input-string
  [cmd-vec]
  (reduce (fn [s c] (str s c "\n")) "" cmd-vec))

(defn get-prompt-string
  [cli-opts]
  (with-out-str (((get-cli-opts cli-opts) :prompt))))

(defn start-test-cli
  [opts]
  (start-cli (assoc-in opts [:read-factory] create-repl-read-fn)))

(defn test-cli-stdout
  [cli-opts in-cmds]
  (let [out-str (with-out-str (with-in-str (cmd-vector-to-test-input-string in-cmds) (start-test-cli cli-opts)))]
    (.trim (.replaceAll out-str (get-prompt-string cli-opts) ""))))

(defn test-cli-stderr
  [cli-opts in-cmds]
  (with-err-str (with-out-str (with-in-str (cmd-vector-to-test-input-string in-cmds) (start-test-cli cli-opts)))))

;;;
;;;   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 "cli4clj allows to create simple interactive command line interfaces for Clojure applications.
          For an example usage scenario please see the namespace cli4clj.example."}
  cli4clj.cli
  (:use
    [clojure.main :only [repl skip-if-eol skip-whitespace]]
    [clojure.string :only [blank? split]]
    clj-assorted-utils.util)
  (:import
    (java.io PushbackReader StringReader)
    (jline.console ConsoleReader)
    (jline.console.completer StringsCompleter)))

(defn cli-repl-print
  [arg]
  (if (not (nil? arg))
    (prn arg)))

(defn cli-repl-prompt
  []
  (print "cli# "))

(defn create-repl-read-fn
  [cmds]
  "The created read function is largely based on the exisiting repl read function:
   http://clojure.github.io/clojure/clojure.main-api.html#clojure.main/repl-read
   The main difference is that if the first argument on a line is a keyword,
   all elements on that line will be forwarded in a vector instead of being
   forwarded seperately."
  (fn [request-prompt request-exit]
    (or ({:line-start request-prompt :stream-end request-exit}
         (skip-whitespace *in*))
        (loop [v []]
          (let [input (read {:read-cond :allow} *in*)]
            (if (and (not (symbol? input)) (empty? v))
              (do
                (skip-if-eol *in*)
                input)
              (if (= :line-start (skip-whitespace *in*))
                (conj v input)
                (recur (conj v input)))))))))

(defn create-jline-read-fn
  [cmds]
  (let [in-rdr (doto (ConsoleReader.) (.addCompleter (StringsCompleter. (map name (keys cmds)))))
        rdr-fn (create-repl-read-fn cmds)]
    (fn [request-prompt request-exit]
      (binding [*in* (PushbackReader. (StringReader. (str (.readLine in-rdr) "\n")))]
        (rdr-fn request-prompt request-exit)))))

(defn resolve-cmd-alias
  [input-cmd cmds]
  (if (keyword? (cmds input-cmd))
    (cmds input-cmd)
    input-cmd))

(defn create-cli-eval-fn
  [cmds allow-eval print-err]
  (fn [arg]
    (if (and (vector? arg) (contains? cmds (keyword (first arg))))
      (let [cmd (resolve-cmd-alias (keyword (first arg)) cmds)]
        (try
          (apply
            (get-in cmds [cmd :fn])
            (rest arg))
          (catch Exception e
            (print-err (.getMessage e)))))
      (if allow-eval
        (eval arg)
        (print-err (str "Invalid command: \"" arg "\". Please type \"help\" to get an overview of commands."))))))

(defn create-cli-help-fn
  [options]
  (fn []
    (let [cmds (:cmds options)
          command-names (sort (keys cmds))
          cmd-entry-delimiter (:help-cmd-entry-delimiter options)]
      (doseq [c command-names]
        (if (map? (cmds c))
          (do
            (println (str (name c) "\t" (get-in cmds [c :short-info])))
            (when-let [li (get-in cmds [c :long-info])]
              (println (str "\t" li)))
            (print cmd-entry-delimiter))
          (println (str (name c) "\tSee: " (name (cmds c)) cmd-entry-delimiter)))))))

(def cli-mandatory-default-options
  {:cmds {:exit {:fn (fn [] (System/exit 0))
                 :short-info "Exit the CLI."
                 :long-info "Terminate and close the command line interface."}
          :help {:short-info "Show help."
                 :long-info "Display a help text that lists all available commands including further detailed information about these commands."}}})

(defmulti print-err-fn (fn [arg] (= (type arg) Exception)))
(defmethod print-err-fn true [arg]
  (println-err (.getMessage arg)))
(defmethod print-err-fn false [arg]
  (println-err (str arg)))

(def cli-default-options
  {:allow-eval false
   :cmds {:e :exit
          :h :help
          :? :help
          :quit :exit
          :q :exit}
   :eval-factory create-cli-eval-fn
   :help-factory create-cli-help-fn
   :help-cmd-entry-delimiter "\n"
   :print cli-repl-print
   :print-err print-err-fn
   :prompt cli-repl-prompt
   :read-factory create-jline-read-fn})

(defn merge-options
  [defaults user-options mandatory-defaults]
  (merge-with (fn [a b] (if (and (map? a) (map? b))
                          (merge a b)
                          b))
              defaults user-options mandatory-defaults))

(defn get-cli-opts
  [user-options]
  (let [merged-opts (merge-options cli-default-options user-options cli-mandatory-default-options)]
    (assoc-in merged-opts [:cmds :help :fn] ((merged-opts :help-factory) merged-opts))))

(defn start-cli
  ([]
    (start-cli {}))
  ([user-options]
    (let [options (get-cli-opts user-options)]
      (repl
        :eval ((options :eval-factory) (options :cmds) (options :allow-eval) (options :print-err))
        :print (options :print)
        :prompt (options :prompt)
        :read ((options :read-factory) (options :cmds))))))

(defn cmd-vector-to-test-input-string
  [cmd-vec]
  (reduce (fn [s c] (str s c "\n")) "" cmd-vec))

(defn get-prompt-string
  [cli-opts]
  (with-out-str (((get-cli-opts cli-opts) :prompt))))

(defn start-test-cli
  [opts]
  (start-cli (assoc-in opts [:read-factory] create-repl-read-fn)))

(defn test-cli-stdout
  [cli-opts in-cmds]
  (let [out-str (with-out-str (with-in-str (cmd-vector-to-test-input-string in-cmds) (start-test-cli cli-opts)))]
    (.trim (.replaceAll out-str (get-prompt-string cli-opts) ""))))

(defn test-cli-stderr
  [cli-opts in-cmds]
  (with-err-str (with-out-str (with-in-str (cmd-vector-to-test-input-string in-cmds) (start-test-cli cli-opts)))))

Add help-cmd-entry-delimiter.

Add help-cmd-entry-delimiter.


(ns curve.core
  (:require [curve.math :as math]))

(enable-console-print!)

(println "This text is printed from src/curve/core.cljs. Go ahead and edit it and see reloading in action.")

;; define your app data so that it doesn't get over-written on reload

(defonce app-state (atom {:text "Hello world!"}))

(defn on-js-reload []
  ;; optionally touch your app-state to force rerendering depending on
  ;; your application
  ;; (swap! app-state update-in [:__figwheel_counter] inc)
)

(def canvas-dom )

(println (.-innerText (.getElementById js/document "header1")))

(defn init []
  (let [canvas-dom (.getElementById js/document "main-canvas")]
    (set! (.-width canvas-dom) 800)
    (set! (.-height canvas-dom) 600)
    canvas-dom))

(defn draw-pixel [image data x y r g b & a]
  (println "draw-pixel" x y r g b (first a))
  (let [offset (+ (* x 4) (* y (.-height image) 4))]
    (aset data offset r)
    (aset data (+ offset 1) g)
    (aset data (+ offset 2) b)
    (aset data (+ offset 3) (or (first a) 255)))
  data)

(defn draw-pixel-color [image data x y color]
  (let [length (count color)]
    (cond
      (= length 1)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 0)
                  (nth color 0)
                  255)
      (= length 2)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 0)
                  (nth color 0)
                  (nth color 1))
      (= length 3)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 1)
                  (nth color 2)
                  255)
      (= length 4)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 1)
                  (nth color 2)
                  (nth color 3))))
  data)

(defn draw-line-inner [image data x1 y1 x2 y2 dx dy error x y ystep color steep]
  (println "draw-line-inner" x1 y1 x2 y2 dx dy error x y ystep color steep)
  (if (<= x x2)
    (do
      (if steep
        (draw-pixel-color image data y x color)
        (draw-pixel-color image data x y color))
      (let [error (- error dy)]
        (println "error" error)
        (if (< error 0)
          (recur image data x1 y1 x2 y2 dx dy (+ error dx) (+ x 1) (+ y ystep) ystep color steep)
              (recur image data x1 y1 x2 y2 dx dy error (+ x 1) y ystep color steep))))))

(defn draw-line [image data x1 y1 x2 y2 color]
  (let [steep (> (math/abs (- y2 y1)) (math/abs (- x2 x1)))]
    (if steep
      (recur image data y1 x1 y2 x2 color)
      (if (> x1 x2)
        (recur image data y2 x2 y1 x1 color)
        (let [dx (- x2 x1)
              dy (- y2 y1)
              error (/ dx 2)]
          (if (< y1 y2)
            (draw-line-inner image data x1 y1 x2 y2 dx dy error x1 y1 1 color steep)
            (draw-line-inner image data x1 y1 x2 y2 dx dy error x1 y1 -1 color steep)))))))

(defn draw [canvas]
  (let [ctx (.getContext canvas "2d")
        canvas-width (.-width canvas)
        canvas-height (.-height canvas)
        image (.createImageData ctx canvas-width canvas-height)
        data (.-data image)]
    ;(draw-pixel image data 0 0 0 0 0) ;test
    ;(draw-pixel-color image data 20 20 [255 0 0]) ;test
    (draw-line image data 30 30 200 200 [0 0 0])
    (.putImageData ctx image 0 0)))

(draw (init))

(ns curve.core
  (:require [curve.math :as math]))

(enable-console-print!)

(println "This text is printed from src/curve/core.cljs. Go ahead and edit it and see reloading in action.")

;; define your app data so that it doesn't get over-written on reload

(defonce app-state (atom {:text "Hello world!"}))

(defn on-js-reload []
  ;; optionally touch your app-state to force rerendering depending on
  ;; your application
  ;; (swap! app-state update-in [:__figwheel_counter] inc)
)

(def canvas-dom )

(println (.-innerText (.getElementById js/document "header1")))

(defn init []
  (let [canvas-dom (.getElementById js/document "main-canvas")]
    (set! (.-width canvas-dom) 800)
    (set! (.-height canvas-dom) 600)
    canvas-dom))

(defn draw-pixel [image data x y r g b & a]
  (println "draw-pixel" x y r g b (first a))
  (let [offset (+ (* x 4) (* y (.-width image) 4))]
    (aset data offset r)
    (aset data (+ offset 1) g)
    (aset data (+ offset 2) b)
    (aset data (+ offset 3) (or (first a) 255)))
  data)

(defn draw-pixel-color [image data x y color]
  (let [length (count color)]
    (cond
      (= length 1)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 0)
                  (nth color 0)
                  255)
      (= length 2)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 0)
                  (nth color 0)
                  (nth color 1))
      (= length 3)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 1)
                  (nth color 2)
                  255)
      (= length 4)
      (draw-pixel image data x y
                  (nth color 0)
                  (nth color 1)
                  (nth color 2)
                  (nth color 3))))
  data)

(defn draw-line-inner [image data x1 y1 x2 y2 dx dy error x y ystep color steep]
  (println "draw-line-inner" x1 y1 x2 y2 dx dy error x y ystep color steep)
  (if (<= x x2)
    (do
      (if steep
        (draw-pixel-color image data y x color)
        (draw-pixel-color image data x y color))
      (let [error (- error dy)]
        ;(println "error" error)
        (if (< error 0)
          (recur image data x1 y1 x2 y2 dx dy (+ error dx) (+ x 1) (+ y ystep) ystep color steep)
              (recur image data x1 y1 x2 y2 dx dy error (+ x 1) y ystep color steep))))))

(defn draw-line [image data x1 y1 x2 y2 color]
  (let [steep (> (math/abs (- y2 y1)) (math/abs (- x2 x1)))]
    (if steep
      (recur image data y1 x1 y2 x2 color)
      (if (> x1 x2)
        (recur image data y2 x2 y1 x1 color)
        (let [dx (- x2 x1)
              dy (- y2 y1)
              error (/ dx 2)]
          (if (< y1 y2)
            (draw-line-inner image data x1 y1 x2 y2 dx dy error x1 y1 1 color steep)
            (draw-line-inner image data x1 y1 x2 y2 dx dy error x1 y1 -1 color steep)))))))

(defn draw [canvas]
  (let [ctx (.getContext canvas "2d")
        canvas-width (.-width canvas)
        canvas-height (.-height canvas)
        image (.createImageData ctx canvas-width canvas-height)
        data (.-data image)]
    ;(draw-pixel image data 0 0 0 0 0) ;test
    ;(run! (fn [x] (draw-pixel-color image data 0 x [255 0 0])) (range 30 600 1))
    ;(draw-pixel-color image data 200 200 [255 0 0]) ;test
    (draw-line image data 30 30 200 200 [0 0 0])
    (.putImageData ctx image 0 0)))

(draw (init))

fix daw pixel bug

fix daw pixel bug


(ns ezglib.game)

(defmacro defgame
  "Defs an ezglib game."
  [name & {:keys [width height element element-id game-id modes mode canvas
                 assets on-load load-update start-on-load? preload]}]
  (let [pre (if preload `(~preload) `(fn [] nil))
        onld (if on-load
               (if start-on-load?
                 '(fn []
                    (~on-load)
                    (ezglib.game/main-loop! ~name))
                 on-load)
               (if start-on-load?
                 `(fn [] (ezglib.game/main-loop! ~name))
                 `(fn [] nil)))
        ast (if assets
              `(ezglib.asset/load!
                :game ~name
                :assets ~assets
                :update ~load-update
                :on-load ~onld))]
    `(let [~'canvas (or ~canvas (.createElement js/document "canvas"))
           ~'gl (ezglib.gl/create-context ~'canvas)
           ~'audio-context (ezglib.sound/create-context)
           e# (if ~element-id
                (.getElementById js/document ~element-id)
                (if ~element
                  ~element
                  (.-body js/document)))]
       (def ~name {:modes (atom nil)
                   :mode (atom nil)
                   :element e#
                   :loop (atom true)
                   :canvas ~'canvas
                   :event-queue (atom cljs.core.PersistentQueue.EMPTY)
                   :handlers (atom nil)
                   :handler-types (atom nil)
                   :gl ~'gl
                   :audio-context ~'audio-context
                   :dt (atom 0)
                   :now (atom (.getTime (js/Date.)))})
       (.appendChild e# ~'canvas)
       (set! (.-id ~'canvas) ~game-id)
       (set! (.-width ~'canvas) ~width)
       (set! (.-height ~'canvas) ~height)
       (ezglib.gl/reset-viewport! ~'gl)
       (ezglib.input/init! ~name)
       (ezglib.gl/clear! ~'gl)
       ~pre
       ~ast
       (reset! (:modes ~name) (or ~modes {:default (ezglib.game/mode)}))
       (ezglib.game/set-mode! ~name ~mode)
       ~name)))

(ns ezglib.game)

(defmacro defgame
  "Defs an ezglib game."
  [name & {:keys [width height element element-id game-id modes mode canvas
                 assets on-load load-update start-on-load? preload fps]}]
  (let [pre (if preload `(~preload) `(fn [] nil))
        onld (if on-load
               (if start-on-load?
                 (if fps
                   '(fn []
                     (~on-load)
                     (ezglib.game/main-loop! ~name ~fps))
                   '(fn []
                     (~on-load)
                     (ezglib.game/main-loop! ~name)))
                 on-load)
               (if start-on-load?
                 (if fps
                   `(fn [] (ezglib.game/main-loop! ~name ~fps))
                   `(fn [] (ezglib.game/main-loop! ~name)))
                 `(fn [] nil)))
        ast (if assets
              `(ezglib.asset/load!
                :game ~name
                :assets ~assets
                :update ~load-update
                :on-load ~onld))]
    `(let [~'canvas (or ~canvas (.createElement js/document "canvas"))
           ~'gl (ezglib.gl/create-context ~'canvas)
           ~'audio-context (ezglib.sound/create-context)
           e# (if ~element-id
                (.getElementById js/document ~element-id)
                (if ~element
                  ~element
                  (.-body js/document)))]
       (def ~name {:modes (atom nil)
                   :mode (atom nil)
                   :element e#
                   :loop (atom true)
                   :canvas ~'canvas
                   :event-queue (atom cljs.core.PersistentQueue.EMPTY)
                   :handlers (atom nil)
                   :handler-types (atom nil)
                   :gl ~'gl
                   :audio-context ~'audio-context
                   :dt (atom 0)
                   :now (atom (.getTime (js/Date.)))})
       (.appendChild e# ~'canvas)
       (set! (.-id ~'canvas) ~game-id)
       (set! (.-width ~'canvas) ~width)
       (set! (.-height ~'canvas) ~height)
       (ezglib.gl/reset-viewport! ~'gl)
       (ezglib.input/init! ~name)
       (ezglib.gl/clear! ~'gl)
       ~pre
       ~ast
       (reset! (:modes ~name) (or ~modes {:default (ezglib.game/mode)}))
       (ezglib.game/set-mode! ~name ~mode)
       ~name)))

Add fps option to defgame.

Add fps option to defgame.


;; Copyright (c) 2015 Andrey Antukh <niwi@niwi.nz>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; * Redistributions of source code must retain the above copyright notice, this
;;   list of conditions and the following disclaimer.
;;
;; * Redistributions in binary form must reproduce the above copyright notice,
;;   this list of conditions and the following disclaimer in the documentation
;;   and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(ns catacumba.http
  (:require [catacumba.impl.http :refer [response]]))

(defn continue
  ([body] (response body 100))
  ([body headers] (response body 100 headers)))

(defn ok
  ([body] (response body 200))
  ([body headers] (response body 200 headers)))

(defn created
  ([location] (response "" 201 {:location location}))
  ([location body] (response body 201 {:location location}))
  ([location body headers] (response body 201 (merge headers {:location location}))))

(defn accepted
  ([body] (response body 202))
  ([body headers] (response body 202 headers)))

(defn no-content
  ([] (response "" 204))
  ([headers] (response "" 204 headers)))

(defn moved-permanently
  ([location] (response "" 301 {:location location}))
  ([location body] (response body 301 {:location location}))
  ([location body headers] (response body 301 (merge headers {:location location}))))

(defn found
  ([location] (response "" 302 {:location location}))
  ([location body] (response body 302 {:location location}))
  ([location body headers] (response body 302 (merge headers {:location location}))))

(defn see-other
  ([location] (response "" 303 {:location location}))
  ([location body] (response body 303 {:location location}))
  ([location body headers] (response body 303 (merge headers {:location location}))))

(defn temporary-redirect
  ([location] (response "" 307 {:location location}))
  ([location body] (response body 307 {:location location}))
  ([location body headers] (response body 307 (merge headers {:location location}))))

(defn bad-request
  ([body] (response body 400))
  ([body headers] (response body 400 headers)))

(defn unauthorized
  ([body] (response body 401))
  ([body headers] (response body 401 headers)))

(defn forbidden
  ([body] (response body 403))
  ([body headers] (response body 403 headers)))

(defn not-found
  ([body] (response body 404))
  ([body headers] (response body 404 headers)))

(defn method-not-allowed
  ([body] (response body 405))
  ([body headers] (response body 405 headers)))

(defn not-acceptable
  ([body] (response body 406))
  ([body headers] (response body 406 headers)))

(defn conflict
  ([body] (response body 409))
  ([body headers] (response body 409 headers)))

(defn gone
  ([body] (response body 410))
  ([body headers] (response body 410 headers)))

(defn precondition-failed
  ([body] (response body 412))
  ([body headers] (response body 412 headers)))

(defn unsupported-mediatype
  ([body] (response body 415))
  ([body headers] (response body 415 headers)))

(defn too-many-requests
  ([body] (response body 429))
  ([body headers] (response body 429 headers)))

(defn internal-server-error
  ([body] (response body 500))
  ([body headers] (response body 500 headers)))

(defn not-implemented
  ([body] (response body 501))
  ([body headers] (response body 501 headers)))

;; Copyright (c) 2015 Andrey Antukh <niwi@niwi.nz>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; * Redistributions of source code must retain the above copyright notice, this
;;   list of conditions and the following disclaimer.
;;
;; * Redistributions in binary form must reproduce the above copyright notice,
;;   this list of conditions and the following disclaimer in the documentation
;;   and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(ns catacumba.http
  (:require [catacumba.impl.http :refer [response]]))

(defn continue
  ([body] (response body 100))
  ([body headers] (response body 100 headers)))

(defn ok
  "HTTP 200 OK
  Should be used to indicate nonspecific success. Must not be used to
  communicate errors in the response body.

  In most cases, 200 is the code the client hopes to see. It indicates that
  the REST API successfully carried out whatever action the client requested,
  and that no more specific code in the 2xx series is appropriate. Unlike
  the 204 status code, a 200 response should include a response body."
  ([body] (response body 200))
  ([body headers] (response body 200 headers)))

(defn created
  "HTTP 201 Created
  Must be used to indicate successful resource creation.

  A REST API responds with the 201 status code whenever a collection creates,
  or a store adds, a new resource at the client's request. There may also be
  times when a new resource is created as a result of some controller action,
  in which case 201 would also be an appropriate response."
  ([location] (response "" 201 {:location location}))
  ([location body] (response body 201 {:location location}))
  ([location body headers] (response body 201 (merge headers {:location location}))))

(defn accepted
  "HTTP 202 Accepted
  Must be used to indicate successful start of an asynchronous action.

  A 202 response indicates that the client's request will be handled
  asynchronously. This response status code tells the client that the request
  appears valid, but it still may have problems once it's finally processed.
  A 202 response is typically used for actions that take a long while to
  process."
  ([body] (response body 202))
  ([body headers] (response body 202 headers)))

(defn no-content
  "HTTP 204 No Content
  Should be used when the response body is intentionally empty.

  The 204 status code is usually sent out in response to a PUT, POST, or
  DELETE request, when the REST API declines to send back any status message
  or representation in the response message's body. An API may also send 204
  in conjunction with a GET request to indicate that the requested resource
  exists, but has no state representation to include in the body."
  ([] (response "" 204))
  ([headers] (response "" 204 headers)))

(defn moved-permanently
  "301 Moved Permanently
  Should be used to relocate resources.

  The 301 status code indicates that the REST API's resource model has been
  significantly redesigned and a new permanent URI has been assigned to the
  client's requested resource. The REST API should specify the new URI in
  the response's Location header."
  ([location] (response "" 301 {:location location}))
  ([location body] (response body 301 {:location location}))
  ([location body headers] (response body 301 (merge headers {:location location}))))

(defn found
  "HTTP 302 Found
  Should not be used.

  The intended semantics of the 302 response code have been misunderstood
  by programmers and incorrectly implemented in programs since version 1.0
  of the HTTP protocol.
  The confusion centers on whether it is appropriate for a client to always
  automatically issue a follow-up GET request to the URI in response's
  Location header, regardless of the original request's method. For the
  record, the intent of 302 is that this automatic redirect behavior only
  applies if the client's original request used either the GET or HEAD
  method.

  To clear things up, HTTP 1.1 introduced status codes 303 (\"See Other\")
  and 307 (\"Temporary Redirect\"), either of which should be used
  instead of 302."
  ([location] (response "" 302 {:location location}))
  ([location body] (response body 302 {:location location}))
  ([location body headers] (response body 302 (merge headers {:location location}))))

(defn see-other
  "HTTP 303 See Other
  Should be used to refer the client to a different URI.

  A 303 response indicates that a controller resource has finished its work,
  but instead of sending a potentially unwanted response body, it sends the
  client the URI of a response resource. This can be the URI of a temporary
  status message, or the URI to some already existing, more permanent,
  resource.
  Generally speaking, the 303 status code allows a REST API to send a
  reference to a resource without forcing the client to download its state.
  Instead, the client may send a GET request to the value of the Location
  header."
  ([location] (response "" 303 {:location location}))
  ([location body] (response body 303 {:location location}))
  ([location body headers] (response body 303 (merge headers {:location location}))))

(defn temporary-redirect
  "HTTP 307 Temporary Redirect
  Should be used to tell clients to resubmit the request to another URI.

  HTTP/1.1 introduced the 307 status code to reiterate the originally
  intended semantics of the 302 (\"Found\") status code. A 307 response
  indicates that the REST API is not going to process the client's request.
  Instead, the client should resubmit the request to the URI specified by
  the response message's Location header.

  A REST API can use this status code to assign a temporary URI to the
  client's requested resource. For example, a 307 response can be used to
  shift a client request over to another host."
  ([location] (response "" 307 {:location location}))
  ([location body] (response body 307 {:location location}))
  ([location body headers] (response body 307 (merge headers {:location location}))))

(defn bad-request
  "HTTP 400 Bad Request
  May be used to indicate nonspecific failure.

  400 is the generic client-side error status, used when no other 4xx error
  code is appropriate."
  ([body] (response body 400))
  ([body headers] (response body 400 headers)))

(defn unauthorized
  "HTTP 401 Unauthorized
  Must be used when there is a problem with the client credentials.

  A 401 error response indicates that the client tried to operate on a
  protected resource without providing the proper authorization. It may have
  provided the wrong credentials or none at all."
  ([body] (response body 401))
  ([body headers] (response body 401 headers)))

(defn forbidden
  "HTTP 403 Forbidden
  Should be used to forbid access regardless of authorization state.

  A 403 error response indicates that the client's request is formed
  correctly, but the REST API refuses to honor it. A 403 response is not a
  case of insufficient client credentials; that would be 401 (\"Unauthorized\").
  REST APIs use 403 to enforce application-level permissions. For example, a
  client may be authorized to interact with some, but not all of a REST API's
  resources. If the client attempts a resource interaction that is outside of
  its permitted scope, the REST API should respond with 403."
  ([body] (response body 403))
  ([body headers] (response body 403 headers)))

(defn not-found
  "HTTP 404 Not Found
  Must be used when a client's URI cannot be mapped to a resource.

  The 404 error status code indicates that the REST API can't map the
  client's URI to a resource."
  ([body] (response body 404))
  ([body headers] (response body 404 headers)))

(defn method-not-allowed
  ([body] (response body 405))
  ([body headers] (response body 405 headers)))

(defn not-acceptable
  ([body] (response body 406))
  ([body headers] (response body 406 headers)))

(defn conflict
  ([body] (response body 409))
  ([body headers] (response body 409 headers)))

(defn gone
  ([body] (response body 410))
  ([body headers] (response body 410 headers)))

(defn precondition-failed
  ([body] (response body 412))
  ([body headers] (response body 412 headers)))

(defn unsupported-mediatype
  ([body] (response body 415))
  ([body headers] (response body 415 headers)))

(defn too-many-requests
  ([body] (response body 429))
  ([body headers] (response body 429 headers)))

(defn internal-server-error
  ([body] (response body 500))
  ([body headers] (response body 500 headers)))

(defn not-implemented
  ([body] (response body 501))
  ([body headers] (response body 501 headers)))

Add descriptive docstrings to some http functions.


(ns akvo.lumen.lib.visualisation.map-config
  (:require [clojure.string :as str]
            [akvo.lumen.lib.aggregation.filter :as filter]
            [hugsql.core :as hugsql]))

(hugsql/def-db-fns "akvo/lumen/lib/dataset.sql")

(defn layer-point-color [layer-index]
    (get
     {0 "#2ca409"
      1 "#096ba4"
      2 "#7a09a4"
      3 "#a4092a"
      4 "#fff721" } layer-index "#000000"))

(defn marker-width [point-size]
  (let [point-size (if (string? point-size)
                     (Long/parseLong point-size)
                     point-size)]
    ({1 5
      2 7
      3 9
      4 10
      5 13} point-size 5)))

(defn point-color-css [point-color-column point-color-mapping]
  (when point-color-column
    (for [{:strs [value color]} point-color-mapping]
      (format "[ %s = %s ] { marker-fill: %s }"
              point-color-column
              (if (string? value)
                (format "'%s'" value)
                value)
              (pr-str color)))))

(defn point-cartocss [point-size point-color-column point-color-mapping layer-index]
  (format "#s {
              marker-allow-overlap: true;
              marker-fill-opacity: 0.8;
              marker-fill: %s;
              marker-line-color: #fff;
              marker-width: %s;
              %s
           }"
          (layer-point-color layer-index)
          (marker-width point-size)
          (str/join " " (point-color-css point-color-column point-color-mapping))))

(defn shape-cartocss [layer-index layer]
  (cond-> (format "#s {
              polygon-opacity: 0.8;
              polygon-fill: transparent;
              line-width: 2;
              line-color: rgba(0,0,0,0.3);
           }
           "
          (layer-point-color layer-index))
          (get layer "shapeLabelColumn")
          (str (format "#s::labels {
            text-name: [%s];
            text-face-name: 'DejaVu Sans Book';
            text-size: 10;
            text-fill: #000;
          }"
          (get layer "shapeLabelColumn"))))
)

(defn shape-aggregation-cartocss [layer-index layer]
  (cond-> (format "#s {
              polygon-opacity: 0.8;
              polygon-fill: [shapefill];
              line-width: 0.5;
              line-color: rgba(0,0,0,0.3);
           }
           "
          (layer-point-color layer-index))
          (get layer "shapeLabelColumn")
          (str (format "#s::labels {
            text-name: [%s];
            text-face-name: 'DejaVu Sans Book';
            text-size: 10;
            text-fill: #000;
          }"
          (get layer "shapeLabelColumn"))))
)

(defn cartocss [layer layer-index metadata-array]
  (cond
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (shape-aggregation-cartocss layer-index layer)

    (= (get layer "layerType") "geo-shape")
    (shape-cartocss layer-index layer)

    :else
    (point-cartocss (get layer "pointSize") (get layer "pointColorColumn") (get (nth metadata-array layer-index) "pointColorMapping") layer-index)
  )
)

(defn trim-css [s]
  (-> s
      str/trim
      (str/replace #"\n" " ")
      (str/replace #" +" " ")))

; Should convert hex string to hue for hsl color. Use string matching as proof of concept for now
(defn color-to-hue [s]
  (cond
    (= s "#FF0000")
    "0"

    (= s "#00FF00")
    "120"

    (= s "#0000FF")
    "240"
  )
)

(defn shape-aggregagation-extra-cols-sql [popup table-name prefix postfix]
  (if
    (= (count popup) 0)
    ""
    (str prefix (clojure.string/join "," (map (fn [popupObj] (str table-name "." (get popupObj "column"))) popup)) postfix)
  )
)

(defn popup-and-label-cols [popup-cols label-col]
  (cond
    (and (boolean popup-cols) (boolean label-col))
    (distinct (conj popup-cols {"column" label-col}))

    (boolean popup-cols)
    popup-cols

    (boolean label-col)
    [{"column" label-col}]

    :else
    []
  )
)

(defn shape-aggregation-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer layer-index tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "aggregationDataset")})
    point-table-name table-name
    point-columns columns
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    shape-table-name table-name
    shape-columns columns
    aggregation-method (get current-layer "aggregationMethod" "avg")
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} point-columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)))
    hue (color-to-hue (clojure.string/upper-case (get current-layer "gradientColor" "#FF0000")))
    extra-cols (popup-and-label-cols (get current-layer "popup") (get current-layer "shapeLabelColumn"))
    ]

    (format "with temp_table as
              (select
                  %s
                  %s.%s,
                  %s(pointTable.%s::decimal) AS aggregation
                from %s
                left join (select * from %s)pointTable on
                st_contains(%s.%s, pointTable.%s)
                GROUP BY %s.%s %s)
            select
              %s
              %s,
              aggregation as _aggregation,
              CASE WHEN aggregation IS NULL THEN
                  'grey'
                ELSE
                  concat(
                    'hsl(%s, 75%%, ',
                    100 - floor(
                      CASE
                        WHEN (select max(aggregation) from temp_table)::decimal=(select min(aggregation) from temp_table)::decimal THEN 0
                        ELSE
                          (
                            (aggregation::decimal - (select min(aggregation) from temp_table)::decimal) /
                            ((select max(aggregation) from temp_table)::decimal - (select min(aggregation) from temp_table)::decimal)
                          ) * 50
                      END
                    ),
                    '%%)'
                  )
              END as shapefill
            from
              temp_table;
            "

            (shape-aggregagation-extra-cols-sql extra-cols shape-table-name "" ",")
            shape-table-name
            (get current-layer "geom")
            aggregation-method
            (get current-layer "aggregationColumn")
            shape-table-name
            point-table-name
            shape-table-name
            (get current-layer "geom")
            (get current-layer "aggregationGeomColumn")
            shape-table-name
            (get current-layer "geom")
            (shape-aggregagation-extra-cols-sql extra-cols shape-table-name "," "")
            (shape-aggregagation-extra-cols-sql extra-cols "temp_table" "" ",")
            (get current-layer "geom")
            hue
            )))

(defn point-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)))]
    (format "select %s from %s where %s"
            (str/join ", " cols)
            table-name
            where-clause)))

(defn shape-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)
                (get current-layer "shapeLabelColumn") (conj (get current-layer "shapeLabelColumn"))))]
    (format "select %s from %s where %s"
            (str/join ", " cols)
            table-name
            where-clause)))

(defn get-sql [columns table-name geom-column popup-columns point-color-column where-clause layer layer-index tenant-conn]
  (cond
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (shape-aggregation-sql columns table-name geom-column popup-columns point-color-column where-clause layer layer-index tenant-conn)

    (= (get layer "layerType") "geo-shape")
    (shape-sql columns table-name geom-column popup-columns point-color-column where-clause layer tenant-conn)

    :else
    (point-sql columns table-name geom-column popup-columns point-color-column where-clause layer tenant-conn)
  )
)

(defn get-interactivity [layer popup-columns]
  (if
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (into ["_aggregation"] popup-columns)
    popup-columns
  )
)

(defn get-geom-column [layer-spec]
  (if-let [geom (get layer-spec "geom")]
    geom
    (let [{:strs [latitude longitude]} layer-spec]
      (format "ST_SetSRID(ST_MakePoint(%s, %s), 4326) AS latlong" longitude latitude))))

(defn get-layers [layers metadata-array table-name conn]
  (map-indexed (fn [idx, current-layer]
                (let [geom-column (get-geom-column current-layer)
                      {:keys [columns]} (dataset-by-id conn {:id (get current-layer "datasetId")})
                      where-clause (filter/sql-str columns (get current-layer "filters"))
                      popup-columns (mapv #(get % "column")
                                         (get current-layer "popup"))
                     point-color-column (get current-layer "pointColorColumn")]
                { "type" "mapnik"
                  "options" {
                    "cartocss" (trim-css (cartocss current-layer idx metadata-array))
                    "cartocss_version" "2.0.0"
                    "geom_column" (or (get current-layer "geom") "latlong")
                    "interactivity" (get-interactivity current-layer popup-columns)
                    "sql" (get-sql columns table-name geom-column popup-columns point-color-column where-clause current-layer idx conn)
                    "srid" "4326"
                  }})) layers))

(defn build [table-name layers metadata-array tenant-conn]
  {"version" "1.6.0"
   "buffersize" {
    "png" 8
    "grid.json" 8
    "mvt" 0
   }
   "layers" (get-layers layers metadata-array table-name tenant-conn)})

(ns akvo.lumen.lib.visualisation.map-config
  (:require [clojure.string :as str]
            [akvo.lumen.lib.aggregation.filter :as filter]
            [hugsql.core :as hugsql]))

(hugsql/def-db-fns "akvo/lumen/lib/dataset.sql")

(defn layer-point-color [layer-index]
    (get
     {0 "#2ca409"
      1 "#096ba4"
      2 "#7a09a4"
      3 "#a4092a"
      4 "#fff721" } layer-index "#000000"))

(defn marker-width [point-size]
  (let [point-size (if (string? point-size)
                     (Long/parseLong point-size)
                     point-size)]
    ({1 5
      2 7
      3 9
      4 10
      5 13} point-size 5)))

(defn point-color-css [point-color-column point-color-mapping]
  (when point-color-column
    (for [{:strs [value color]} point-color-mapping]
      (format "[ %s = %s ] { marker-fill: %s }"
              point-color-column
              (if (string? value)
                (format "'%s'" value)
                value)
              (pr-str color)))))

(defn point-cartocss [point-size point-color-column point-color-mapping layer-index]
  (format "#s {
              marker-allow-overlap: true;
              marker-fill-opacity: 0.8;
              marker-fill: %s;
              marker-line-color: #fff;
              marker-width: %s;
              %s
           }"
          (layer-point-color layer-index)
          (marker-width point-size)
          (str/join " " (point-color-css point-color-column point-color-mapping))))

(defn shape-cartocss [layer-index layer]
  (cond-> (format "#s {
              polygon-opacity: 0.8;
              polygon-fill: transparent;
              line-width: 2;
              line-color: rgba(0,0,0,0.3);
           }
           "
          (layer-point-color layer-index))
          (get layer "shapeLabelColumn")
          (str (format "#s::labels {
            text-name: [%s];
            text-face-name: 'DejaVu Sans Book';
            text-size: 10;
            text-fill: #000;
          }"
          (get layer "shapeLabelColumn"))))
)

(defn shape-aggregation-cartocss [layer-index layer]
  (cond-> (format "#s {
              polygon-opacity: 0.8;
              polygon-fill: [shapefill];
              line-width: 0.5;
              line-color: rgba(0,0,0,0.3);
           }
           "
          (layer-point-color layer-index))
          (get layer "shapeLabelColumn")
          (str (format "#s::labels {
            text-name: [%s];
            text-face-name: 'DejaVu Sans Book';
            text-size: 10;
            text-fill: #000;
          }"
          (get layer "shapeLabelColumn"))))
)

(defn cartocss [layer layer-index metadata-array]
  (cond
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (shape-aggregation-cartocss layer-index layer)

    (= (get layer "layerType") "geo-shape")
    (shape-cartocss layer-index layer)

    :else
    (point-cartocss (get layer "pointSize") (get layer "pointColorColumn") (get (nth metadata-array layer-index) "pointColorMapping") layer-index)
  )
)

(defn trim-css [s]
  (-> s
      str/trim
      (str/replace #"\n" " ")
      (str/replace #" +" " ")))

; Should convert hex string to hue for hsl color. Use string matching as proof of concept for now
(defn color-to-hue [s]
  (cond
    (= s "#FF0000")
    "0"

    (= s "#00FF00")
    "120"

    (= s "#0000FF")
    "240"
  )
)

(defn shape-aggregagation-extra-cols-sql [popup table-name prefix postfix]
  (if
    (= (count popup) 0)
    ""
    (str prefix (clojure.string/join "," (map (fn [popupObj] (str table-name "." (get popupObj "column"))) popup)) postfix)
  )
)

(defn popup-and-label-cols [popup-cols label-col]
  (cond
    (and (boolean popup-cols) (boolean label-col))
    (distinct (conj popup-cols {"column" label-col}))

    (boolean popup-cols)
    popup-cols

    (boolean label-col)
    [{"column" label-col}]

    :else
    []
  )
)

(defn shape-aggregation-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer layer-index tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "aggregationDataset")})
    point-table-name table-name
    point-columns columns
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    shape-table-name table-name
    shape-columns columns
    aggregation-method (get current-layer "aggregationMethod" "avg")
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} point-columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)))
    hue (color-to-hue (clojure.string/upper-case (get current-layer "gradientColor" "#FF0000")))
    extra-cols (popup-and-label-cols (get current-layer "popup") (get current-layer "shapeLabelColumn"))
    ]

    (format "with temp_table as
              (select
                  %s
                  %s.%s,
                  %s(pointTable.%s::decimal) AS aggregation
                from %s
                left join (select * from %s)pointTable on
                st_contains(%s.%s, pointTable.%s)
                GROUP BY %s.%s %s)
            select
              %s
              %s,
              aggregation as _aggregation,
              CASE WHEN aggregation IS NULL THEN
                  'grey'
                ELSE
                  concat(
                    'hsl(%s, 75%%, ',
                    100 - floor(
                      CASE
                        WHEN (select max(aggregation) from temp_table)::decimal=(select min(aggregation) from temp_table)::decimal THEN 50
                        ELSE
                          (
                            (aggregation::decimal - (select min(aggregation) from temp_table)::decimal) /
                            ((select max(aggregation) from temp_table)::decimal - (select min(aggregation) from temp_table)::decimal)
                          ) * 50
                      END
                    ),
                    '%%)'
                  )
              END as shapefill
            from
              temp_table;
            "

            (shape-aggregagation-extra-cols-sql extra-cols shape-table-name "" ",")
            shape-table-name
            (get current-layer "geom")
            aggregation-method
            (get current-layer "aggregationColumn")
            shape-table-name
            point-table-name
            shape-table-name
            (get current-layer "geom")
            (get current-layer "aggregationGeomColumn")
            shape-table-name
            (get current-layer "geom")
            (shape-aggregagation-extra-cols-sql extra-cols shape-table-name "," "")
            (shape-aggregagation-extra-cols-sql extra-cols "temp_table" "" ",")
            (get current-layer "geom")
            hue
            )))

(defn point-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)))]
    (format "select %s from %s where %s"
            (str/join ", " cols)
            table-name
            where-clause)))

(defn shape-sql [columns table-name geom-column popup-columns point-color-column where-clause current-layer tenant-conn]
  (let [
    {:keys [table-name columns]} (dataset-by-id tenant-conn {:id (get current-layer "datasetId")})
    date-column-set (reduce (fn [m c]
                                  (if (= "date" (get c "type"))
                                    (conj m (get c "columnName"))
                                    m)) #{} columns)
        cols (distinct
              (cond-> (conj (map (fn [c]
                                   (if (contains? date-column-set c)
                                     (str c "::text")
                                     c)) popup-columns) geom-column)
                point-color-column (conj point-color-column)
                (get current-layer "shapeLabelColumn") (conj (get current-layer "shapeLabelColumn"))))]
    (format "select %s from %s where %s"
            (str/join ", " cols)
            table-name
            where-clause)))

(defn get-sql [columns table-name geom-column popup-columns point-color-column where-clause layer layer-index tenant-conn]
  (cond
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (shape-aggregation-sql columns table-name geom-column popup-columns point-color-column where-clause layer layer-index tenant-conn)

    (= (get layer "layerType") "geo-shape")
    (shape-sql columns table-name geom-column popup-columns point-color-column where-clause layer tenant-conn)

    :else
    (point-sql columns table-name geom-column popup-columns point-color-column where-clause layer tenant-conn)
  )
)

(defn get-interactivity [layer popup-columns]
  (if
    (and (get layer "aggregationDataset")(get layer "aggregationColumn")(get layer "aggregationGeomColumn"))
    (into ["_aggregation"] popup-columns)
    popup-columns
  )
)

(defn get-geom-column [layer-spec]
  (if-let [geom (get layer-spec "geom")]
    geom
    (let [{:strs [latitude longitude]} layer-spec]
      (format "ST_SetSRID(ST_MakePoint(%s, %s), 4326) AS latlong" longitude latitude))))

(defn get-layers [layers metadata-array table-name conn]
  (map-indexed (fn [idx, current-layer]
                (let [geom-column (get-geom-column current-layer)
                      {:keys [columns]} (dataset-by-id conn {:id (get current-layer "datasetId")})
                      where-clause (filter/sql-str columns (get current-layer "filters"))
                      popup-columns (mapv #(get % "column")
                                         (get current-layer "popup"))
                     point-color-column (get current-layer "pointColorColumn")]
                { "type" "mapnik"
                  "options" {
                    "cartocss" (trim-css (cartocss current-layer idx metadata-array))
                    "cartocss_version" "2.0.0"
                    "geom_column" (or (get current-layer "geom") "latlong")
                    "interactivity" (get-interactivity current-layer popup-columns)
                    "sql" (get-sql columns table-name geom-column popup-columns point-color-column where-clause current-layer idx conn)
                    "srid" "4326"
                  }})) layers))

(defn build [table-name layers metadata-array tenant-conn]
  {"version" "1.6.0"
   "buffersize" {
    "png" 8
    "grid.json" 8
    "mvt" 0
   }
   "layers" (get-layers layers metadata-array table-name tenant-conn)})

[#1142] Set gradient color to max when only one shape on map


(ns async-ring.core
  "This namespace provides a core.async API for Ring. It allows you define and nest synchronous
   and async ring handlers to create efficient, async http servers.

   Async handlers are just core.async channels! To use them, put ring request maps into them.
   Each request map must contain 2 additional keys, :async-response and :async-error, which must
   both be channels. For each ring request map you put into the input channel, you will recieve
   either a response map via the :async-response channel or a Throwable via the :async-error
   channel."
  (:require [clojure.core.async :as async]))

;;; The fundamental unit is a channel. It expects to recieve Ring request maps, which each contain
;;; 2 extra keys: `:async-response` and `:async-error`, which contain channels onto which you can
;;; put Ring response maps or Exceptions, respectively.
;;;

(defn async->sync-adapter
  "Takes an async ring handler and converts into a normal ring handler.

   This uses blocking async operations, so the async ring handler shouldn't block."
  [async-middleware]
  (fn async->sync-handler-adapter-helper [req]
    (let [resp-chan (async/chan)
          error-chan (async/chan)]
      (async/go (async/>! async-middleware
                          (assoc req
                                 :async-response resp-chan
                                 :async-error error-chan)))
      (async/alt!!
        resp-chan ([resp] resp)
        error-chan ([e] (throw e))))))

(defn sync->async-adapter
  "This takes a normal ring handler and converts it into an async ring
   handler. It runs the ring handler on up to :parallelism goroutines,
   and it will queue up to :buffer-size requests before exhibiting
   back-pressure."
  [handler {:keys [parallelism buffer-size]
            :or {parallelism 5
                 buffer-size 10}
            :as options}]
  (let [req-chan (async/chan buffer-size)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)]
            (try
              (let [resp (handler req)]
                (if resp
                  (async/>! (:async-response req) resp)
                  (async/>! (:async-error req)
                            (ex-info "Handler returned null"
                                     {:req req :handler handler}))))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn sync->async-middleware
  "This lets you use normal ring middleware in an async ring app. You must
   provide the async-handler that will be wrapped with the middleware,
   an options map (nil means use defaults) to configure the concurrent
   properties of the synchronous middleware, and you can optionally provide
   additional args for the ring middleware.

   For example, suppose that ah is an sync ring handler. To combine it
   with ring.middleware.json/wrap-json-body, we can write:

   (sync->async-middleware ah wrap-json-body {:parallelism 2} {:keywords? true})

   Thus you can see how extra arguments (i.e. {:keyswords? true}) are passed to
   wrap-json-body.

   See async->sync-middleware for the dual.
   "
  [async-handler middleware options & args]
  (let [handler (async->sync-adapter async-handler)]
    (sync->async-adapter (apply middleware handler args) options)))

(defn async->sync-middleware
  "This lets you use async ring middleware in a normal ring app. You
   simply provide the normal ring handler as well as the constructor
   function for the async-middlware, along with any args that the
   async-middleware might take.

   Options configures the concurrency properties of the given
   normal ring handler; this will affect performance of the async
   middleware.

   See sync->async-middleware for the dual.
   "
  [handler options async-middleware & args]
  (let [async-handler (sync->async-adapter handler options)]
    (async->sync-adapter (apply async-middleware async-handler args))))

(defn sync->async-preprocess-middleware
  "This is like sync->async-middleware, except it skips the processing **after**
   it calls the child function."
  [async-handler sync-preprocess-middleware
   {:keys [parallelism buffer-size]
    :or {parallelism 5
         buffer-size 10}
    :as options}
   & args]
  (let [req-chan (async/chan buffer-size)
        forward-handler (apply sync-preprocess-middleware
                               (fn fwd [req]
                                 {::fwd req})
                               args)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)]
            (try
              (let [{to-fwd ::fwd :as resp} (forward-handler req)]
                (if to-fwd
                  (async/>! async-handler to-fwd)
                  (async/>! (:async-response req) resp)))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn sync->async-postprocess-middleware
  "This is like sync->async-middleware, except it skips the processing **before**
   it calls the child function."
  [async-handler sync-postprocess-middleware
   {:keys [parallelism buffer-size]
    :or {parallelism 5
         buffer-size 10}
    :as options}
   & args]
  (let [req-chan (async/chan buffer-size)
        post-process (apply sync-postprocess-middleware
                            (fn fwd [resp]
                              (if-let [e (::error resp)]
                                (throw e)
                                resp)) args)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)
                resp-chan (async/chan)
                error-chan (async/chan)]
            (async/>! async-handler
                      (assoc req
                             :async-response resp-chan
                             :async-error error-chan))
            (try
              (let [value (async/alt!
                            resp-chan ([resp] resp)
                            error-chan ([e] {::error e}))
                    _ (println "result was" value)
                    result (post-process value)]
                (if result
                  (async/>! (:async-response req) result)
                  (async/>! (:async-error req)
                            (ex-info "post-process handler returned nil"
                                     {:req req :middleware sync-postprocess-middleware :value-before-postprocess value}))))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn constant-response
  "Returns an async-handler that always returns the given response."
  [response]
  (let [req-chan (async/chan)]
    (async/go
      (while true
        (async/>! (:async-response (async/<! req-chan)) response)))
    req-chan))

(ns async-ring.core
  "This namespace provides a core.async API for Ring. It allows you define and nest synchronous
   and async ring handlers to create efficient, async http servers.

   Async handlers are just core.async channels! To use them, put ring request maps into them.
   Each request map must contain 2 additional keys, :async-response and :async-error, which must
   both be channels. For each ring request map you put into the input channel, you will recieve
   either a response map via the :async-response channel or a Throwable via the :async-error
   channel."
  (:require [clojure.core.async :as async]))

;;; The fundamental unit is a channel. It expects to recieve Ring request maps, which each contain
;;; 2 extra keys: `:async-response` and `:async-error`, which contain channels onto which you can
;;; put Ring response maps or Exceptions, respectively.
;;;

(defn async->sync-adapter
  "Takes an async ring handler and converts into a normal ring handler.

   This uses blocking async operations, so the async ring handler shouldn't block."
  [async-middleware]
  (fn async->sync-handler-adapter-helper [req]
    (let [resp-chan (async/chan)
          error-chan (async/chan)]
      (async/go (async/>! async-middleware
                          (assoc req
                                 :async-response resp-chan
                                 :async-error error-chan)))
      (async/alt!!
        resp-chan ([resp] resp)
        error-chan ([e] (throw e))))))

(defn sync->async-adapter
  "This takes a normal ring handler and converts it into an async ring
   handler. It runs the ring handler on up to :parallelism goroutines,
   and it will queue up to :buffer-size requests before exhibiting
   back-pressure."
  [handler {:keys [parallelism buffer-size]
            :or {parallelism 5
                 buffer-size 10}
            :as options}]
  (let [req-chan (async/chan buffer-size)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)]
            (try
              (let [resp (handler req)]
                (if resp
                  (async/>! (:async-response req) resp)
                  (async/>! (:async-error req)
                            (ex-info "Handler returned null"
                                     {:req req :handler handler}))))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn sync->async-middleware
  "This lets you use normal ring middleware in an async ring app. You must
   provide the async-handler that will be wrapped with the middleware,
   an options map (nil means use defaults) to configure the concurrent
   properties of the synchronous middleware, and you can optionally provide
   additional args for the ring middleware.

   For example, suppose that ah is an sync ring handler. To combine it
   with ring.middleware.json/wrap-json-body, we can write:

   (sync->async-middleware ah wrap-json-body {:parallelism 2} {:keywords? true})

   Thus you can see how extra arguments (i.e. {:keyswords? true}) are passed to
   wrap-json-body.

   See async->sync-middleware for the dual.
   "
  [async-handler middleware options & args]
  (let [handler (async->sync-adapter async-handler)]
    (sync->async-adapter (apply middleware handler args) options)))

(defn async->sync-middleware
  "This lets you use async ring middleware in a normal ring app. You
   simply provide the normal ring handler as well as the constructor
   function for the async-middlware, along with any args that the
   async-middleware might take.

   Options configures the concurrency properties of the given
   normal ring handler; this will affect performance of the async
   middleware.

   See sync->async-middleware for the dual.
   "
  [handler options async-middleware & args]
  (let [async-handler (sync->async-adapter handler options)]
    (async->sync-adapter (apply async-middleware async-handler args))))

(defn sync->async-preprocess-middleware
  "This is like sync->async-middleware, except it skips the processing **after**
   it calls the child function."
  [async-handler sync-preprocess-middleware
   {:keys [parallelism buffer-size]
    :or {parallelism 5
         buffer-size 10}
    :as options}
   & args]
  (let [req-chan (async/chan buffer-size)
        forward-handler (apply sync-preprocess-middleware
                               (fn fwd [req]
                                 {::fwd req})
                               args)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)]
            (try
              (let [{to-fwd ::fwd :as resp} (forward-handler req)]
                (if to-fwd
                  (async/>! async-handler to-fwd)
                  (async/>! (:async-response req) resp)))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn sync->async-postprocess-middleware
  "This is like sync->async-middleware, except it skips the processing **before**
   it calls the child function."
  [async-handler sync-postprocess-middleware
   {:keys [parallelism buffer-size]
    :or {parallelism 5
         buffer-size 10}
    :as options}
   & args]
  (let [req-chan (async/chan buffer-size)
        post-process (apply sync-postprocess-middleware
                            (fn fwd [resp]
                              (if-let [e (::error resp)]
                                (throw e)
                                resp)) args)]
    (dotimes [i parallelism]
      (async/go
        (while true
          (let [req (async/<! req-chan)
                resp-chan (async/chan)
                error-chan (async/chan)]
            (async/>! async-handler
                      (assoc req
                             :async-response resp-chan
                             :async-error error-chan))
            (try
              (let [value (async/alt!
                            resp-chan ([resp] resp)
                            error-chan ([e] {::error e}))
                    result (post-process value)]
                (if result
                  (async/>! (:async-response req) result)
                  (async/>! (:async-error req)
                            (ex-info "post-process handler returned nil"
                                     {:req req :middleware sync-postprocess-middleware :value-before-postprocess value}))))
              (catch Throwable e
                (async/>! (:async-error req) e)))))))
    req-chan))

(defn constant-response
  "Returns an async-handler that always returns the given response."
  [response]
  (let [req-chan (async/chan)]
    (async/go
      (while true
        (async/>! (:async-response (async/<! req-chan)) response)))
    req-chan))

Remove extraneous println

Remove extraneous println