;; Utility functions and functions for manipulating state
(ns robinson.worldgen
  (:use
        robinson.common
        robinson.npc
        [robinson.mapgen :exclude [-main]])
  (:require
            [robinson.itemgen :as ig]
            [clojure.data.generators :as dg]
            [taoensso.timbre :as timbre]
            [clisk.core :as clisk]
            [clisk.patterns :as cliskp]
            [clisk.node :as cliskn]
            [clisk.functions :as cliskf]))

(timbre/refer-timbre)

;; clisk utils
(defn invert [a] (cliskf/v+ [1 1 1] (cliskf/v* [-1 -1 -1] a)))

(defn center [f]
  (cliskf/offset [-0.5 -0.5] (cliskf/scale 0.5 f)))

(defn center-radius []
  (cliskf/radius (center [cliskf/x cliskf/y])))

(defmacro vcond
  "Takes a set of test/expr pairs. It evaluates each test one at a
  time. If a test returns logical true, cond evaluates and returns
  the value of the corresponding expr and doesn't evaluate any of the
  other tests or exprs. (cond) returns nil."
  {:added "1.0"}
  [& clauses]
  (if clauses
    (list 'cliskf/vif (first clauses)
      (if (next clauses)
        (second clauses)
        (throw (IllegalArgumentException.
          "vcond requires an even number of forms")))
      (cons 'vcond (next (next clauses))))
    [0 0 0]))

(defn init-ocean
  []
  (let [max-x 80
        max-y 26]
    (add-extras
      (vec
        (map vec
          (partition max-x
            (for [y (range max-y)
                  x (range max-x)]
                {:type :water}))))
      [])))

(defn init-island
  "Create an example place with an island, two items
   and a set of down stairs that lead to place `:1`"
  [seed]
  (let [_    (cliskp/seed-simplex-noise! seed)
        node (cliskf/vectorize
               (cliskf/vlet [c (center (invert (cliskf/offset (cliskf/scale 0.43 (cliskf/v* [0.5 0.5 0.5] cliskp/vsnoise)) cliskf/radius)))]
                 (vcond
                   ;; interior trees/green
                   (cliskf/v+ [-0.7 -0.7 -0.7]  (cliskf/v* c (cliskf/v+ [0.4 0.4 0.4] (cliskf/scale 0.05 cliskp/noise))))
                     [0 0.5 0]
                   ;; interior dirt/brown
                   (cliskf/v+ [-0.6 -0.6 -0.6]  c)
                     [0.3 0.2 0.1]
                   ;; shore/yellow
                   (cliskf/v+ [-0.5 -0.5 -0.5]  c)
                     [0.7 0.6 0.0]
                   ;; surf/light blue
                   (cliskf/v+ [-0.37 -0.37 -0.37]  c)
                     [0 0.5 0.6]
                   ;; else ocean
                   [1 1 1]
                     [0 0.4 0.5])))
        fns  (vec (map cliskn/compile-fn (:nodes node)))
        max-x 80
        max-y 26]
    (add-extras
      (vec
        (map vec
          (partition max-x
            (log-time "for" (for [y (range max-y)
                  x (range max-x)
                  :let [s (vec (map #(.calc ^clisk.IFunction % (double (/ x max-x)) (double (/ y max-y)) (double 0.0) (double 0.0))
                               fns))]]
              (case s
                [0.0 0.4 0.5] {:type :water}
                [0.0 0.5 0.6] {:type :surf}
                [0.7 0.6 0.0] {:type :sand}
                [0.3 0.2 0.1] (case (uniform-int 2)
                                0 {:type :dirt}
                                1 {:type :gravel})
                [0.0 0.5 0.0] (case (uniform-int 7)
                                0 {:type :tree}
                                1 {:type :palm-tree}
                                2 {:type :fruit-tree :fruit-type (dg/rand-nth [:red-fruit :orange-fruit :yellow-fruit
                                                                               :green-fruit :blue-fruit :purple-fruit
                                                                               :white-fruit :black-fruit])}
                                3 {:type :tall-grass}
                                4 {:type :short-grass}
                                5 {:type :gravel}
                                6 {:type :bamboo})))))))
    [[[(int (/ max-x 2)) (int (/ max-y 2))]      {:type :dirt :starting-location true}]])))

(defn init-random-0
  "Create a random grid suitable for a starting level.
   Contains a down stairs, and identifies the starting location as
   the spot that would have been reserved for up stairs."
  []
  (let [place       (random-place 50 27)
        _ (debug "place" place)
        _ (debug "(place :up-stairs)" (place :up-stairs))
        _ (debug "(place :down-stairs)" (place :down-stairs))
        down-stairs (assoc-in (place :down-stairs) [1 :dest-place] :1)
        starting-location [[(-> place :up-stairs first first)
                            (-> place :up-stairs first second)]
                           {:type :floor :starting-location true}]
        _ (debug "starting-location" starting-location)
        place       (place :place)
        _ (debug "place" place)]
    (add-extras place [down-stairs starting-location])))

(defn init-random-n
  "Creates a random grid suitable for a non-starting level.
   Contains a down stairs, an up stairs, and five random items
   placed in floor cells."
  [level]
  (let [place       (random-place 50 27)
        _ (debug "place" place)
        _ (debug "(place :up-stairs)" (place :up-stairs))
        _ (debug "(place :down-stairs)" (place :down-stairs))
        _ (debug "level" level)
        _ (debug "former place id" (keyword (str (dec level))))
        up-stairs   (assoc-in (place :up-stairs) [1 :dest-place] (keyword (str (dec level))))
        _ (debug "up-stairs" up-stairs)
        down-stairs (assoc-in (place :down-stairs) [1 :dest-place] (keyword (str (inc level))))
        place       (place :place)
        drops       (map (fn [pos]
                           [pos {:type :floor :items [(ig/gen-item)]}])
                           (take 5 (dg/shuffle
                              (map (fn [[_ x y]] [x y]) (filter (fn [[cell x y]] (and (not (nil? cell))
                                                                                (= (cell :type) :floor)))
                                                                (with-xy place))))))
        cash-drops  (map (fn [pos]
                           [pos {:type :floor :items [(ig/gen-cash (* level 10))]}])
                           (take 5 (dg/shuffle
                              (map (fn [[_ x y]] [x y]) (filter (fn [[cell x y]] (and (not (nil? cell))
                                                                                (= (cell :type) :floor)))
                                                                (with-xy place))))))
        _ (debug "drops" drops)
        _ (debug "cash-drops" cash-drops)
        _ (debug "place" place)]
    (add-extras place (concat [down-stairs up-stairs] drops cash-drops))))

(defn init-world
  "Create a randomly generated world.

   A world consists of

   * an intial place id (`:0_0`)

   * places (indexed by place id)

   * a player

   * a log

   * a time (initialized to 0)

   * a state (for use with state tracking (for complex input like opening doors,
   dropping items, menus)

   * available hotkeys (a-zA-Z)

   * npcs

   * quests (indexed by quest id)

   Not all of the places or npcs have to be generated by this function; they can be
   added during the course of the game."
  [seed]
  ;; Assign hotkeys to inventory and remove from remaining hotkeys
  (let [inventory              []
        remaining-hotkeys      (vec (seq "abcdefghijklmnopqrstuvwxyzABCdEFGHIJKLMNOPQRSTUVWQYZ"))
        hotkey-groups          (split-at (count inventory) remaining-hotkeys)
        inventory-with-hotkeys (vec (map #(assoc %1 :hotkey %2) inventory (first hotkey-groups)))
        remaining-hotkeys      (set (clojure.string/join (second hotkey-groups)))
        place-0                (init-island seed)
        [_ starting-x
           starting-y]         (first (filter (fn [[cell x y]] (contains? cell :starting-location))
                                              (with-xy place-0)))
        starting-pos           {:x starting-x :y starting-y}
        party-pos              (adjacent-navigable-pos place-0 starting-pos #{:corridor :open-door :floor})
        _ (debug "starting-pos" starting-pos)
        _ (debug "party-pos" party-pos)
       fruit-ids               [:red-fruit :orange-fruit :yellow-fruit :green-fruit :blue-fruit :purple-fruit :white-fruit :black-fruit]
       poisoned-fruit          (set (take (/ (count fruit-ids) 2) (dg/shuffle fruit-ids)))
       skin-identifiable       (set (take (/ (count poisoned-fruit) 2) (dg/shuffle poisoned-fruit)))
       tongue-identifiable     (set (take (/ (count poisoned-fruit) 2) (dg/shuffle poisoned-fruit)))]

  {:places {:0_0 place-0}
            ;:1 (init-place-1)}
   :current-place :0_0
   :time 0
   :current-state :start
   :selected-hotkeys #{}
   :remaining-hotkeys remaining-hotkeys
   :log []
   :ui-hint nil
   :dialog-log []
   :player {
            :id :player
            :name "Player"
            :race :human
            :class :ranger
            :movement-policy :entourage
            :in-party? true
            :inventory inventory-with-hotkeys
            :speed 1
            :hp 10
            :max-hp 10
            :will-to-live 100
            :max-will-to-live 100
            :$ 50
            :xp 0
            :level 0
            :hunger 0
            :max-hunger 100
            :thirst 0
            :max-thirst 100
            :pos starting-pos
            :place :0_0
            :body-parts #{:head :neck :face :abdomen :arm :leg :foot}
            :attacks #{:punch}
            :status #{}
            :stats {
              :num-animals-killed       {}
              :num-items-crafted        {}
              :num-items-harvested      {}
              :num-kills-by-attack-type {}
              :num-items-eaten          {}}
            ;; map from body-part to {:time <int> :damage <float>}
            :wounds {}}
   :fruit {
     :poisonous           poisoned-fruit
     :skin-identifiable   skin-identifiable
     :tongue-identifiable tongue-identifiable
     :identified          #{}
   }
   :quests {}
   :npcs []}))

(defn -main [& args]
  (let [_ (cliskp/seed-simplex-noise!)
        node (cliskf/vectorize
               (cliskf/vlet [c (center (invert (cliskf/offset (cliskf/scale 0.43 (cliskf/v* [0.5 0.5 0.5] cliskp/vsnoise)) cliskf/radius)))]
                 (vcond
                   ;; interior trees/green
                   (cliskf/v+ [-0.7 -0.7 -0.7]  (cliskf/v* c (cliskf/v+ [0.4 0.4 0.4] (cliskf/scale 0.05 cliskp/noise))))
                     [0 0.5 0]
                   ;; interior dirt/brown
                   (cliskf/v+ [-0.6 -0.6 -0.6]  c)
                     [0.3 0.2 0.1]
                   ;; shore/yellow
                   (cliskf/v+ [-0.5 -0.5 -0.5]  c)
                     [0.7 0.6 0.0]
                   ;; surf/light blue
                   (cliskf/v+ [-0.37 -0.37 -0.37]  c)
                     [0 0.5 0.6]
                   ;; else ocean
                   [1 1 1]
                     [0 0.4 0.5])))

        fns  (vec (map cliskn/compile-fn (:nodes node)))]
    (clisk/show node)
    #_(dorun
      (map (comp (partial apply str) println)
        (partition 70
          (log-time "for"
            (for [y (range 28)
                  x (range 70)
                  :let [[s _ _] (vec (map #(.calc ^clisk.IFunction % (double (/ x 70)) (double (/ y 28)) (double 0.0) (double 0.0))
                                   fns))]]
              (cond
                (> s 0.9) \^
                (> s 0.7) \.
                (> s 0.5) \_
                :else \~))))))))

;; Utility functions and functions for manipulating state
(ns robinson.worldgen
  (:use
        robinson.common
        robinson.npc
        [robinson.mapgen :exclude [-main]])
  (:require
            [robinson.itemgen :as ig]
            [clojure.data.generators :as dg]
            [taoensso.timbre :as timbre]
            [clisk.core :as clisk]
            [clisk.patterns :as cliskp]
            [clisk.node :as cliskn]
            [clisk.functions :as cliskf]))

(timbre/refer-timbre)

;; clisk utils
(defn invert [a] (cliskf/v+ [1 1 1] (cliskf/v* [-1 -1 -1] a)))

(defn center [f]
  (cliskf/offset [-0.5 -0.5] (cliskf/scale 0.5 f)))

(defn center-radius []
  (cliskf/radius (center [cliskf/x cliskf/y])))

(defmacro vcond
  "Takes a set of test/expr pairs. It evaluates each test one at a
  time. If a test returns logical true, cond evaluates and returns
  the value of the corresponding expr and doesn't evaluate any of the
  other tests or exprs. (cond) returns nil."
  {:added "1.0"}
  [& clauses]
  (if clauses
    (list 'cliskf/vif (first clauses)
      (if (next clauses)
        (second clauses)
        (throw (IllegalArgumentException.
          "vcond requires an even number of forms")))
      (cons 'vcond (next (next clauses))))
    [0 0 0]))

(defn init-ocean
  []
  (let [max-x 80
        max-y 26]
    (add-extras
      (vec
        (map vec
          (partition max-x
            (for [y (range max-y)
                  x (range max-x)]
                {:type :water}))))
      [])))

(defn init-island
  "Create an example place with an island, two items
   and a set of down stairs that lead to place `:1`"
  [seed]
  (let [_    (cliskp/seed-simplex-noise! seed)
        node (cliskf/vectorize
               (cliskf/vlet [c (center (invert (cliskf/offset (cliskf/scale 0.43 (cliskf/v* [0.5 0.5 0.5] cliskp/vsnoise)) cliskf/radius)))]
                 (vcond
                   ;; interior trees/green
                   (cliskf/v+ [-0.7 -0.7 -0.7]  (cliskf/v* c (cliskf/v+ [0.4 0.4 0.4] (cliskf/scale 0.05 cliskp/noise))))
                     [0 0.5 0]
                   ;; interior dirt/brown
                   (cliskf/v+ [-0.6 -0.6 -0.6]  c)
                     [0.3 0.2 0.1]
                   ;; shore/yellow
                   (cliskf/v+ [-0.5 -0.5 -0.5]  c)
                     [0.7 0.6 0.0]
                   ;; surf/light blue
                   (cliskf/v+ [-0.37 -0.37 -0.37]  c)
                     [0 0.5 0.6]
                   ;; else ocean
                   [1 1 1]
                     [0 0.4 0.5])))
        fns  (vec (map cliskn/compile-fn (:nodes node)))
        max-x 80
        max-y 26]
    (add-extras
      (vec
        (map vec
          (partition max-x
            (log-time "for" (for [y (range max-y)
                  x (range max-x)
                  :let [s (vec (map #(.calc ^clisk.IFunction % (double (/ x max-x)) (double (/ y max-y)) (double 0.0) (double 0.0))
                               fns))]]
              (case s
                [0.0 0.4 0.5] {:type :water}
                [0.0 0.5 0.6] {:type :surf}
                [0.7 0.6 0.0] {:type :sand}
                [0.3 0.2 0.1] (case (uniform-int 2)
                                0 {:type :dirt}
                                1 {:type :gravel})
                [0.0 0.5 0.0] (case (uniform-int 7)
                                0 {:type :tree}
                                1 {:type :palm-tree}
                                2 {:type :fruit-tree :fruit-type (dg/rand-nth [:red-fruit :orange-fruit :yellow-fruit
                                                                               :green-fruit :blue-fruit :purple-fruit
                                                                               :white-fruit :black-fruit])}
                                3 {:type :tall-grass}
                                4 {:type :short-grass}
                                5 {:type :gravel}
                                6 {:type :bamboo})))))))
    [[[(int (/ max-x 2)) (int (/ max-y 2))]      {:type :dirt :starting-location true}]])))

(defn init-random-0
  "Create a random grid suitable for a starting level.
   Contains a down stairs, and identifies the starting location as
   the spot that would have been reserved for up stairs."
  []
  (let [place       (random-place 50 27)
        _ (debug "place" place)
        _ (debug "(place :up-stairs)" (place :up-stairs))
        _ (debug "(place :down-stairs)" (place :down-stairs))
        down-stairs (assoc-in (place :down-stairs) [1 :dest-place] :1)
        starting-location [[(-> place :up-stairs first first)
                            (-> place :up-stairs first second)]
                           {:type :floor :starting-location true}]
        _ (debug "starting-location" starting-location)
        place       (place :place)
        _ (debug "place" place)]
    (add-extras place [down-stairs starting-location])))

(defn init-random-n
  "Creates a random grid suitable for a non-starting level.
   Contains a down stairs, an up stairs, and five random items
   placed in floor cells."
  [level]
  (let [place       (random-place 50 27)
        _ (debug "place" place)
        _ (debug "(place :up-stairs)" (place :up-stairs))
        _ (debug "(place :down-stairs)" (place :down-stairs))
        _ (debug "level" level)
        _ (debug "former place id" (keyword (str (dec level))))
        up-stairs   (assoc-in (place :up-stairs) [1 :dest-place] (keyword (str (dec level))))
        _ (debug "up-stairs" up-stairs)
        down-stairs (assoc-in (place :down-stairs) [1 :dest-place] (keyword (str (inc level))))
        place       (place :place)
        drops       (map (fn [pos]
                           [pos {:type :floor :items [(ig/gen-item)]}])
                           (take 5 (dg/shuffle
                              (map (fn [[_ x y]] [x y]) (filter (fn [[cell x y]] (and (not (nil? cell))
                                                                                (= (cell :type) :floor)))
                                                                (with-xy place))))))
        cash-drops  (map (fn [pos]
                           [pos {:type :floor :items [(ig/gen-cash (* level 10))]}])
                           (take 5 (dg/shuffle
                              (map (fn [[_ x y]] [x y]) (filter (fn [[cell x y]] (and (not (nil? cell))
                                                                                (= (cell :type) :floor)))
                                                                (with-xy place))))))
        _ (debug "drops" drops)
        _ (debug "cash-drops" cash-drops)
        _ (debug "place" place)]
    (add-extras place (concat [down-stairs up-stairs] drops cash-drops))))

(defn init-world
  "Create a randomly generated world.

   A world consists of

   * an intial place id (`:0_0`)

   * places (indexed by place id)

   * a player

   * a log

   * a time (initialized to 0)

   * a state (for use with state tracking (for complex input like opening doors,
   dropping items, menus)

   * available hotkeys (a-zA-Z)

   * npcs

   * quests (indexed by quest id)

   Not all of the places or npcs have to be generated by this function; they can be
   added during the course of the game."
  [seed]
  ;; Assign hotkeys to inventory and remove from remaining hotkeys
  (let [inventory              []
        remaining-hotkeys      (vec (seq "abcdefghijklmnopqrstuvwxyzABCdEFGHIJKLMNOPQRSTUVWQYZ"))
        hotkey-groups          (split-at (count inventory) remaining-hotkeys)
        inventory-with-hotkeys (vec (map #(assoc %1 :hotkey %2) inventory (first hotkey-groups)))
        remaining-hotkeys      (set (clojure.string/join (second hotkey-groups)))
        place-0                (init-island seed)
        [_ starting-x
           starting-y]         (first (filter (fn [[cell x y]] (contains? cell :starting-location))
                                              (with-xy place-0)))
        starting-pos           {:x starting-x :y starting-y}
        party-pos              (adjacent-navigable-pos place-0 starting-pos #{:corridor :open-door :floor})
        _ (debug "starting-pos" starting-pos)
        _ (debug "party-pos" party-pos)
       fruit-ids               [:red-fruit :orange-fruit :yellow-fruit :green-fruit :blue-fruit :purple-fruit :white-fruit :black-fruit]
       poisoned-fruit          (set (take (/ (count fruit-ids) 2) (dg/shuffle fruit-ids)))
       skin-identifiable       (set (take (/ (count poisoned-fruit) 2) (dg/shuffle poisoned-fruit)))
       tongue-identifiable     (set (take (/ (count poisoned-fruit) 2) (dg/shuffle poisoned-fruit)))]

  {:seed seed
   :places {:0_0 place-0}
            ;:1 (init-place-1)}
   :current-place :0_0
   :time 0
   :current-state :start
   :selected-hotkeys #{}
   :remaining-hotkeys remaining-hotkeys
   :log []
   :ui-hint nil
   :dialog-log []
   :player {
            :id :player
            :name "Player"
            :race :human
            :class :ranger
            :movement-policy :entourage
            :in-party? true
            :inventory inventory-with-hotkeys
            :speed 1
            :hp 10
            :max-hp 10
            :will-to-live 100
            :max-will-to-live 100
            :$ 50
            :xp 0
            :level 0
            :hunger 0
            :max-hunger 100
            :thirst 0
            :max-thirst 100
            :pos starting-pos
            :place :0_0
            :body-parts #{:head :neck :face :abdomen :arm :leg :foot}
            :attacks #{:punch}
            :status #{}
            :stats {
              :num-animals-killed       {}
              :num-items-crafted        {}
              :num-items-harvested      {}
              :num-kills-by-attack-type {}
              :num-items-eaten          {}}
            ;; map from body-part to {:time <int> :damage <float>}
            :wounds {}}
   :fruit {
     :poisonous           poisoned-fruit
     :skin-identifiable   skin-identifiable
     :tongue-identifiable tongue-identifiable
     :identified          #{}
   }
   :quests {}
   :npcs []}))

(defn -main [& args]
  (let [_ (cliskp/seed-simplex-noise!)
        node (cliskf/vectorize
               (cliskf/vlet [c (center (invert (cliskf/offset (cliskf/scale 0.43 (cliskf/v* [0.5 0.5 0.5] cliskp/vsnoise)) cliskf/radius)))]
                 (vcond
                   ;; interior trees/green
                   (cliskf/v+ [-0.7 -0.7 -0.7]  (cliskf/v* c (cliskf/v+ [0.4 0.4 0.4] (cliskf/scale 0.05 cliskp/noise))))
                     [0 0.5 0]
                   ;; interior dirt/brown
                   (cliskf/v+ [-0.6 -0.6 -0.6]  c)
                     [0.3 0.2 0.1]
                   ;; shore/yellow
                   (cliskf/v+ [-0.5 -0.5 -0.5]  c)
                     [0.7 0.6 0.0]
                   ;; surf/light blue
                   (cliskf/v+ [-0.37 -0.37 -0.37]  c)
                     [0 0.5 0.6]
                   ;; else ocean
                   [1 1 1]
                     [0 0.4 0.5])))

        fns  (vec (map cliskn/compile-fn (:nodes node)))]
    (clisk/show node)
    #_(dorun
      (map (comp (partial apply str) println)
        (partition 70
          (log-time "for"
            (for [y (range 28)
                  x (range 70)
                  :let [[s _ _] (vec (map #(.calc ^clisk.IFunction % (double (/ x 70)) (double (/ y 28)) (double 0.0) (double 0.0))
                                   fns))]]
              (cond
                (> s 0.9) \^
                (> s 0.7) \.
                (> s 0.5) \_
                :else \~))))))))

Save seed as part of world

Save seed as part of world


(ns ruuvi-server.util
    (:import [org.joda.time.format DateTimeFormat DateTimeFormatter]
             [org.joda.time DateTime DateTimeZone])
    (:import [java.lang IllegalArgumentException])
    (:import [java.math BigDecimal])
    (:import java.math.RoundingMode)
    )

(defn modify-map [data key-modifiers value-modifiers]
  "Goes through all entries in data map and converts values"
  (into {}
        (for [[key value] data]
          (let [new-value
                (if (contains? value-modifiers key)
                  (let [modifier (value-modifiers key)]
                    (if (fn? modifier)
                      (modifier value)
                      modifier))
                  value)

                new-key
                (if (contains? key-modifiers key)
                  (let [modifier (key-modifiers key)]
                    (if (fn? modifier)
                      (modifier key)
                      modifier))
                  key)]
            [new-key new-value]
            ))))

(defn remove-nil-values
  "Removes keys that have nil values"
  [data-map]
  (let [data (into {}
                   (filter
                    (fn [item]
                      (if item
                        (let [value (item 1)]
                          (cond (and (coll? value) (empty? value)) false
                                (= value nil) false
                                :else true))
                        nil)
                      ) data-map))]
    (if (empty? data)
      nil
      data)
    ))

(def date-time-formatter (.withZone
                          (DateTimeFormat/forPattern "YYYY-MM-dd'T'HH:mm:ss.SSSZ")
                          (DateTimeZone/forID "UTC")
  ))

(defn timestamp [] (.print date-time-formatter (new org.joda.time.DateTime)))

(defn parse-decimal
  "Parses string to BigDecimal instance. In case of errors, returns nil."
  [decimal]
  (try
    (BigDecimal. decimal)
    (catch Exception e nil)
    ))

(defn- parse-unix-timestamp [value]
  (DateTime. (* 1000 (Long/valueOf value)) (DateTimeZone/forID "UTC")))

(defn parse-date-time
  "Parses string to DateTime instance. In case of errors, returns nil."
  [date]
  (try
    (.parseDateTime date-time-formatter date)
    (catch Exception e nil)))

(defn parse-timestamp
  "Parses a stromg to DateTime instance. In case of errors, returns nil.
Supports unix timestamp and YYYY-MM-dd'T'HH:mm:ss.SSSZ"
  [value]
  (cond (not value) nil
        (re-matches #"\d+" value) (parse-unix-timestamp value)
        :default (parse-date-time value)))

(defn timestamp? [value]
  (cond (not value) false
        (parse-date-time value) true
        :else false))

(defn- upper-matches-regex? [value regex]
  (if value
    (let [uppercase (.toUpperCase value)]
      (if (re-matches regex uppercase)
        true
        false
        ))
    false))

;; TODO check that seconds, minutes and degrees are in proper range [0,59]
(defn nmea-latitude? [value]
  (let [regex #"(\d*.?\d*),[NS]"]
    (upper-matches-regex? value regex)))

(defn nmea-longitude? [value]
  (let [regex #"(\d*.?\d*),[EW]"]
    (upper-matches-regex? value regex)))

(defn- is-nmea-coordinate? [value]
  (and value
      (or (nmea-latitude? value)
          (nmea-longitude? value))))

(defn parse-nmea-coordinate [value]
  (when (not (is-nmea-coordinate? value))
    (throw (IllegalArgumentException. (str value " is not valid NMEA coordinate"))))
  (let [upper (.toUpperCase value)
        regex #"(\d*)(\d\d.?\d*),([NSWE])"
        match-groups (re-matches regex upper)
        area (match-groups 3)
        sign (if (or (.contains area "S")
                     (.contains area "W"))
               -1
               +1)
        degrees (BigDecimal. (match-groups 1))
        minutes (BigDecimal. (match-groups 2))
        ]
    (* sign (+ degrees (.divide minutes 60.0M 6 RoundingMode/FLOOR)))
  ))

(defn parse-coordinate
  "Parses string to a coordinate. String can be decimal or NMEA format"
  [value]
  (cond (not value) nil
        (empty? value) nil
        (is-nmea-coordinate? value) (parse-nmea-coordinate value)
        :default (BigDecimal. value)
        ))

(defn wrap-cors-headers
  "http://www.w3.org/TR/cors/"
  [app & methods]
  (fn [request]
    (let [response (app request)
          request-origin (when (:headers request)
                           ((:headers request) "origin"))
          options (apply str (interpose ", " (conj methods "OPTIONS")))
          cors-response
          (merge response
                 {:headers
                  (merge (:headers response)
                         {"Access-Control-Allow-Origin" (or request-origin "*")
                          "Access-Control-Allow-Headers" "X-Requested-With, Content-Type, Origin, Referer, User-Agent"
                          "Access-Control-Allow-Methods" options})})]
      cors-response
      )))

(ns ruuvi-server.util
    (:import [org.joda.time.format DateTimeFormat DateTimeFormatter]
             [org.joda.time DateTime DateTimeZone])
    (:import [java.lang IllegalArgumentException])
    (:import [java.math BigDecimal])
    (:import java.math.RoundingMode)
    )

(defn modify-map [data key-modifiers value-modifiers]
  "Goes through all entries in data map and converts values"
  (into {}
        (for [[key value] data]
          (let [new-value
                (if (contains? value-modifiers key)
                  (let [modifier (value-modifiers key)]
                    (if (fn? modifier)
                      (modifier value)
                      modifier))
                  value)

                new-key
                (if (contains? key-modifiers key)
                  (let [modifier (key-modifiers key)]
                    (if (fn? modifier)
                      (modifier key)
                      modifier))
                  key)]
            [new-key new-value]
            ))))

(defn remove-nil-values
  "Removes keys that have nil values"
  [data-map]
  (let [data (into {}
                   (filter
                    (fn [item]
                      (if item
                        (let [value (item 1)]
                          (cond (and (coll? value) (empty? value)) false
                                (= value nil) false
                                :else true))
                        nil)
                      ) data-map))]
    (if (empty? data)
      nil
      data)
    ))

(def date-time-formatter (.withZone
                          (DateTimeFormat/forPattern "YYYY-MM-dd'T'HH:mm:ss.SSSZ")
                          (DateTimeZone/forID "UTC")
  ))

(defn timestamp [] (.print date-time-formatter (new org.joda.time.DateTime)))

(defn parse-decimal
  "Parses string to BigDecimal instance. In case of errors, returns nil."
  [decimal]
  (try
    (BigDecimal. decimal)
    (catch Exception e nil)
    ))

(defn- parse-unix-timestamp [value]
  (DateTime. (* 1000 (Long/valueOf value)) (DateTimeZone/forID "UTC")))

(defn parse-date-time
  "Parses string to DateTime instance. In case of errors, returns nil."
  [date]
  (try
    (.parseDateTime date-time-formatter date)
    (catch Exception e nil)))

(defn parse-timestamp
  "Parses a string to DateTime instance. In case of errors, returns nil.
Supports unix timestamp and YYYY-MM-dd'T'HH:mm:ss.SSSZ"
  [value]
  (cond (not value) nil
        (re-matches #"\d+" value) (parse-unix-timestamp value)
        :default (parse-date-time value)))

(defn timestamp? [value]
  (cond (not value) false
        (parse-date-time value) true
        :else false))

(defn- upper-matches-regex? [value regex]
  (if value
    (let [uppercase (.toUpperCase value)]
      (if (re-matches regex uppercase)
        true
        false
        ))
    false))

;; TODO check that seconds, minutes and degrees are in proper range [0,59]
(defn nmea-latitude? [value]
  (let [regex #"(\d*.?\d*),[NS]"]
    (upper-matches-regex? value regex)))

(defn nmea-longitude? [value]
  (let [regex #"(\d*.?\d*),[EW]"]
    (upper-matches-regex? value regex)))

(defn- is-nmea-coordinate? [value]
  (and value
      (or (nmea-latitude? value)
          (nmea-longitude? value))))

(defn parse-nmea-coordinate [value]
  (when (not (is-nmea-coordinate? value))
    (throw (IllegalArgumentException. (str value " is not valid NMEA coordinate"))))
  (let [upper (.toUpperCase value)
        regex #"(\d*)(\d\d.?\d*),([NSWE])"
        match-groups (re-matches regex upper)
        area (match-groups 3)
        sign (if (or (.contains area "S")
                     (.contains area "W"))
               -1
               +1)
        degrees (BigDecimal. (match-groups 1))
        minutes (BigDecimal. (match-groups 2))
        ]
    (* sign (+ degrees (.divide minutes 60.0M 6 RoundingMode/FLOOR)))
  ))

(defn parse-coordinate
  "Parses string to a coordinate. String can be decimal or NMEA format"
  [value]
  (cond (not value) nil
        (empty? value) nil
        (is-nmea-coordinate? value) (parse-nmea-coordinate value)
        :default (BigDecimal. value)
        ))

(defn wrap-cors-headers
  "http://www.w3.org/TR/cors/"
  [app & methods]
  (fn [request]
    (let [response (app request)
          request-origin (when (:headers request)
                           ((:headers request) "origin"))
          options (apply str (interpose ", " (conj methods "OPTIONS")))
          cors-response
          (merge response
                 {:headers
                  (merge (:headers response)
                         {"Access-Control-Allow-Origin" (or request-origin "*")
                          "Access-Control-Allow-Headers" "X-Requested-With, Content-Type, Origin, Referer, User-Agent"
                          "Access-Control-Allow-Methods" options})})]
      cors-response
      )))

fix typo

fix typo


;; Copyright © 2014 JUXT LTD.

(defproject juxt.modular/cassandra "0.4.0"
  :description "A modular extension that provides support for Cassandra (via cassaforte)"
  :url "https://github.com/juxt/modular/tree/master/modules/cassandra"
  :license {:name "The MIT License"
            :url "http://opensource.org/licenses/MIT"}
  :dependencies [[clojurewerkz/cassaforte "2.0.0-beta1"]
                 [prismatic/schema "0.2.1"]])

;; Copyright © 2014 JUXT LTD.

(defproject juxt.modular/cassandra "0.4.0"
  :description "A modular extension that provides support for Cassandra (via cassaforte)"
  :url "https://github.com/juxt/modular/tree/master/modules/cassandra"
  :license {:name "The MIT License"
            :url "http://opensource.org/licenses/MIT"}
  :dependencies [[clojurewerkz/cassaforte "2.0.0-rc4"]
                 [prismatic/schema "0.2.1"]])

Upgrade to Cassaforte 2.0.0-rc4

[cassandra] Upgrade to Cassaforte 2.0.0-rc4


(ns infinitelives.utils.pathfind-test
  (:require [cljs.test :refer-macros [deftest is]]
            [infinitelives.utils.pathfind :as pf]))

(deftest manhattan-test
  (is (= (pf/manhattan 0 0) 0))
  (is (= (pf/manhattan 1 4) 5))
  (is (= (pf/manhattan 1 -4) 5))
  (is (= (pf/manhattan -1 4) 5))
  (is (= (pf/manhattan -1 -4) 5)))

(deftest chebyshev-test
  (is (= (pf/chebyshev 0 0) 0))
  (is (= (pf/chebyshev 1 4) 4))
  (is (= (pf/chebyshev 1 -4) 4))
  (is (= (pf/chebyshev -1 4) 4))
  (is (= (pf/chebyshev -1 -4) 4)))

(deftest euclid-test
  (is (= (pf/euclid 0 0) 0))
  (is (= (pf/euclid 3 4) 5))
  (is (= (pf/euclid 3 -4) 5))
  (is (= (pf/euclid -3 4) 5))
  (is (= (pf/euclid -3 -4) 5)))

(deftest distance-between-test
  (is (= (pf/distance-between pf/manhattan [0 0] [-3 4]) 7))
  (is (= (pf/distance-between pf/chebyshev [0 0] [-3 4]) 4))
  (is (= (pf/distance-between pf/euclid    [0 0] [-3 4]) 5)))

(deftest state-add-neighbour-test
  (is (=
       (pf/state-add-neighbour
        (pf/->state #{} #{} {} {} {})
        [0 0]
        [1 1])
       (pf/->state #{} #{[1 1]} {[1 1] [0 0]} {} {}))))

(deftest state-add-open-test
  (is (=
       (pf/state-add-open
        (pf/->state #{} #{} {} {} {})
        [0 0])
       (pf/->state #{} #{[0 0]} {} {} {}))))

(deftest state-open-to-closed-test
  (is (=
       (pf/state-open-to-closed
        (pf/->state #{} #{[0 0]} {} {} {})
        [0 0])
       (pf/->state #{[0 0]} #{} {} {} {}))))

(deftest reduce-state-over-neighbours
  (is (=
       (pf/reduce-state-over-neighbours
        (pf/->state #{} #{[0 0]} {} {} {})
        [0 0]
        [[0 1] [0 -1] [1 0] [-1 0] [1 1] [-1 1] [1 -1] [-1 -1]])
       (pf/->state
        #{}
        #{[0 0] [0 1] [0 -1] [1 0] [-1 0] [1 1] [-1 1] [1 -1] [-1 -1]}
        {[0 1] [0 0]
         [0 -1] [0 0]
         [1 0] [0 0]
         [-1 0] [0 0]
         [1 1] [0 0]
         [-1 1] [0 0]
         [1 -1] [0 0]
         [-1 -1] [0 0]
         }
        {} {}))))

(deftest calculate-open-fscore-test
  (let [{:keys [g-score f-score]}
        (pf/calculate-open-fscore
         (pf/->state
          #{} #{[0 1] [0 0] [-1 1] [1 1] [1 -1] [1 0] [-1 0] [-1 -1] [0 -1]}
          {[0 1] [0 0], [0 -1] [0 0], [1 0] [0 0], [-1 0] [0 0], [1 1] [0 0], [-1 1] [0 0], [1 -1] [0 0], [-1 -1] [0 0]}
          {}, {})
         [0 0] [10 10])]
    (is (= g-score
           {[0 1] 10
            [0 0] 0
            [-1 1] 14
            [1 1] 14
            [1 -1] 14
            [1 0] 10
            [-1 0] 10
            [-1 -1] 14
            [0 -1] 10}))
    (is (= f-score
           {[0 1] 200
            [0 0] 200
            [-1 1] 214
            [1 1] 194
            [1 -1] 214
            [1 0] 200
            [-1 0] 220
            [-1 -1] 234
            [0 -1] 220}))))

(deftest lowest-f-score-open-cell-test
  (is
   (#{[0 1] [1 1]}
    (->
     (pf/->state
      #{} #{[0 1] [0 0] [-1 1] [1 1] [1 -1] [1 0] [-1 0] [-1 -1] [0 -1]}
      {[0 1] [0 0], [0 -1] [0 0], [1 0] [0 0], [-1 0] [0 0], [1 1] [0 0], [-1 1] [0 0], [1 -1] [0 0], [-1 -1] [0 0]}
      {}, {})
     (pf/calculate-open-fscore [0 1] [10 10])
     (pf/lowest-f-score-open-cell)))))

(deftest A*-step-test
  (let [start [0 0]
        end [10 10]
        [{:keys [open-set came-from g-score] :as state} next-cell]
        (-> (pf/->state #{} #{start} {} {start 0} {start 10})
            (pf/A*-step (constantly true) start end false))]
    (is (= open-set #{[-1 -1] [0 -1] [1 -1] [-1 0] [1 0] [-1 1] [0 1] [1 1]}))
    (is (= came-from
           {
            [-1 -1] [0 0]
            [0 -1] [0 0]
            [1 -1] [0 0]
            [-1 0] [0 0]
            [1 0] [0 0]
            [-1 1] [0 0]
            [0 1] [0 0]
            [1 1] [0 0]
            }))
    (is (= g-score
           {[0 -1] 10
            [-1 0] 10
            [0 1] 10
            [1 0] 10
            [-1 -1] 14
            [-1 1] 14
            [1 -1] 14
            [1 1] 14
            [0 0] 0
            }))))

(deftest A*-test
  (is (= (pf/A* (constantly true) [0 0] [10 5])
         '([0 0] [1 1] [2 2] [3 3] [4 4] [5 5] [6 5] [7 5] [8 5] [9 5] [10 5]))))

(deftest A*-obstacle-test
  (let [passable? (fn [pos]
                    (-> pos #{[3 3] [3 4] [4 4] [4 3]} boolean not))]
    (is (= (pf/A* passable? [0 0] [10 5] :corner-cut)
           '([0 0] [1 1] [2 2]
             [3 2] [4 2] [5 3]
             [6 4] [7 5] [8 5]
             [9 5] [10 5])))))

(deftest A*-obstacle-no-diags-test
  (let [passable? (fn [pos]
                    (-> pos #{[3 3] [3 4] [4 4] [4 3]} boolean not))]
    (is (= (pf/A* passable? [0 0] [10 5])
           '([0 0] [1 1] [2 2]
             [3 2] [4 2] [5 2]
             [6 3] [7 4] [8 5]
             [9 5] [10 5])))))

(deftest A*-cant-reach
  (let [passable? (fn [[x y]]
                    (not
                     (or (= x -5)
                         (= x 5)
                         (= y -5)
                         (= y 5))))]
    (is (nil? (pf/A* passable? [0 0] [10 10])))))

(deftest A*-direct-path
  (let [passable? (fn [[x y]]
                    (or
                     (and (<= 2 x 7)
                          (<= 1 y 6))
                     (and (<= 8 x 13)
                          (= 4 y))
                     (and (= 13 x)
                          (<= 4 y 9))
                     (and (<= 6 x 14)
                          (<= 10 y 12))))]
    (println (pf/A* passable? [6 5] [6 12]))))

write test to replicate failing scenario


(ns cmr.common.test.cache
  (:require [clojure.test :refer :all]
            [cmr.common.cache :as c]))

(def counter (atom 0))

(defn increment-counter
  "Increments the counter atom and returns it"
  []
  (swap! counter inc))

(deftest cache-test
  (testing "cache hit, miss and reset"
    (let [cache-atom (c/create-cache)]
      (is (= 1 (c/cache-lookup cache-atom "key" increment-counter)))
      ;; look up again will not call the increment-counter function
      (is (= 1 (c/cache-lookup cache-atom "key" increment-counter)))
      (c/reset-cache cache-atom)
      (is (= 2 (c/cache-lookup cache-atom "key" increment-counter)))
      (is (= 2 (c/cache-lookup cache-atom "key" increment-counter))))))

(ns cmr.common.test.cache
  (:require [clojure.test :refer :all]
            [cmr.common.cache :as c]))

(def counter (atom 0))

(defn increment-counter
  "Increments the counter atom and returns it"
  []
  (swap! counter inc))

(deftest cache-test
  (testing "cache hit, miss and reset"
    (let [cache-atom (c/create-cache)]
      (reset! counter 0)
      (is (= 1 (c/cache-lookup cache-atom "key" increment-counter)))
      ;; look up again will not call the increment-counter function
      (is (= 1 (c/cache-lookup cache-atom "key" increment-counter)))
      (c/reset-cache cache-atom)
      (is (= 2 (c/cache-lookup cache-atom "key" increment-counter)))
      (is (= 2 (c/cache-lookup cache-atom "key" increment-counter))))))

Reset counter so the test can be run multiple times in repl.


(ns uuuurrrrllll.core
  (:require [compojure.core :refer [defroutes routes GET POST]]
            [clojure.core.cache :as cache]
            [ring.middleware.json :refer [wrap-json-body
                                          wrap-json-response]]
            [ring.adapter.jetty :as jetty])
  (:use [hiccup.core]))

;; One day in ms.
(def one-day (* (* (* 60 60) 24) 1000))
(def url-map (atom (cache/ttl-cache-factory {} :ttl one-day)))

(defn expire-entries! [c]
  (cache/ttl-cache-factory
   (into {} (filter #((complement nil?) (second %))
                    (map #(vector % (get c %)) (keys c))))
   :ttl (.ttl-ms c)))

(def char-seq (doall
               (for [c (range 65 91)]
                 (char c))))

(defn gen-short-url [n]
  (clojure.string/join
   (take n (repeatedly #(rand-nth char-seq)))))

(defn add-url! [url]
  (swap! url-map expire-entries!)
  (let [short-url (gen-short-url 10)]
    (swap! url-map assoc short-url url)
    short-url))

(defn handle-post [request]
  (if-let [url (get-in request [:body "url"])]
    {:status 201 :body {:short (add-url! url)}}
    {:status 400}))

(defn handle-get [request]
  (if-let [url (get-in request [:params :url])]
    {:status 301 :headers {"location" (@url-map url)}}
    {:status 404}))

(defn list-all [request]
  {:status 200
   :body (html [:body
                [:ul
                 (for [[k v] (seq @url-map)]
                   [:li [:a {:href v} k]])]])})

(defroutes app
  (POST "/" request
        handle-post)
  (GET "/list/" request
       list-all)
  (GET "/:url/" request
       handle-get))

(def wrapp
  (-> app
      wrap-json-body
      wrap-json-response))

(defn -main [& args]
  (jetty/run-jetty wrapp {:port 8080}))

(ns uuuurrrrllll.core
  (:require [compojure.core :refer [defroutes routes GET POST]]
            [clojure.core.cache :as cache]
            [ring.middleware.json :refer [wrap-json-body
                                          wrap-json-response]]
            [ring.adapter.jetty :as jetty])
  (:use [hiccup.core]))

;; One day in ms.
(def one-day (* (* (* 60 60) 24) 1000))
(def url-map (atom (cache/ttl-cache-factory {} :ttl one-day)))

(defn expire-entries! [c]
  (cache/ttl-cache-factory
   (into {} (filter #((complement nil?) (second %))
                    (map #(vector % (get c %)) (keys c))))
   :ttl (.ttl-ms c)))

(def char-seq (doall
               (for [c (range 65 91)]
                 (char c))))

(defn gen-short-url [n]
  (clojure.string/join
   (take n (repeatedly #(rand-nth char-seq)))))

(defn add-url! [url]
  (swap! url-map expire-entries!)
  (let [short-url (gen-short-url 10)]
    (swap! url-map assoc short-url url)
    short-url))

(defn handle-post [request]
  (if-let [url (get-in request [:body "url"])]
    {:status 201 :body {:short (add-url! url)}}
    {:status 400}))

(defn handle-get [request]
  (if-let [url (-> request
                   (get-in [:params :url])
                   ((fn [u] (cache/lookup @url-map u))))]
    {:status 301 :headers {"location" url}}
    {:status 404}))

(defn list-all [request]
  {:status 200
   :body (html [:body
                [:ul
                 (for [[k v] (seq @url-map)]
                   [:li [:a {:href v} k]])]])})

(defroutes app
  (POST "/" request
        handle-post)
  (GET "/list/" request
       list-all)
  (GET "/:url/" request
       handle-get))

(def wrapp
  (-> app
      wrap-json-body
      wrap-json-response))

(defn -main [& args]
  (jetty/run-jetty wrapp {:port 8080}))

Fix up GET now we use the TTL cache.

Fix up GET now we use the TTL cache.


(ns planck.http
  (:refer-clojure :exclude [get])
  (:require
    [planck.core]
    [planck.io]
    [clojure.string :as string]
    [cljs.spec :as s]))

(def content-types {:json            "application/json"
                    :xml             "application/xml"
                    :form-urlencoded "application/x-www-form-urlencoded"})

(def default-timeout 5)

(def boundary-constant "---------------planck-rocks-")

(def content-disposition "\nContent-Disposition: form-data; name=\"")

(defn- encode-val [k v]
  (str (js/encodeURIComponent (name k)) "=" (js/encodeURIComponent (str v))))

(defn- encode-vals [k vs]
  (->>
    vs
    (map #(encode-val k %))
    (string/join "&")))

(defn- encode-param [[k v]]
  (if (coll? v)
    (encode-vals k v)
    (encode-val k v)))

(defn generate-query-string [params]
  (->>
    params
    (map encode-param)
    (string/join "&")))

(defn- maybe-add-header [request key header-key]
  (when-let [val (key request)]
    (let [header-value (if (keyword? val)
                         (val content-types)
                         val)]
      (merge {header-key header-value} (:headers request)))))

(defn wrap-content-type
  "Set the appropriate Content Type header."
  [client]
  (fn [request]
    (if-let [headers (maybe-add-header request :content-type "Content-Type")]
      (-> request
        (dissoc :content-type)
        (assoc :headers headers)
        client)
      (client request))))

(defn wrap-accepts
  "Set the appropriate Accept header."
  [client]
  (fn [request]
    (if-let [headers (maybe-add-header request :accept "Accept")]
      (-> request
        (dissoc :accept)
        (assoc :headers headers)
        client)
      (client request))))

(defn wrap-debug
  "adds the request to the response if :debug is present"
  [client]
  (fn [request]
    (if-let [debug (:debug request)]
      (let [req (dissoc request :debug)]
        (assoc (client req) :request req))
      (client request))))

(defn wrap-add-content-length
  "Adds content-length if :body is present "
  [client]
  (fn [request]
    (if-let [body (:body request)]
      (let [headers (merge {"Content-length" (count body)} (:headers request))]
        (-> request
          (assoc :headers headers)
          client))
      (client request))))

(defn wrap-form-params
  "Adds form-params and content-type"
  [client]
  (fn [request]
    (if-let [form-params (:form-params request)]
      (-> request
        (dissoc :form-params)
        (assoc :content-type :form-urlencoded)
        (assoc :body (generate-query-string form-params))
        client)
      (client request))))

(defn wrap-add-headers
  "Adds headers to the request if they're not present"
  [client]
  (fn [request]
    (client (assoc request :headers (or (:headers request) {})))))

(defn wrap-add-timeout
  "Adds default timeout if :timeout is not present"
  [client timeout]
  (fn [request]
    (client (assoc request :timeout (or (:timeout request) timeout)))))

(defn generate-form-data [params]
  (conj (mapv (fn [[k v]]
                (if (coll? v)
                  (str content-disposition k "\"; filename=\"" (second v) "\"\n"
                    "Content-Type: application/octet-stream\n\n"
                    (first v))
                  (str content-disposition k "\"\n\n" v))) params) "--\n"))

(defn generate-multipart-body [boundary body-parts]
  (->> body-parts
    (map str (repeat boundary))
    (interpose "\n")
    (apply str)))

(defn boundary [c]
  (apply str (cons c (take 10 (repeatedly #(int (rand 10)))))))

(defn wrap-multipart-params [client]
  (fn [{:keys [multipart-params] :as request}]
    (if multipart-params
      (let [b (boundary boundary-constant)
            body (generate-multipart-body b (generate-form-data multipart-params))]
        (client (-> request
                  (dissoc :multipart-params)
                  (assoc :content-type (str "multipart/form-data; boundary=" b))
                  (assoc :body body))))
      (client request))))

(defn wrap-throw-on-error [client]
  (fn [request]
    (let [response (client request)]
      (if-let [error (:error response)]
        (throw (js/Error. error))
        response))))

(defn wrap-add-method [client method]
  (fn [request]
    (client (assoc request :method (string/upper-case (name method))))))

(defn wrap-to-from-js [client]
  (fn [request]
    (-> request
      clj->js
      client
      (js->clj :keywordize-keys true))))

(defn- do-request [client]
  (fn [opts]
    (client opts)))

(defn request [client method url opts]
  ((-> client
     do-request
     wrap-to-from-js
     wrap-throw-on-error
     wrap-debug
     wrap-accepts
     wrap-content-type
     wrap-add-content-length
     wrap-form-params
     wrap-multipart-params
     (wrap-add-timeout default-timeout)
     wrap-add-headers
     (wrap-add-method method)) (assoc opts :url url)))

(defn get
  "Performs a GET request. It takes an URL and an optional map of options.
  These include:
  :timeout, number, default 5 seconds
  :debug, boolean, assoc the request on to the response
  :accepts, keyword or string. Valid keywords are :json or :xml
  :content-type, keyword or string Valid keywords are :json or :xml
  :headers, map, a map containing headers"
  ([url] (get url {}))
  ([url opts] (request js/PLANCK_REQUEST :get url opts)))

(s/def ::timeout integer?)
(s/def ::debug boolean?)
(s/def ::accepts (s/or :kw #{:json :xml} :str string?))
(s/def ::content-type (s/or :kw #{:json :xml} :str string?))
(s/def ::headers (s/and map? (fn [m]
                               (and (every? keyword? (keys m))
                                    (every? string? (vals m))))))
(s/def ::body string?)
(s/def ::status integer?)

(s/fdef get
  :args (s/cat :url string? :opts (s/? (s/keys :opt-un [::timeout ::debug ::accepts ::content-type ::headers])))
  :ret (s/keys :req-un [::body ::headers ::status]))

(defn post
  "Performs a POST requeest. It takes an URL and an optional map of options
  These options include the options for get in addition to:
  :form-params, a map, will become the body of the request, urlencoded
  :multipart-params, a list of tuples, used for file-upload
                     {:multipart-params [[\"name\" \"value\"]
                                         [\"name\" [\"content\" \"filename\"]]"
  ([url] (post url {}))
  ([url opts] (request js/PLANCK_REQUEST :post url opts)))

(s/def ::form-params map?)
(s/def ::multipart-params seq?)

(s/fdef post
  :args (s/cat :url string? :opts (s/? (s/keys :opt-un [::timeout ::debug ::accepts ::content-type ::headers
                                                        ::form-params ::multipart-params])))
  :ret (s/keys :req-un [::body ::headers ::status]))

(extend-protocol planck.io/IOFactory
  js/goog.Uri
  (make-reader [url opts]
    (let [content (atom (:body (get url opts)))]
      (letfn [(read [] (let [return @content]
                         (reset! content nil)
                         return))]
        (planck.core/->BufferedReader
          read
          (fn [])
          (atom nil)))))
  (make-writer [url opts]
    (planck.core/->Writer
      (fn [content]
        (let [name (or (:param-name opts) "file")
              filename (or (:filename opts) "file.pnk")]
          (post url {:multipart-params [[name [content filename]]]}))
        nil)
      (fn [])
      (fn []))))

(extend-protocol planck.io/Coercions
  js/goog.Uri
  (as-url [u] u)
  (as-file [u]
    (if (= "file" (.getScheme u))
      (planck.io/as-file (.getPath u))
      (throw (js/Error. (str "Not a file: " u))))))

(ns planck.http
  (:refer-clojure :exclude [get])
  (:require
    [planck.core]
    [planck.io]
    [clojure.string :as string]
    [cljs.spec :as s]))

(def content-types {:json            "application/json"
                    :xml             "application/xml"
                    :form-urlencoded "application/x-www-form-urlencoded"})

(def default-timeout 5)

(def boundary-constant "---------------planck-rocks-")

(def content-disposition "\nContent-Disposition: form-data; name=\"")

(defn- encode-val [k v]
  (str (js/encodeURIComponent (name k)) "=" (js/encodeURIComponent (str v))))

(defn- encode-vals [k vs]
  (->>
    vs
    (map #(encode-val k %))
    (string/join "&")))

(defn- encode-param [[k v]]
  (if (coll? v)
    (encode-vals k v)
    (encode-val k v)))

(defn generate-query-string [params]
  (->>
    params
    (map encode-param)
    (string/join "&")))

(defn- maybe-add-header [request key header-key]
  (when-let [val (key request)]
    (let [header-value (if (keyword? val)
                         (val content-types)
                         val)]
      (merge {header-key header-value} (:headers request)))))

(defn wrap-content-type
  "Set the appropriate Content Type header."
  [client]
  (fn [request]
    (if-let [headers (maybe-add-header request :content-type "Content-Type")]
      (-> request
        (dissoc :content-type)
        (assoc :headers headers)
        client)
      (client request))))

(defn wrap-accepts
  "Set the appropriate Accept header."
  [client]
  (fn [request]
    (if-let [headers (maybe-add-header request :accept "Accept")]
      (-> request
        (dissoc :accept)
        (assoc :headers headers)
        client)
      (client request))))

(defn wrap-debug
  "adds the request to the response if :debug is present"
  [client]
  (fn [request]
    (if-let [debug (:debug request)]
      (let [req (dissoc request :debug)]
        (assoc (client req) :request req))
      (client request))))

(defn wrap-add-content-length
  "Adds content-length if :body is present "
  [client]
  (fn [request]
    (if-let [body (:body request)]
      (let [headers (merge {"Content-length" (count body)} (:headers request))]
        (-> request
          (assoc :headers headers)
          client))
      (client request))))

(defn wrap-form-params
  "Adds form-params and content-type"
  [client]
  (fn [request]
    (if-let [form-params (:form-params request)]
      (-> request
        (dissoc :form-params)
        (assoc :content-type :form-urlencoded)
        (assoc :body (generate-query-string form-params))
        client)
      (client request))))

(defn wrap-add-headers
  "Adds headers to the request if they're not present"
  [client]
  (fn [request]
    (client (assoc request :headers (or (:headers request) {})))))

(defn wrap-add-timeout
  "Adds default timeout if :timeout is not present"
  [client timeout]
  (fn [request]
    (client (assoc request :timeout (or (:timeout request) timeout)))))

(defn generate-form-data [params]
  (conj (mapv (fn [[k v]]
                (if (coll? v)
                  (str content-disposition k "\"; filename=\"" (second v) "\"\n"
                    "Content-Type: application/octet-stream\n\n"
                    (first v))
                  (str content-disposition k "\"\n\n" v))) params) "--\n"))

(defn generate-multipart-body [boundary body-parts]
  (->> body-parts
    (map str (repeat boundary))
    (interpose "\n")
    (apply str)))

(defn boundary [c]
  (apply str (cons c (take 10 (repeatedly #(int (rand 10)))))))

(defn wrap-multipart-params [client]
  (fn [{:keys [multipart-params] :as request}]
    (if multipart-params
      (let [b (boundary boundary-constant)
            body (generate-multipart-body b (generate-form-data multipart-params))]
        (client (-> request
                  (dissoc :multipart-params)
                  (assoc :content-type (str "multipart/form-data; boundary=" b))
                  (assoc :body body))))
      (client request))))

(defn wrap-throw-on-error [client]
  (fn [request]
    (let [response (client request)]
      (if-let [error (:error response)]
        (throw (js/Error. error))
        response))))

(defn wrap-add-method [client method]
  (fn [request]
    (client (assoc request :method (string/upper-case (name method))))))

(defn wrap-to-from-js [client]
  (fn [request]
    (-> request
      clj->js
      client
      (js->clj :keywordize-keys true))))

(defn- do-request [client]
  (fn [opts]
    (client opts)))

(defn request [client method url opts]
  ((-> client
     do-request
     wrap-to-from-js
     wrap-throw-on-error
     wrap-debug
     wrap-accepts
     wrap-content-type
     wrap-add-content-length
     wrap-form-params
     wrap-multipart-params
     (wrap-add-timeout default-timeout)
     wrap-add-headers
     (wrap-add-method method)) (assoc opts :url url)))

(defn get
  "Performs a GET request. It takes an URL and an optional map of options.
  These include:
  :timeout, number, default 5 seconds
  :debug, boolean, assoc the request on to the response
  :accepts, keyword or string. Valid keywords are :json or :xml
  :content-type, keyword or string Valid keywords are :json or :xml
  :headers, map, a map containing headers"
  ([url] (get url {}))
  ([url opts] (request js/PLANCK_REQUEST :get url opts)))

(s/def ::timeout integer?)
(s/def ::debug boolean?)
(s/def ::accepts (s/or :kw #{:json :xml} :str string?))
(s/def ::content-type (s/or :kw #{:json :xml} :str string?))
(s/def ::headers (s/and map? (fn [m]
                               (and (every? keyword? (keys m))
                                    (every? string? (vals m))))))
(s/def ::body string?)
(s/def ::status integer?)

(s/fdef get
  :args (s/cat :url string? :opts (s/? (s/keys :opt-un [::timeout ::debug ::accepts ::content-type ::headers])))
  :ret (s/keys :req-un [::body ::headers ::status]))

(defn post
  "Performs a POST request. It takes an URL and an optional map of options
  These options include the options for get in addition to:
  :form-params, a map, will become the body of the request, urlencoded
  :multipart-params, a list of tuples, used for file-upload
                     {:multipart-params [[\"name\" \"value\"]
                                         [\"name\" [\"content\" \"filename\"]]"
  ([url] (post url {}))
  ([url opts] (request js/PLANCK_REQUEST :post url opts)))

(s/def ::form-params map?)
(s/def ::multipart-params seq?)

(s/fdef post
  :args (s/cat :url string? :opts (s/? (s/keys :opt-un [::timeout ::debug ::accepts ::content-type ::headers
                                                        ::form-params ::multipart-params])))
  :ret (s/keys :req-un [::body ::headers ::status]))

(extend-protocol planck.io/IOFactory
  js/goog.Uri
  (make-reader [url opts]
    (let [content (atom (:body (get url opts)))]
      (letfn [(read [] (let [return @content]
                         (reset! content nil)
                         return))]
        (planck.core/->BufferedReader
          read
          (fn [])
          (atom nil)))))
  (make-writer [url opts]
    (planck.core/->Writer
      (fn [content]
        (let [name (or (:param-name opts) "file")
              filename (or (:filename opts) "file.pnk")]
          (post url {:multipart-params [[name [content filename]]]}))
        nil)
      (fn [])
      (fn []))))

(extend-protocol planck.io/Coercions
  js/goog.Uri
  (as-url [u] u)
  (as-file [u]
    (if (= "file" (.getScheme u))
      (planck.io/as-file (.getPath u))
      (throw (js/Error. (str "Not a file: " u))))))

Fix typo in http post docstring

Fix typo in http post docstring


(ns comic-reader.main
  (:require [comic-reader.api :as api]
            [comic-reader.handlers :refer [init-handlers!]]
            [comic-reader.subscriptions
             :refer [init-subscriptions!]]
            [comic-reader.history :as history]
            [reagent.core :as reagent :refer [atom]]
            [re-frame.core :as rf]
            [secretary.core :as secretary
                            :refer-macros [defroute]]))

;; Have secretary pull apart URL's and then dispatch with re-frame
(defroute sites-path "/" []
  (rf/dispatch [:sites]))

(defroute comics-path "/comics/:site" [site]
  (rf/dispatch [:comics site]))

(defroute read-path "/read/:comic/:volume/:page" {:as location}
  (rf/dispatch [:read location]))

;; Actual re-frame code

(defn four-oh-four []
  [:div
   [:h1 "Sorry!"]
   "There's nothing to see here."])

(defn comic-reader []
  (let [page (rf/subscribe [:page])]
    (fn []
      [:div
       (case @page
         :sites "Display the sites."
         :comics "Display the comics available."
         :read "Display the comic itself!"
         [four-oh-four])])))

(defn ^:export run []
  (init-handlers!)
  (init-subscriptions!)
  (rf/dispatch [:initialize])
  (try
    (history/hook-browser-navigation!)
    (catch js/Error e
      nil))
  (reagent/render [comic-reader]
                  (.-body js/document)))

(ns comic-reader.main
  (:require [comic-reader.api :as api]
            [comic-reader.handlers :refer [init-handlers!]]
            [comic-reader.subscriptions
             :refer [init-subscriptions!]]
            [comic-reader.history :as history]
            [reagent.core :as reagent :refer [atom]]
            [re-frame.core :as rf]
            [secretary.core :as secretary
                            :refer-macros [defroute]]))

;; Have secretary pull apart URL's and then dispatch with re-frame
(defroute sites-path "/" []
  (rf/dispatch [:sites]))

(defroute comics-path "/comics/:site" [site]
  (rf/dispatch [:comics site]))

(defroute read-path "/read/:comic/:volume/:page" {:as location}
  (rf/dispatch [:read location]))

;; Actual re-frame code

(defn four-oh-four []
  [:div
   [:h1 "Sorry!"]
   "There's nothing to see here."])

(defn comic-reader []
  (let [page (rf/subscribe [:page])]
    (fn []
      [:div
       (case @page
         :sites "Display the sites."
         :comics "Display the comics available."
         :read "Display the comic itself!"
         nil ""
         [four-oh-four])])))

(defn ^:export run []
  (init-handlers!)
  (init-subscriptions!)
  (rf/dispatch [:initialize])
  (try
    (history/hook-browser-navigation!)
    (catch js/Error e
      nil))
  (reagent/render [comic-reader]
                  (.-body js/document)))

Add nil to the main component render

Add nil to the main component render

Hopefully this will get rid of the 404flicker


(ns vault.blob.store-test
  (:require
    [byte-streams :refer [bytes=]]
    [clojure.java.io :as io]
    [clojure.string :as str]
    [clojure.test :refer :all]
    [environ.core :refer [env]]
    (vault.blob
      [core :as blob]
      [store :as store])
    (vault.blob.store
      [memory :refer [memory-store]]
      [file :refer [file-store]])))

;; STORAGE FUNCTION TESTS

(deftest blob-loading
  (is (nil? (blob/load (byte-array 0))))
  (is (nil? (blob/load "")))
  (let [blob (blob/load "foo")]
    (is (not (nil? blob)))
    (is (not (nil? (:id blob))))
    (is (not (empty? (:content blob))))))

(deftest list-wrapper
  (let [store (reify store/BlobStore (enumerate [this opts] (vector :list opts)))]
    (is (= [:list nil] (blob/list store)))
    (is (= [:list {:foo "bar" :baz 3}] (blob/list store :foo "bar" :baz 3)))))

(deftest get-wrapper
  (let [content (.getBytes "foobarbaz")
        id (blob/hash :sha256 content)
        store (reify store/BlobStore (get* [this id] (blob/load content)))
        blob (blob/get store id)]
    (is (= id (:id blob)))
    (is (bytes= content (:content blob)))
    (is (thrown? RuntimeException
                 (blob/get store (:id (blob/load "bazbarfoo")))))))

(deftest hash-id-selection
  (let [a (blob/hash-id :md5 "37b51d194a7513e45b56f6524f2d51f2")
        b (blob/hash-id :md5 "73fcffa4b7f6bb68e44cf984c85f6e88")
        c (blob/hash-id :md5 "73fe285cedef654fccc4a4d818db4cc2")
        d (blob/hash-id :md5 "acbd18db4cc2f85cedef654fccc4a4d8")
        e (blob/hash-id :md5 "c3c23db5285662ef7172373df0003206")
        hash-ids [a b c d e]]
    (are [brs opts] (= brs (store/select-ids opts hash-ids))
         hash-ids {}
         [c d e]  {:after "md5:73fd2"}
         [b c]    {:prefix "md5:73"}
         [a b]    {:limit 2})))

;; STORAGE IMPLEMENTATION TESTS

(defn- store-test-blobs!
  "Stores some test blobs in the given blob store and returns a map of the
  ids to the original string values."
  [store]
  (->> ["foo" "bar" "baz" "foobar" "barbaz"]
       (map (juxt (comp :id (partial blob/store! store)) identity))
       (into (sorted-map))))

(defn- test-blob-content
  "Determines whether the store contains the content for the given identifier."
  [store id content]
  (let [status (blob/stat store id)
        stored-content (:content (blob/get store id))]
    (is (and status stored-content) "returns info and content")
    (is (= (:stat/size status) (count stored-content)) "stats contain size info")
    (is (= content (slurp stored-content)) "stored content matches input")))

(defn- test-restore-blob
  "Tests re-storing an existing blob."
  [store id content]
  (let [status     (blob/stat store id)
        new-blob   (blob/store! store content)
        new-status (blob/stat store id)]
    (is (= id (:id new-blob)))
    (is (= (:stat/stored-at status)
           (:stat/stored-at new-status)))))

(defn test-blob-store
  "Tests a blob store implementation."
  [store]
  (is (empty? (blob/list store)) "starts empty")
  (testing (str (-> store class .getSimpleName))
    (let [stored-content (store-test-blobs! store)]
      (is (= (keys stored-content) (blob/list store {}))
          "enumerates all ids in sorted order")
      (doseq [[id content] stored-content]
        (test-blob-content store id content))
      (let [[id content] (first (seq stored-content))]
        (test-restore-blob store id content))
      (when (satisfies? store/DestructiveBlobStore store)
        (doseq [id (keys stored-content)]
          (is (store/delete! store id) "delete returns true"))
        (is (empty? (blob/list store)) "ends empty")
        (is (not (store/delete! store (first (keys stored-content))))
          "gives false when removing a nonexistent blob")))))

(defn store-enabled?
  "Uses the VAULT_BLOB_STORE_TESTS environment variable to determine which
  tests to run."
  [store-type]
  (some->
    (env :vault-blob-store-tests)
    (str/split #",")
    set
    (contains? store-type)))

(deftest test-memory-store
  ; Always enabled.
  (println "  - memory-store")
  (let [store (memory-store)]
    (test-blob-store (memory-store))
    (store/destroy!! store)))

(deftest test-file-store
  (when (store-enabled? "file")
    (println "  - file-store")
    (let [tmpdir (io/file "target" "test" "tmp"
                          (str "file-blob-store."
                            (System/currentTimeMillis)))
         store (file-store tmpdir)]
      (test-blob-store (file-store tmpdir))
      (store/destroy!! store))))

(ns vault.blob.store-test
  (:require
    [byte-streams :refer [bytes=]]
    [clojure.java.io :as io]
    [clojure.string :as str]
    [clojure.test :refer :all]
    [environ.core :refer [env]]
    (vault.blob
      [core :as blob]
      [store :as store])
    (vault.blob.store
      [memory :refer [memory-store]]
      [file :refer [file-store]])))

;; STORAGE FUNCTION TESTS

(deftest blob-loading
  (is (nil? (blob/load (byte-array 0))))
  (is (nil? (blob/load "")))
  (let [blob (blob/load "foo")]
    (is (not (nil? blob)))
    (is (not (nil? (:id blob))))
    (is (not (empty? (:content blob))))))

(deftest list-wrapper
  (let [store (reify store/BlobStore (enumerate [this opts] (vector :list opts)))]
    (is (= [:list nil] (blob/list store)))
    (is (= [:list {:foo "bar" :baz 3}] (blob/list store :foo "bar" :baz 3)))))

(deftest get-wrapper
  (let [content (.getBytes "foobarbaz")
        id (blob/hash :sha256 content)
        store (reify store/BlobStore (get* [this id] (blob/load content)))
        blob (blob/get store id)]
    (is (= id (:id blob)))
    (is (bytes= content (:content blob)))
    (is (thrown? RuntimeException
                 (blob/get store (:id (blob/load "bazbarfoo")))))))

(deftest hash-id-selection
  (let [a (blob/hash-id :md5 "37b51d194a7513e45b56f6524f2d51f2")
        b (blob/hash-id :md5 "73fcffa4b7f6bb68e44cf984c85f6e88")
        c (blob/hash-id :md5 "73fe285cedef654fccc4a4d818db4cc2")
        d (blob/hash-id :md5 "acbd18db4cc2f85cedef654fccc4a4d8")
        e (blob/hash-id :md5 "c3c23db5285662ef7172373df0003206")
        hash-ids [a b c d e]]
    (are [brs opts] (= brs (store/select-ids opts hash-ids))
         hash-ids {}
         [c d e]  {:after "md5:73fd2"}
         [b c]    {:prefix "md5:73"}
         [a b]    {:limit 2})))

;; STORAGE IMPLEMENTATION TESTS

(defn- store-test-blobs!
  "Stores some test blobs in the given blob store and returns a map of the
  ids to the original string values."
  [store]
  (->> ["foo" "bar" "baz" "foobar" "barbaz"]
       (map (juxt (comp :id (partial blob/store! store)) identity))
       (into (sorted-map))))

(defn- test-blob-content
  "Determines whether the store contains the content for the given identifier."
  [store id content]
  (let [status (blob/stat store id)
        stored-content (:content (blob/get store id))]
    (is (and status stored-content) "returns info and content")
    (is (= (:stat/size status) (count stored-content)) "stats contain size info")
    (is (= content (slurp stored-content)) "stored content matches input")))

(defn- test-restore-blob
  "Tests re-storing an existing blob."
  [store id content]
  (let [status     (blob/stat store id)
        new-blob   (blob/store! store content)
        new-status (blob/stat store id)]
    (is (= id (:id new-blob)))
    (is (= (:stat/stored-at status)
           (:stat/stored-at new-status)))))

(defn test-blob-store
  "Tests a blob store implementation."
  [store label]
  (println "  *" label)
  (is (empty? (blob/list store)) "starts empty")
  (testing (str (-> store class .getSimpleName))
    (let [stored-content (store-test-blobs! store)]
      (is (= (keys stored-content) (blob/list store {}))
          "enumerates all ids in sorted order")
      (doseq [[id content] stored-content]
        (test-blob-content store id content))
      (let [[id content] (first (seq stored-content))]
        (test-restore-blob store id content))
      (when (satisfies? store/DestructiveBlobStore store)
        (doseq [id (keys stored-content)]
          (is (store/delete! store id) "delete returns true"))
        (is (empty? (blob/list store)) "ends empty")
        (is (not (store/delete! store (first (keys stored-content))))
          "gives false when removing a nonexistent blob")))))

(defn store-enabled?
  "Uses the VAULT_BLOB_STORE_TESTS environment variable to determine which
  tests to run."
  [store-type]
  (some->
    (env :vault-blob-store-tests)
    (str/split #",")
    set
    (contains? store-type)))

(deftest test-memory-store
  ; Always enabled.
  (let [store (memory-store)]
    (test-blob-store store "memory-store")
    (store/destroy!! store)))

(deftest test-file-store
  (when (store-enabled? "file")
    (let [tmpdir (io/file "target" "test" "tmp"
                          (str "file-blob-store."
                            (System/currentTimeMillis)))
          store (file-store tmpdir)]
      (test-blob-store store "file-store")
      (store/destroy!! store))))

Clean up some blob store test code.

Clean up some blob store test code.


;
;  (C) Copyright 2016  Pavel Tisnovsky
;
;  All rights reserved. This program and the accompanying materials
;  are made available under the terms of the Eclipse Public License v1.0
;  which accompanies this distribution, and is available at
;  http://www.eclipse.org/legal/epl-v10.html
;
;  Contributors:
;      Pavel Tisnovsky
;

(ns zg.html-renderer-test
  (:require [clojure.test :refer :all]
            [zg.html-renderer :refer :all]))

(require '[hiccup.page :as page])

;
; Common functions used by tests.
;

(defn callable?
    "Test if given function-name is bound to the real function."
    [function-name]
    (clojure.test/function? function-name))

;
; Test for existence of several functions.
;

(deftest test-render-html-header-existence
    "Check that the zg.html-renderer/render-html-header definition exists."
    (testing "if the zg.html-renderer/render-html-header definition exists."
        (is (callable? 'zg.html-renderer/render-html-header))))

(deftest test-render-html-footer-existence
    "Check that the zg.html-renderer/render-html-footer definition exists."
    (testing "if the zg.html-renderer/render-html-footer definition exists."
        (is (callable? 'zg.html-renderer/render-html-footer))))

(deftest test-search-href-existence
    "Check that the zg.html-renderer/search-href definition exists."
    (testing "if the zg.html-renderer/search-href definition exists."
        (is (callable? 'zg.html-renderer/search-href))))

(deftest test-render-search-field-existence
    "Check that the zg.html-renderer/render-search-field definition exists."
    (testing "if the zg.html-renderer/render-search-field definition exists."
        (is (callable? 'zg.html-renderer/render-search-field))))

(deftest test-render-name-field-existence
    "Check that the zg.html-renderer/render-name-field definition exists."
    (testing "if the zg.html-renderer/render-name-field definition exists."
        (is (callable? 'zg.html-renderer/render-name-field))))

(deftest test-tab-class-existence
    "Check that the zg.html-renderer/tab-class definition exists."
    (testing "if the zg.html-renderer/tab-class definition exists."
        (is (callable? 'zg.html-renderer/tab-class))))

(deftest test-user-href-existence
    "Check that the zg.html-renderer/user-href definition exists."
    (testing "if the zg.html-renderer/user-href definition exists."
        (is (callable? 'zg.html-renderer/user-href))))

(deftest test-users-href-existence
    "Check that the zg.html-renderer/users-href definition exists."
    (testing "if the zg.html-renderer/users-href definition exists."
        (is (callable? 'zg.html-renderer/users-href))))

(deftest test-remember-me-href-existence
    "Check that the zg.html-renderer/remember-me-href definition exists."
    (testing "if the zg.html-renderer/remember-me-href definition exists."
        (is (callable? 'zg.html-renderer/remember-me-href))))

(deftest test-render-navigation-bar-section-existence
    "Check that the zg.html-renderer/render-navigation-bar-section definition exists."
    (testing "if the zg.html-renderer/render-navigation-bar-section definition exists."
        (is (callable? 'zg.html-renderer/render-navigation-bar-section))))

(deftest test-render-error-page-existence
    "Check that the zg.html-renderer/render-error-page definition exists."
    (testing "if the zg.html-renderer/render-error-page definition exists."
        (is (callable? 'zg.html-renderer/render-error-page))))

(deftest test-render-front-page-existence
    "Check that the zg.html-renderer/render-front-page definition exists."
    (testing "if the zg.html-renderer/render-front-page definition exists."
        (is (callable? 'zg.html-renderer/render-front-page))))

(deftest test-render-users-existence
    "Check that the zg.html-renderer/render-users definition exists."
    (testing "if the zg.html-renderer/render-users definition exists."
        (is (callable? 'zg.html-renderer/render-users))))

(deftest test-render-user-info-existence
    "Check that the zg.html-renderer/render-user-info definition exists."
    (testing "if the zg.html-renderer/render-user-info definition exists."
        (is (callable? 'zg.html-renderer/render-user-info))))

;
; Test for function behaviours
;

(deftest test-render-html-header
    "Checking the function zg.html-renderer/render-html-header."
    (testing "the function zg.html-renderer/render-html-header."
        (are [x y] (= (slurp x) y)
            "test/expected/html_header1.html" (page/xhtml (render-html-header "" "" ""))
            "test/expected/html_header2.html" (page/xhtml (render-html-header "" "" "title"))
            "test/expected/html_header3.html" (page/xhtml (render-html-header "" "http://10.20.30.40/" ""))
            "test/expected/html_header4.html" (page/xhtml (render-html-header "" "http://10.20.30.40/" "title"))
            "test/expected/html_header5.html" (page/xhtml (render-html-header "word" "" ""))
            "test/expected/html_header6.html" (page/xhtml (render-html-header "word" "" "title"))
            "test/expected/html_header7.html" (page/xhtml (render-html-header "word" "http://10.20.30.40/" ""))
            "test/expected/html_header8.html" (page/xhtml (render-html-header "word" "http://10.20.30.40/" "title")))))

(deftest test-render-html-footer
    "Checking the function zg.html-renderer/render-html-footer."
    (testing "the function zg.html-renderer/render-html-footer."
        (is (= (slurp "test/expected/html_footer1.html") (page/xhtml (render-html-footer))))))

(deftest test-render-search-href
    "Checking the function zg.html-renderer/render-search-href."
    (testing "the function zg.html-renderer/render-search-href."
        (are [x y] (= (slurp x) y)
            "test/expected/search-href1.html" (search-href "" :whitelist)
            "test/expected/search-href2.html" (search-href "" :blacklist)
            "test/expected/search-href3.html" (search-href "/" :whitelist)
            "test/expected/search-href4.html" (search-href "/" :blacklist)
            "test/expected/search-href5.html" (search-href "http://10.20.30.40/" :whitelist)
            "test/expected/search-href6.html" (search-href "http://10.20.30.40/" :blacklist)
            "test/expected/search-href7.html" (search-href "http://10.20.30.40/zg/" :whitelist)
            "test/expected/search-href8.html" (search-href "http://10.20.30.40/zg/" :blacklist))))

(deftest test-render-search-field
    "Checking the function zg.html-renderer/render-search-field."
    (testing "the function zg.html-renderer/render-search-field."
        (are [x y] (= (slurp x) y)
            "test/expected/search-field1.html" (page/xhtml (render-search-field "word" "" :whitelist))
            "test/expected/search-field2.html" (page/xhtml (render-search-field "word" "" :blacklist))
            "test/expected/search-field3.html" (page/xhtml (render-search-field "word" "/" :whitelist))
            "test/expected/search-field4.html" (page/xhtml (render-search-field "word" "/" :blacklist))
            "test/expected/search-field5.html" (page/xhtml (render-search-field "word" "http://10.20.30.40/" :whitelist))
            "test/expected/search-field6.html" (page/xhtml (render-search-field "word" "http://10.20.30.40/" :blacklist))
            "test/expected/search-field7.html" (page/xhtml (render-search-field "word" "http://10.20.30.40/zg/" :whitelist))
            "test/expected/search-field8.html" (page/xhtml (render-search-field "word" "http://10.20.30.40/zg/" :blacklist)))))

(deftest test-render-name-field
    "Checking the function zg.html-renderer/render-name-field."
    (testing "the function zg.html-renderer/render-name-field."
        (are [x y] (= (slurp x) y)
            "test/expected/name-field1.html" (page/xhtml (render-name-field "user name" ""))
            "test/expected/name-field3.html" (page/xhtml (render-name-field "user name" "/"))
            "test/expected/name-field5.html" (page/xhtml (render-name-field "user name" "http://10.20.30.40/"))
            "test/expected/name-field7.html" (page/xhtml (render-name-field "user name" "http://10.20.30.40/zg/")))))

(deftest test-tab-class
    "Checking the function zg.html-renderer/tab-class."
    (testing "the function zg.html-renderer/tab-class."
        (are [x y] (= x y)
            {:class "active"} (tab-class 1 1)
            {:class "active"} (tab-class true true)
            {:class "active"} (tab-class "word" "word")
            nil               (tab-class 1 2)
            nil               (tab-class true false)
            nil               (tab-class "word" "world"))))

Test for function tab-class

Test for function tab-class


(ns yablog.core-test
  (:require [clojure.test :refer :all]
            [yablog.core :refer :all]))

(deftest a-test
  (testing "FIXME, I fail."
    (is (= 0 1))))

delete boilerplate failing test

delete boilerplate failing test


(ns pro.juxt.edge.doc-site
  (:require
    [integrant.core :as ig]
    [clojure.java.io :as io]
    [edge.asciidoctor :refer [load-doc]]
    [yada.yada :as yada]))

(defn routes [engine]
  [["" (merge
         (yada/redirect ::doc-resource {:route-params {:name "index"}})
         {:id ::doc-index})]
   [[:name ".html"]
    (yada/resource
      {:id ::doc-resource
       :methods
       {:get
        {:produces [{:media-type "text/html;q=0.8" :charset "utf-8"}
                    {:media-type "application/json"}]
         :response (fn [ctx]
                     (let [path (str "doc/sources/" (-> ctx :parameters :path :name) ".adoc")]
                       (try
                         (.convert
                           (load-doc
                             ctx
                             engine
                             (-> ctx :parameters :path :name)
                             (slurp (io/resource path))))
                         (catch Exception e
                           (throw (ex-info (format "Failed to convert %s" path)
                                           {:path path} e))))))}}})]])

(defmethod ig/init-key ::routes [_ {:keys [edge.asciidoctor/engine]}]
  (routes engine))

(ns pro.juxt.edge.doc-site
  (:require
    [integrant.core :as ig]
    [clojure.java.io :as io]
    [edge.asciidoctor :refer [load-doc]]
    [yada.yada :as yada]))

(defn routes [engine]
  [["" (merge
         (yada/redirect ::doc-resource {:route-params {:name "index"}})
         {:id ::doc-index})]
   [[;; regex derived from bidi's default, but adding / to allow directories
     [#"[A-Za-z0-9\\-\\_\\.\/]+" :name] ".html"]
    (yada/resource
      {:id ::doc-resource
       :methods
       {:get
        {:produces [{:media-type "text/html;q=0.8" :charset "utf-8"}
                    {:media-type "application/json"}]
         :response (fn [ctx]
                     (let [path (str "doc/sources/" (-> ctx :parameters :path :name) ".adoc")]
                       (try
                         (.convert
                           (load-doc
                             ctx
                             engine
                             (-> ctx :parameters :path :name)
                             (slurp (io/resource path))))
                         (catch Exception e
                           (throw (ex-info (format "Failed to convert %s" path)
                                           {:path path} e))))))}}})]])

(defmethod ig/init-key ::routes [_ {:keys [edge.asciidoctor/engine]}]
  (routes engine))

Add support for nested directories to doc-site


(ns com.stuartsierra.lazytest.report
  (:use [com.stuartsierra.lazytest :only (success?)]
        [clojure.stacktrace :only (print-cause-trace)])
  (:import (java.io File)))

(defn result-seq
  "Given a single TestResult, returns a depth-first sequence of that
  TestResult and all its children."
  [r]
  (tree-seq :children :children r))

(defn details
  "Given a TestResult, returns the map of :name, :ns, :file, :line,
  :generator, and :form."
  [r]
  (meta (:source r)))

(defn print-details
  "Prints full details of a TestResult, including file and line
  number, doc string, and stack trace if applicable."
  [r]
  (println
   (cond (success? r) "SUCCESS"
         (:throwable r) "ERROR"
         :else "FAIL"))
  (let [m (details r)]
    (when-let [n (:name m)] (println "Name:" n))
    (when-let [d (:doc m)] (println "Doc: " d))
    (when (and (:form m) (not (:name m)))
      (print "Form: ")
      (prn (:form m)))
    (when-let [f (:file m)] (println "File:" f))
    (when-let [l (:line m)] (println "Line:" l))
    (when (seq (:states r))
      (print "Context states: ")
      (prn (:states r)))
    (when-let [e (:throwable r)]
      (println "STACK TRACE")
      (print-cause-trace e))))

(defn assertion-results
  "Returns a sequence of all assertion results (not grouped test
  results) in the tree rooted at r."
  [r]
  (filter #(empty? (:children %)) (result-seq r)))

(defn summary
  "Returns a map of :total, :pass, :fail, and :error
  counts for assertions in the results tree rooted at r."
  [r]
  (reduce (fn [m r]
            (assoc (cond (success? r) (assoc m :pass (inc (:pass m)))
                         (:throwable r) (assoc m :error (inc (:error m)))
                         :else (assoc m :fail (inc (:fail m))))
              :assertions (inc (:assertions m 0))))
          {:assertions 0, :pass 0, :fail 0, :error 0}
          (assertion-results r)))

(defn print-summary [r]
  (let [{:keys [assertions pass fail error]} (summary r)]
    (println "Ran" assertions "assertions.")
    (println fail "failures," error "errors.")))

(defn dot-report
  "Simple spec report.  Prints a dot for each passed assertion; prints
  details for each failure."
  [r]
  (println "Running" (:name (details r)))
  (doseq [c (assertion-results r)]
    (if (success? c)
      (do (print ".") (flush))
      (do (newline) (print-details c))))
  (newline)
  (print-summary r))

(defn- spec-report* [r parents]
  (if (seq (:children r))
    (doseq [c (:children r)]
      (spec-report* c (conj parents r)))
    (if (success? r)
      (do (print ".") (flush))
      (do (newline)
          (print-details
           (assoc r :source
                  (vary-meta (:source r) assoc :doc
                             (apply str (interpose " "
                                                   (filter identity
                                                           (map #(:doc (details %))
                                                                (conj parents r))))))))))))

(defn spec-report
  "Like dot-report but concatenates :doc strings for nested specs."
  [r]
  (println "Running" (:name (details r)))
  (spec-report* r [])
  (newline)
  (print-summary r))

(ns com.stuartsierra.lazytest.report
  (:use [com.stuartsierra.lazytest :only (success?)]
        [com.stuartsierra.lazytest.color :only (colorize)]
        [clojure.stacktrace :only (print-cause-trace)])
  (:import (java.io File)))

(defn result-seq
  "Given a single TestResult, returns a depth-first sequence of that
  TestResult and all its children."
  [r]
  (tree-seq :children :children r))

(defn details
  "Given a TestResult, returns the map of :name, :ns, :file, :line,
  :generator, and :form."
  [r]
  (meta (:source r)))

(defn print-details
  "Prints full details of a TestResult, including file and line
  number, doc string, and stack trace if applicable."
  [r]
  (println
   (cond (success? r) (colorize "SUCCESS" :fg-green)
         (:throwable r) (colorize "ERROR" :fg-red)
         :else (colorize "FAIL" :fg-red)))
  (let [m (details r)]
    (when-let [n (:name m)] (println "Name:" n))
    (when-let [d (:doc m)] (println "Doc: " d))
    (when (and (:form m) (not (:name m)))
      (print "Form: ")
      (prn (:form m)))
    (when-let [f (:file m)] (println "File:" f))
    (when-let [l (:line m)] (println "Line:" l))
    (when (seq (:states r))
      (print "Context states: ")
      (prn (:states r)))
    (when-let [e (:throwable r)]
      (println "STACK TRACE")
      (print-cause-trace e))))

(defn assertion-results
  "Returns a sequence of all assertion results (not grouped test
  results) in the tree rooted at r."
  [r]
  (filter #(empty? (:children %)) (result-seq r)))

(defn summary
  "Returns a map of :total, :pass, :fail, and :error
  counts for assertions in the results tree rooted at r."
  [r]
  (reduce (fn [m r]
            (assoc (cond (success? r) (assoc m :pass (inc (:pass m)))
                         (:throwable r) (assoc m :error (inc (:error m)))
                         :else (assoc m :fail (inc (:fail m))))
              :assertions (inc (:assertions m 0))))
          {:assertions 0, :pass 0, :fail 0, :error 0}
          (assertion-results r)))

(defn print-summary [r]
  (let [{:keys [assertions pass fail error]} (summary r)]
    (println "Ran" assertions "assertions.")
    (print (colorize (str fail " failures")
                     (if (zero? fail) :fg-green :fg-red)))
    (print ", ")
    (print (colorize (str error " errors")
                     (if (zero? error) :fg-green :fg-red)))
    (newline)))

(defn dot-report
  "Simple spec report.  Prints a dot for each passed assertion; prints
  details for each failure."
  [r]
  (println "Running" (:name (details r))
           "at" (str (java.util.Date.)))
  (doseq [c (assertion-results r)]
    (if (success? c)
      (do (print (colorize "." :fg-green)) (flush))
      (do (newline) (print-details c))))
  (newline)
  (print-summary r))

(defn- spec-report* [r parents]
  (if (seq (:children r))
    (doseq [c (:children r)]
      (spec-report* c (conj parents r)))
    (if (success? r)
      (do (print (colorize "." :fg-green)) (flush))
      (do (newline)
          (print-details
           (assoc r :source
                  (vary-meta (:source r) assoc :doc
                             (apply str (interpose " "
                                                   (filter identity
                                                           (map #(:doc (details %))
                                                                (conj parents r))))))))))))

(defn spec-report
  "Like dot-report but concatenates :doc strings for nested specs."
  [r]
  (println "Running" (:name (details r))
           "at" (str (java.util.Date.)))
  (spec-report* r [])
  (newline)
  (print-summary r))

Add color to default reports

Add color to default reports


{:pedestal {}
 :yolo {}
 :marginalia {:plugins [[michaelblume/marginalia "0.9.0"]]}
 :user {:signing {:gpg-key "F5619DFC"}
        ;;:plugins [[cider/cider-nrepl "0.9.0"]]
        }
 :woot {:plugins [[lein-ancient "0.6.7"]]}
 :cider-repl {:dependencies [[org.clojure/tools.nrepl "0.2.12"]]
              :plugins [[cider/cider-nrepl "0.11.0"]]}

 :mavbozo {
           ;;:repl-options {:prompt (fn [ns] (str "[" *ns* "]" \newline "=> "))}
           :repl-options { ; for nREPL dev you really need to limit output
                          :init (set! *print-length* 50)
                          :nrepl-middleware [cemerick.piggieback/wrap-cljs-repl]}
           :dependencies [[spyscope "0.1.5"]
                          [clojure-complete "0.2.3"]
                          [leiningen #=(leiningen.core.main/leiningen-version)]
                          [io.aviso/pretty "0.1.8"]
                          [im.chit/vinyasa "0.3.0"]
                          [figwheel-sidecar "0.5.3-1"]
                          [com.cemerick/piggieback "0.2.1"]]
           :plugins [[cider/cider-nrepl "0.12.0"]
                     [jonase/eastwood "0.2.3"]
                     [lein-ns-dep-graph "0.1.0-SNAPSHOT"]
                     ]
           :injections
           [(require 'spyscope.core)
            (require '[vinyasa.inject :as inject])
            (require 'io.aviso.repl)
            (inject/in ;; the default injected namespace is `.`

             ;; note that `:refer, :all and :exclude can be used
             [vinyasa.inject :refer [inject [in inject-in]]]
             [vinyasa.lein :exclude [*project*]]

             ;; imports all functions in vinyasa.pull
             [vinyasa.pull :all]

             ;; same as [cemerick.pomegranate
             ;;           :refer [add-classpath get-classpath resources]]
             [cemerick.pomegranate add-classpath get-classpath resources]

             ;; inject into clojure.core
             clojure.core
             [vinyasa.reflection .> .? .* .% .%> .& .>ns .>var]

             ;; inject into clojure.core with prefix
             clojure.core >
             [clojure.pprint pprint]
             [clojure.java.shell sh])]}}

{:pedestal {}
 :yolo {}
 :marginalia {:plugins [[michaelblume/marginalia "0.9.0"]]}
 :user {:signing {:gpg-key "F5619DFC"}
        ;;:plugins [[cider/cider-nrepl "0.9.0"]]
        }
 :woot {:plugins [[lein-ancient "0.6.7"]]}
 :cider-repl {:dependencies [[org.clojure/tools.nrepl "0.2.12"]]
              :plugins [[cider/cider-nrepl "0.12.0"]]}
 :repl {:dependencies [[org.clojure/tools.nrepl "0.2.12"]]
        :plugins [[cider/cider-nrepl "0.12.0"]]}
 :mavbozo {
           ;;:repl-options {:prompt (fn [ns] (str "[" *ns* "]" \newline "=> "))}
           :repl-options { ; for nREPL dev you really need to limit output
                          :init (set! *print-length* 50)
                          :nrepl-middleware [cemerick.piggieback/wrap-cljs-repl]}
           :dependencies [[spyscope "0.1.5"]
                          [clojure-complete "0.2.3"]
                          [leiningen #=(leiningen.core.main/leiningen-version)]
                          [io.aviso/pretty "0.1.8"]
                          [im.chit/vinyasa "0.3.0"]
                          [figwheel-sidecar "0.5.3-1"]
                          [com.cemerick/piggieback "0.2.1"]]
           :plugins [[cider/cider-nrepl "0.12.0"]
                     [jonase/eastwood "0.2.3"]
                     [lein-ns-dep-graph "0.1.0-SNAPSHOT"]
                     ]
           :injections
           [(require 'spyscope.core)
            (require '[vinyasa.inject :as inject])
            (require 'io.aviso.repl)
            (inject/in ;; the default injected namespace is `.`

             ;; note that `:refer, :all and :exclude can be used
             [vinyasa.inject :refer [inject [in inject-in]]]
             [vinyasa.lein :exclude [*project*]]

             ;; imports all functions in vinyasa.pull
             [vinyasa.pull :all]

             ;; same as [cemerick.pomegranate
             ;;           :refer [add-classpath get-classpath resources]]
             [cemerick.pomegranate add-classpath get-classpath resources]

             ;; inject into clojure.core
             clojure.core
             [vinyasa.reflection .> .? .* .% .%> .& .>ns .>var]

             ;; inject into clojure.core with prefix
             clojure.core >
             [clojure.pprint pprint]
             [clojure.java.shell sh])]}}

add leiningen :repl profile

add leiningen :repl profile


(ns lazytest.test-case)

(defn test-case
  "Sets metadata on function f identifying it as a test case.  A test
  case function may execute arbitrary code and may have side effects.
  It should throw an exception to indicate failure.  Returning without
  throwing an exception indicates success.

  Additional identifying metadata may be placed on the function, such
  as :name and :doc."
  [f]
  {:pre [(fn? f)]}
  (vary-meta f assoc ::test-case true))

(defn test-case?
  "True if x is a test case."
  [x]
  (and (fn? x) (::test-case (meta x))))

(defn test-case-result
  "Creates a test case result map with keys :pass?, :source, and :thrown.

  pass? is true if the test case passed successfully, false otherwise.

  source is the test case object that returned this result.

  thrown is the exception (Throwable) thrown by a failing test case."
  ([pass? source]
     {:pre [(or (true? pass?) (false? pass?))
	    (test-case? source)]}
     (with-meta {:pass? pass?, :source source}
       {:type ::test-case-result}))
  ([pass? source thrown]
     {:pre [(or (true? pass?) (false? pass?))
	    (test-case? source)
	    (instance? Throwable thrown)]}
     (with-meta {:pass? pass?, :source source, :thrown thrown}
       {:type ::test-case-result})))

(defn test-case-result?
  "True if x is a test case result."
  [x]
  (and (map? x) (isa? (type x) ::test-case-result)))

(defn try-test-case
  "Executes a test case function.  Does not execute before/after
   metadata functions.  Catches all Throwables.  Returns a map with
   the following key-value pairs:

     :source - the input function
     :pass?  - true if the function ran without throwing
     :thrown - the Throwable instance if thrown"
  [f]
  {:pre [(test-case? f)]
   :post [(test-case-result? %)]}
  (try (f)
       (test-case-result true f)
       (catch Throwable t
	 (test-case-result false f t))))

(ns lazytest.test-case)

(defn test-case
  "Sets metadata on function f identifying it as a test case.  A test
  case function may execute arbitrary code and may have side effects.
  It should throw an exception to indicate failure.  Returning without
  throwing an exception indicates success.

  Additional identifying metadata may be placed on the function, such
  as :name and :doc."
  [f]
  {:pre [(fn? f)]}
  (vary-meta f assoc ::test-case true))

(defn test-case?
  "True if x is a test case."
  [x]
  (and (fn? x) (::test-case (meta x))))

(defn test-case-result
  "Creates a test case result map with keys :pass?, :source, and :thrown.

  pass? is true if the test case passed successfully, false otherwise.

  source is the test case object that returned this result.

  thrown is the exception (Throwable) thrown by a failing test case."
  ([pass? source]
     {:pre [(or (true? pass?) (false? pass?))
	    (test-case? source)]}
     (with-meta {:pass? pass?, :source source}
       {:type ::test-case-result}))
  ([pass? source thrown]
     {:pre [(or (true? pass?) (false? pass?))
	    (test-case? source)
	    (instance? Throwable thrown)]}
     (with-meta {:pass? pass?, :source source, :thrown thrown}
       {:type ::test-case-result})))

(defn test-case-result?
  "True if x is a test case result."
  [x]
  (and (map? x) (isa? (type x) ::test-case-result)))

(defn try-test-case
  "Executes a test case function.  Catches all Throwables.  Returns a
   map with the following key-value pairs:

     :source - the input function
     :pass?  - true if the function ran without throwing
     :thrown - the Throwable instance if thrown"
  [f]
  {:pre [(test-case? f)]
   :post [(test-case-result? %)]}
  (try (f)
       (test-case-result true f)
       (catch Throwable t
	 (test-case-result false f t))))

Remove additional references to wrapper functions