(ns om-css.tests
  (:require [clojure.test :refer [deftest testing is are]]
            [om-css.core :as oc]))

(def component-info
  {:component-name "Foo"
   :ns-name "ns.core"})

(deftest test-reshape-render
  (testing "`reshape-render` adds ns & component info to props"
    (let [unchanged '((dom/div nil "text"))]
      (is (= (oc/reshape-render
               '((dom/div {}
                    "Nested `defcomponent` example"))
               component-info)
            '((dom/div {:omcss$this {:component-name "Foo"
                                      :ns-name "ns.core"}}
                 "Nested `defcomponent` example"))))
      (is (= (oc/reshape-render unchanged component-info) unchanged))))
  (testing "`reshape-render` adds namespace qualified classes (:class)"
    (is (= (oc/reshape-render
             '((dom/div {:class :bar} "bar"))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_bar"} "bar"))))
    (is (= (oc/reshape-render
             '((dom/div {:class :bar} "bar"
                   (dom/p {:class :baz} "baz")))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_bar"} "bar"
              (dom/p {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_baz"} "baz"))))))
  (testing "`reshape-render` preserves `:className` classnames"
    (is (= (oc/reshape-render
             '((dom/div {:className "bar"} "bar"))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :className "bar"} "bar")))))
  (testing "`reshape-render` preserves `:class`'s data structure"
    (is (= (oc/reshape-render
             '((dom/div {:class [:root]}))
              component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class ["ns_core_Foo_root"]}))))))

(comment
  (reshape-defui
    '(om/IQuery
        (query [this])
      om/Ident
      (ident [this])
      Object
      (componentWillMount [this])
      (render [dia]
        (dom/div nil (dom/div nil "3")))
      static field a 3
      static om/IQuery
      (query [this] [:a])))

  (get-component-style
    '(static om/IQuery
      (query [this])
      static oc/Style
      (style [_]
        [:root {:color "#FFFFF"}
         :section (merge {} ;;css/default-section
                    {:background-color :green})])
     static om/Ident
     (ident [this])
     Object
     (render [this])
     static om/IQueryParams
     (params [this])))

  (get-style-form
    '(Object
      (render [this])
      static om/Ident
      (ident [this])))

  (reshape-style-form
    '(style [_]
       [:root {:color "#FFFFF"}
        :section (merge {} {:background-color :green})]))

  )

(ns om-css.tests
  (:require [clojure.test :refer [deftest testing is are]]
            [om-css.core :as oc]))

(def component-info
  {:component-name "Foo"
   :ns-name "ns.core"})

(deftest test-reshape-render
  (testing "`reshape-render` adds ns & component info to props"
    (let [unchanged '((dom/div nil "text"))]
      (is (= (oc/reshape-render
               '((dom/div {}
                    "Nested `defcomponent` example"))
               component-info)
            '((dom/div {:omcss$this {:component-name "Foo"
                                      :ns-name "ns.core"}}
                 "Nested `defcomponent` example"))))
      (is (= (oc/reshape-render unchanged component-info) unchanged))))
  (testing "`reshape-render` adds namespace qualified classes (:class)"
    (is (= (oc/reshape-render
             '((dom/div {:class :bar} "bar"))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_bar"} "bar"))))
    (is (= (oc/reshape-render
             '((dom/div {:class :bar} "bar"
                   (dom/p {:class :baz} "baz")))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_bar"} "bar"
              (dom/p {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class "ns_core_Foo_baz"} "baz"))))))
  (testing "`reshape-render` preserves `:className` classnames"
    (is (= (oc/reshape-render
             '((dom/div {:className "bar"} "bar"))
             component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :className "bar"} "bar")))))
  (testing "`reshape-render` preserves `:class`'s data structure"
    (is (= (oc/reshape-render
             '((dom/div {:class [:root]}))
              component-info)
          '((dom/div {:omcss$this {:component-name "Foo"
                                   :ns-name "ns.core"}
                      :class ["ns_core_Foo_root"]}))))))

(deftest test-get-style
  (let [form '(static om/IQuery
               (query [this])
               static oc/Style
               (style [_]
                 [:root {:color "#FFFFF"}
                  :section {:background-color :green}])
               static om/Ident
               (ident [this])
               Object
               (render [this])
               static om/IQueryParams
               (params [this]))]
    (is (= (oc/get-style-form form)
          '(style [_]
            [:root {:color "#FFFFF"}
             :section {:background-color :green}])))
    (is (nil? (oc/get-style-form
                '(Object
                   (render [this])
                   static om/Ident
                   (ident [this])))))
    (is (= (oc/get-component-style form)
          [:root {:color "#FFFFF"}
           :section {:background-color :green}]))))

(deftest test-reshape-defui
  (let [form '(om/IQuery
                (query [this])
                om/Ident
                (ident [this])
                Object
                (componentWillMount [this])
                (render [dia]
                  (dom/div {:class :foo} (dom/div nil "3")))
                static field a 3
                static om/IQuery
                (query [this] [:a]))
        expected '[om/IQuery
                   (query [this])
                   om/Ident
                   (ident [this])
                   Object
                   (componentWillMount [this])
                   (render [dia]
                     (dom/div
                       {:class "ns_core_Foo_foo"
                        :omcss$this {:component-name "Foo"
                                     :ns-name "ns.core"}}
                       (dom/div nil "3")))
                   static field a 3
                   static om/IQuery
                   (query [this] [:a])]]
    (is (= (oc/reshape-defui form component-info)
          expected))
    (is (= (oc/reshape-defui
             '(Object (render [this] (dom/div nil "foo")))
             component-info)
          '[Object (render [this] (dom/div nil "foo"))]))))

add more tests

add more tests


(ns riemann.influxdb-9
  "Functions to write events as points to an InfluxDB 0.9 series cluster."
  (:require
    [cheshire.core :as json]
    [clj-http.client :as http]
    [clojure.set :as set]
    [riemann.common :refer [unix-to-iso8601]]))

(defn write-endpoint
  "Generates a URL for the write endpoint based on an InfluxDB opts map."
  [opts]
  (str (if (:tls opts) "https" "http")
       "://" (:host opts)
       \: (:port opts)
       "/write"))

(defn event-tags
  "Generates a map of InfluxDB tags from a Riemann event. Any entries in the
  event which are named in `tag-keys` will be converted to a string key/value
  entry in the tag map. The event's `host` is always included."
  [tag-keys event]
  (->> (conj tag-keys :host)
       (select-keys event)
       (map #(vector (name (key %)) (str (val %))))
       (into {})))

(defn event-fields
  "Generates a map of InfluxDB fields from a Riemann event. The event's
  `metric` is converted to the `value` field, and any additional event entries
  which are not standard Riemann fields or in `tag-keys` will also be present."
  [tag-keys event]
  (let [standard-keys #{:host :service :time :metric :description :tags :ttl}
        ignored-keys (set/union standard-keys tag-keys)]
    (-> event
        (->> (remove (comp ignored-keys key))
             (map #(vector (name (key %)) (val %)))
             (into {}))
        (assoc "value" (:metric event)))))

(defn event->point
  "Converts a Riemann event into an InfluxDB point if it has a time, service,
  and metric."
  [tag-keys event]
  (when (and (:time event) (:service event) (:metric event))
    {"name" (:service event)
     "timestamp" (unix-to-iso8601 (:time event))
     "tags" (event-tags tag-keys event)
     "fields" (event-fields tag-keys event)}))

(defn events->points
  "Converts a collection of Riemann events into InfluxDB points. Events which
  map to nil are removed from the final collection."
  [tag-keys events]
  (vec (remove nil? (map (partial event->point tag-keys) events))))

(defn influxdb
  "Returns a function which accepts an event, or sequence of events, and writes
  them to InfluxDB as a batch of measurement points.

  (batch 500 1
    (influxdb {:host \"influxdb.example.com\"
               :port 8086
               :database \"my_db\"}))

  Options:

  `:host`           Hostname to write points to.

  `:port`           API port number.

  `:tls`            Whether to write using HTTPS. (optional)

  `:database`       Name of database to write to.

  `:retention`      Name of retention policy to use. (optional)

  `:username`       Database user to authenticate as.

  `:password`       Password to authenticate with.

  `:tags`           A common map of tags to apply to all events. (optional)

  `:tag-keys`       A set of event fields to map into InfluxDB series tags.
                    (optional)"
  [opts]
  (let [write-url (write-endpoint opts)
        tag-keys (:tag-keys opts #{})
        payload-base (cond-> {"database" (:database opts)}
                       (:retention opts)
                         (assoc "retentionPolicy" (:retention opts))
                       (seq (:tags opts))
                         (assoc "tags" (:tags opts)))
        http-opts {:socket-timeout 5000 ; ms
                   :conn-timeout   5000 ; ms
                   :content-type   :json
                   :basic-auth [(:username opts)
                                (:password opts)]}]
    (fn stream
      [events]
      (let [events (if (sequential? events) events (list events))
            points (events->points tag-keys events)]
        (when-not (empty? points)
          (->> points
               (assoc payload-base "points")
               (json/generate-string)
               (assoc http-opts :body)
               (http/post write-url)))))))

(ns riemann.influxdb-9
  "Functions to write events as points to an InfluxDB 0.9 series cluster."
  (:require
    [cheshire.core :as json]
    [clj-http.client :as http]
    [clojure.set :as set]
    [riemann.common :refer [unix-to-iso8601]]))

(defn write-endpoint
  "Generates a URL for the write endpoint based on an InfluxDB opts map."
  [opts]
  (str (if (:tls opts) "https" "http")
       "://" (:host opts)
       \: (:port opts 8086)
       "/write"))

(defn event-tags
  "Generates a map of InfluxDB tags from a Riemann event. Any entries in the
  event which are named in `tag-keys` will be converted to a string key/value
  entry in the tag map. The event's `host` is always included."
  [tag-keys event]
  (->> (conj tag-keys :host)
       (select-keys event)
       (map #(vector (name (key %)) (str (val %))))
       (into {})))

(defn event-fields
  "Generates a map of InfluxDB fields from a Riemann event. The event's
  `metric` is converted to the `value` field, and any additional event entries
  which are not standard Riemann fields or in `tag-keys` will also be present."
  [tag-keys event]
  (let [standard-keys #{:host :service :time :metric :description :tags :ttl}
        ignored-keys (set/union standard-keys tag-keys)]
    (-> event
        (->> (remove (comp ignored-keys key))
             (map #(vector (name (key %)) (val %)))
             (into {}))
        (assoc "value" (:metric event)))))

(defn event->point
  "Converts a Riemann event into an InfluxDB point if it has a time, service,
  and metric."
  [tag-keys event]
  (when (and (:time event) (:service event) (:metric event))
    {"name" (:service event)
     "timestamp" (unix-to-iso8601 (:time event))
     "tags" (event-tags tag-keys event)
     "fields" (event-fields tag-keys event)}))

(defn events->points
  "Converts a collection of Riemann events into InfluxDB points. Events which
  map to nil are removed from the final collection."
  [tag-keys events]
  (vec (remove nil? (map (partial event->point tag-keys) events))))

(defn influxdb
  "Returns a function which accepts an event, or sequence of events, and writes
  them to InfluxDB as a batch of measurement points.

  (batch 500 1
    (influxdb {:host \"influxdb.example.com\"
               :database \"my_db\"
               :user \"riemann\"
               :password \"secret\"}))

  Options:

  `:host`           Hostname to write points to.

  `:port`           API port number. (optional)

  `:tls`            Whether to write using HTTPS. (optional)

  `:database`       Name of database to write to.

  `:retention`      Name of retention policy to use. (optional)

  `:username`       Database user to authenticate as.

  `:password`       Password to authenticate with.

  `:tags`           A common map of tags to apply to all events. (optional)

  `:tag-keys`       A set of event fields to map into InfluxDB series tags.
                    (optional)"
  [opts]
  (let [write-url (write-endpoint opts)
        tag-keys (:tag-keys opts #{})
        payload-base (cond-> {"database" (:database opts)}
                       (:retention opts)
                         (assoc "retentionPolicy" (:retention opts))
                       (seq (:tags opts))
                         (assoc "tags" (:tags opts)))
        http-opts {:socket-timeout 5000 ; ms
                   :conn-timeout   5000 ; ms
                   :content-type   :json
                   :basic-auth [(:username opts)
                                (:password opts)]}]
    (fn stream
      [events]
      (let [events (if (sequential? events) events (list events))
            points (events->points tag-keys events)]
        (when-not (empty? points)
          (->> points
               (assoc payload-base "points")
               (json/generate-string)
               (assoc http-opts :body)
               (http/post write-url)))))))

Make InfluxDB port default to 8086.

Make InfluxDB port default to 8086.


{:user {:plugins [[cider/cider-nrepl "0.9.1"]
                  [refactor-nrepl "1.1.0"]]
        :dependencies [[org.clojure/tools.nrepl "0.2.10"]]}}

{:user {:plugins [[cider/cider-nrepl "0.9.1"]
                  [refactor-nrepl "1.1.0"]
                  [lein-immutant "2.0.0"]]
        :dependencies [[org.clojure/tools.nrepl "0.2.10"]]}}

add lein-immutant

add lein-immutant


{:user {:plugins [[cider/cider-nrepl "0.8.1"]]}}

{:user {:plugins [[cider/cider-nrepl "0.9.0-SNAPSHOT"]]}}

update cider-nrepl

update cider-nrepl


; Copyright (c) 2015 Denys Lebediev and contributors. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file LICENSE at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns flatgui.test
  (:require [flatgui.comlogic :as fgc]
            [flatgui.util.matrix :as m]
            [flatgui.awt :as awt]
            [flatgui.base :as fg]
            [clojure.test :as test])
  (:import (flatgui.core.engine ClojureContainerParser IResultCollector Container)
           (java.awt.event MouseEvent KeyEvent)
           (flatgui.core.engine.ui FGMouseEventParser FGTestAppContainer FGTestMouseEventParser)))

(def dummy-source (java.awt.Container.))

(def wait-attempts 5)

(def wait-interval-millis 1000)

(defn enable-traces-for-failed-tests []
  (defmethod clojure.test/report :fail [m]
    (clojure.test/with-test-out
      (clojure.test/inc-report-counter :fail)
      (println "\nFAIL in" (clojure.test/testing-vars-str m))
      (when (seq clojure.test/*testing-contexts*) (println (clojure.test/testing-contexts-str)))
      (when-let [message (:message m)] (println message))
      (println "expected:" (pr-str (:expected m)))
      (println "  actual:" (pr-str (:actual m)))
      (let [trace (.getStackTrace (Thread/currentThread))]
        (loop [i 0]
          (if (< i (alength trace))
            (do
              (println (.toString (aget trace i)))
              (recur (inc i)))))))))

(defn evolve
  ([container property reason target]
   (let [results (atom {})
         result-collector (reify IResultCollector
                            (appendResult [_this _parentComponentUid, _path, node, newValue]
                              (swap! results (fn [r] (if (= property (.getPropertyId node))
                                                       newValue
                                                       r))))
                            (componentAdded [_this _parentComponentUid _componentUid])
                            (componentRemoved [_this _componentUid])
                            (postProcessAfterEvolveCycle [_this _a _m]))
         container-engine (Container.
                            "flatgui.test"
                            (ClojureContainerParser.)
                            result-collector
                            container)
         _ (.evolve container-engine target reason)]
     @results))
  ([container property reason] (evolve container property reason [:main])))

(defn event-> [container target event] (.evolve container target event))

(defn create-container-from-file [c-path c-ns c-name]
  (FGTestAppContainer/loadSourceCreateAndInit c-path c-ns c-name))

(defn create-container [c-var]
  (if (coll? c-var)
    (let [c (FGTestAppContainer/createAndInit (first c-var))]
      ((second c-var) c)
      c)
    (FGTestAppContainer/createAndInit c-var)))

(defn init-container [c]
  (FGTestAppContainer/init c))

(defn get-property [container target property] (.getProperty container target property))

(defn wait-for-property-pred [container target property pred]
  (let [actual-value (loop [a 0
                            interval 5
                            v (.getProperty container target property)]
                       (if (and (not (pred v)) (< a wait-attempts))
                         (do
                           (fg/log-debug (str "Waiting " interval " millis, attempt " (inc a) " of " wait-attempts))
                           (Thread/sleep interval)
                           (recur
                             (inc a)
                             wait-interval-millis
                             (.getProperty container target property)))
                         v))]
    (test/is (pred actual-value) (str "Failed for actual value was " (if (coll? actual-value) (str "[coll count=" (count actual-value) "] ") "") actual-value))))

(defn wait-for-property [container target property expected-value]
  (wait-for-property-pred container target property (fn [v] (= expected-value v))))

;;
;; Combining test into scenarios
;;

(def standard-interstep-delay-millis 100)

(defn- gen-wait [clause] (list 'Thread/sleep (list '* clause standard-interstep-delay-millis)))

(defn- ensure-size [s size] (map #(if (< % (count s)) (nth s %)) (range size)))

(defn interleave-long [& colls]
  (let [max-size (count (apply max-key count colls))]
    (filter #(not (nil? %)) (apply interleave (map (fn [c] (ensure-size c max-size)) colls)))))

(declare clause-processor)

(defn clause-processor [clause]
  (cond

    (number? clause)
    (gen-wait clause)

    (and (seq? clause) (= 'inter (first clause)))
    (map clause-processor (apply interleave-long (rest clause)))

    :else clause))

(defmacro defscenario [scenario-name container-var-coll & clauses]
  (let [scenario (map clause-processor clauses)]
    (list 'clojure.test/deftest scenario-name
          (concat (list 'let ['containers (list 'mapv (list 'fn ['cv] (list 'flatgui.test/create-container 'cv)) container-var-coll)
                              'container (list 'nth 'containers 0)]) scenario))))

;;
;; Mouse
;;

(defn mouse-event
  ([id modifiers click-count button]
   (FGMouseEventParser/deriveFGEvent
     (MouseEvent. dummy-source id 0 modifiers 0 0 0 0 click-count false button)
     0 0))
  ([id modifiers click-count button x y]
   (let [xint (FGTestMouseEventParser/doubleToInt x)
         yint (FGTestMouseEventParser/doubleToInt y)]
     (MouseEvent. dummy-source id 0 modifiers xint yint xint yint click-count false button))))

(defn mouse-left
  ([id] (mouse-event id MouseEvent/BUTTON1_DOWN_MASK 1 MouseEvent/BUTTON1))
  ([id x y] (mouse-event id MouseEvent/BUTTON1_DOWN_MASK 1 MouseEvent/BUTTON1 x y)))

(def left-click-events
  [;TODO (move-mouse-to container target)
   (mouse-left MouseEvent/MOUSE_PRESSED)
   (mouse-left MouseEvent/MOUSE_RELEASED)
   (mouse-left MouseEvent/MOUSE_CLICKED)])

(defn create-left-click-events [x y]
  [;TODO (move-mouse-to container target)
   (mouse-left MouseEvent/MOUSE_PRESSED x y)
   (mouse-left MouseEvent/MOUSE_RELEASED x y)
   (mouse-left MouseEvent/MOUSE_CLICKED x y)])

(defn left-click
  ([container target] (.evolve container target left-click-events))
  ([container x y] (.evolve container (create-left-click-events x y))))

;;
;; Keyboard
;;

(defn key-event [id key-code char-code]
  (KeyEvent. dummy-source id 0 0 (if (= id KeyEvent/KEY_TYPED) KeyEvent/VK_UNDEFINED key-code) (char char-code)))

(defn create-key-type-events
  ([key-code char-code]
   [(key-event KeyEvent/KEY_PRESSED key-code char-code)
    (key-event KeyEvent/KEY_TYPED key-code char-code)
    (key-event KeyEvent/KEY_RELEASED key-code char-code)])
  ([key-code char-code cnt]
    (loop [i 0
           e []]
      (if (< i cnt)
        (recur
          (inc i)
          (vec (concat e (create-key-type-events key-code char-code))))
        e))))

(defn create-string-type-events [str]
  (let [len (.length str)]
    (loop [i 0
           events nil]
      (if (< i len)
        (recur
          (inc i)
          (concat events (create-key-type-events (int (.charAt str i)) (.charAt str i))))
        events))))

(defn type-string
  ([container target str] (.evolve container target (create-string-type-events str)))
  ([container str] (.evolve container (create-string-type-events str))))

(defn type-key
  ([container target key-code char-code cnt] (.evolve container target (create-key-type-events key-code char-code cnt)))
  ([container key-code char-code cnt] (.evolve container (create-key-type-events key-code char-code cnt))))

;;;
;;; Utilities for working with components
;;;

;;
;; Table (flatgui.widgets.table2.table)
;;

(defn wait-table-cell-id [container table-path coord]
  (wait-for-property-pred container table-path :in-use-model
                          (fn [v] (let [sc->id (:screen-coord->cell-id v)]
                                    (get sc->id coord)))))

(defn wait-table-model-coords-shown [container table-path coords]
  (wait-for-property-pred container table-path :in-use-model
                              (fn [v] (let [sc->id (:screen-coord->cell-id v)]
                                        (= (set coords) (set (map (fn [[k _cid]] k) sc->id)))))))

(defn wait-table-cell-property [container table-path coord property pred]
  (let [cid (wait-table-cell-id container table-path coord)]
    (wait-for-property-pred container (conj table-path cid) property pred)))

; Copyright (c) 2015 Denys Lebediev and contributors. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file LICENSE at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns flatgui.test
  (:require [flatgui.comlogic :as fgc]
            [flatgui.util.matrix :as m]
            [flatgui.awt :as awt]
            [flatgui.base :as fg]
            [clojure.test :as test])
  (:import (flatgui.core.engine ClojureContainerParser IResultCollector Container)
           (java.awt.event MouseEvent KeyEvent)
           (flatgui.core.engine.ui FGMouseEventParser FGTestAppContainer FGTestMouseEventParser)))

(def dummy-source (java.awt.Container.))

(def wait-attempts 5)

(def wait-interval-millis 1000)

(defn enable-traces-for-failed-tests []
  (defmethod clojure.test/report :fail [m]
    (clojure.test/with-test-out
      (clojure.test/inc-report-counter :fail)
      (println "\nFAIL in" (clojure.test/testing-vars-str m))
      (when (seq clojure.test/*testing-contexts*) (println (clojure.test/testing-contexts-str)))
      (when-let [message (:message m)] (println message))
      (println "expected:" (pr-str (:expected m)))
      (println "  actual:" (pr-str (:actual m)))
      (let [trace (.getStackTrace (Thread/currentThread))]
        (loop [i 0]
          (if (< i (alength trace))
            (do
              (println (.toString (aget trace i)))
              (recur (inc i)))))))))

(defn evolve
  ([container property reason target]
   (let [results (atom {})
         result-collector (reify IResultCollector
                            (appendResult [_this _parentComponentUid, _path, node, newValue]
                              (swap! results (fn [r] (if (= property (.getPropertyId node))
                                                       newValue
                                                       r))))
                            (componentAdded [_this _parentComponentUid _componentUid])
                            (componentRemoved [_this _componentUid])
                            (postProcessAfterEvolveCycle [_this _a _m]))
         container-engine (Container.
                            "flatgui.test"
                            (ClojureContainerParser.)
                            result-collector
                            container)
         _ (.evolve container-engine target reason)]
     @results))
  ([container property reason] (evolve container property reason [:main])))

(defn path [& elements] (vec (apply mapcat #(if (coll? %) % [%]) elements)))

(defn event-> [container target event] (.evolve container (path target) event))

(defn create-container-from-file [c-path c-ns c-name]
  (FGTestAppContainer/loadSourceCreateAndInit c-path c-ns c-name))

(defn create-container [c-var]
  (if (coll? c-var)
    (let [c (FGTestAppContainer/createAndInit (first c-var))]
      ((second c-var) c)
      c)
    (FGTestAppContainer/createAndInit c-var)))

(defn init-container [c]
  (FGTestAppContainer/init c))

(defn get-property [container target property] (.getProperty container (path target) property))

(defn wait-for-property-pred [container target property pred]
  (let [actual-value (loop [a 0
                            interval 5
                            v (.getProperty container (path target) property)]
                       (if (and (not (pred v)) (< a wait-attempts))
                         (do
                           (fg/log-debug (str "Waiting " interval " millis, attempt " (inc a) " of " wait-attempts))
                           (Thread/sleep interval)
                           (recur
                             (inc a)
                             wait-interval-millis
                             (.getProperty container (path target) property)))
                         v))]
    (test/is (pred actual-value) (str "Failed for actual value was " (if (coll? actual-value) (str "[coll count=" (count actual-value) "] ") "") actual-value))))

(defn wait-for-property [container target property expected-value]
  (wait-for-property-pred container target property (fn [v] (= expected-value v))))

;;
;; Combining test into scenarios
;;

(def standard-interstep-delay-millis 1000)

(defn- gen-wait [clause] (list 'Thread/sleep (list '* clause standard-interstep-delay-millis)))

(defn- ensure-size [s size] (map #(if (< % (count s)) (nth s %)) (range size)))

(defn interleave-long [& colls]
  (let [max-size (count (apply max-key count colls))]
    (filter #(not (nil? %)) (apply interleave (map (fn [c] (ensure-size c max-size)) colls)))))

(declare clause-processor)

(defn clause-processor [clause]
  (cond

    (number? clause)
    (gen-wait clause)

    (and (seq? clause) (= 'inter (first clause)))
    (map clause-processor (apply interleave-long (rest clause)))

    :else clause))

(defmacro defscenario [scenario-name container-var-coll & clauses]
  (let [scenario (map clause-processor clauses)]
    (list 'clojure.test/deftest scenario-name
          (concat (list 'let ['containers (list 'mapv (list 'fn ['cv] (list 'flatgui.test/create-container 'cv)) container-var-coll)
                              'cc (list 'count 'containers)
                              'container (list 'nth 'containers 0)
                              'container-0 (list 'nth 'containers 0)
                              'container-1 (list 'if (list '< 1 'cc) (list 'nth 'containers 1))
                              'container-2 (list 'if (list '< 2 'cc) (list 'nth 'containers 2))
                              'container-3 (list 'if (list '< 3 'cc) (list 'nth 'containers 3))
                              'container-4 (list 'if (list '< 4 'cc) (list 'nth 'containers 4))]) scenario))))

;;
;; Mouse
;;

(defn mouse-event
  ([id modifiers click-count button]
   (FGMouseEventParser/deriveFGEvent
     (MouseEvent. dummy-source id 0 modifiers 0 0 0 0 click-count false button)
     0 0))
  ([id modifiers click-count button x y]
   (let [xint (FGTestMouseEventParser/doubleToInt x)
         yint (FGTestMouseEventParser/doubleToInt y)]
     (MouseEvent. dummy-source id 0 modifiers xint yint xint yint click-count false button))))

(defn mouse-left
  ([id] (mouse-event id MouseEvent/BUTTON1_DOWN_MASK 1 MouseEvent/BUTTON1))
  ([id x y] (mouse-event id MouseEvent/BUTTON1_DOWN_MASK 1 MouseEvent/BUTTON1 x y)))

(def left-click-events
  [;TODO (move-mouse-to container target)
   (mouse-left MouseEvent/MOUSE_PRESSED)
   (mouse-left MouseEvent/MOUSE_RELEASED)
   (mouse-left MouseEvent/MOUSE_CLICKED)])

(defn create-left-click-events [x y]
  [;TODO (move-mouse-to container target)
   (mouse-left MouseEvent/MOUSE_PRESSED x y)
   (mouse-left MouseEvent/MOUSE_RELEASED x y)
   (mouse-left MouseEvent/MOUSE_CLICKED x y)])

(defn left-click
  ([container target] (.evolve container (path target) left-click-events))
  ([container x y] (.evolve container (create-left-click-events x y))))

;;
;; Keyboard
;;

(defn key-event [id key-code char-code]
  (KeyEvent. dummy-source id 0 0 (if (= id KeyEvent/KEY_TYPED) KeyEvent/VK_UNDEFINED key-code) (char char-code)))

(defn create-key-type-events
  ([key-code char-code]
   [(key-event KeyEvent/KEY_PRESSED key-code char-code)
    (key-event KeyEvent/KEY_TYPED key-code char-code)
    (key-event KeyEvent/KEY_RELEASED key-code char-code)])
  ([key-code char-code cnt]
    (loop [i 0
           e []]
      (if (< i cnt)
        (recur
          (inc i)
          (vec (concat e (create-key-type-events key-code char-code))))
        e))))

(defn create-string-type-events [str]
  (let [len (.length str)]
    (loop [i 0
           events nil]
      (if (< i len)
        (recur
          (inc i)
          (concat events (create-key-type-events (int (.charAt str i)) (.charAt str i))))
        events))))

(defn type-string
  ([container target str] (.evolve container (path target) (create-string-type-events str)))
  ([container str] (.evolve container (create-string-type-events str))))

(defn type-key
  ([container target key-code char-code cnt] (.evolve container target (create-key-type-events key-code char-code cnt)))
  ([container key-code char-code cnt] (.evolve container (create-key-type-events key-code char-code cnt))))

;;;
;;; Utilities for working with components
;;;

;;
;; Table (flatgui.widgets.table2.table)
;;

(defn wait-table-cell-id [container table-path coord]
  (wait-for-property-pred container (path table-path) :in-use-model
                          (fn [v] (let [sc->id (:screen-coord->cell-id v)]
                                    (get sc->id coord)))))

(defn wait-table-model-coords-shown [container table-path coords]
  (wait-for-property-pred container (path table-path) :in-use-model
                              (fn [v] (let [sc->id (:screen-coord->cell-id v)]
                                        (= (set coords) (set (map (fn [[k _cid]] k) sc->id)))))))

(defn wait-table-cell-property
  ([container table-path cell-subpath coord property pred]
   (let [cid (wait-table-cell-id container table-path coord)]
     (wait-for-property-pred container (path (vec (concat (conj table-path cid) cell-subpath))) property pred)))
  ([container table-path coord property pred] (wait-table-cell-property container table-path [] coord property pred)))

test suite

test suite


(ns nml.core
  (:require [clojure.string    :as string])
  (:require [instaparse.core   :as insta ])
  (:require [clojure.tools.cli :as cli   ])
  (:gen-class))

(declare nml-get nml-parse nml-set strmap valstr)

;; formatting

(defn- fmt-sh [m lo]
  (let [ms  (sort m)
        n   (lo 1)
        k   (lo 2)
        eq #(string/replace % "\"" "\\\"")
        f0  (fn [[dataref values]]
              (let [v (eq values)]
                (str "'" dataref "') echo \"" v "\";;")))
        f1  (fn [[name nv_sequence]]
              (let [x (strmap f0 nv_sequence)]
                (str "'" name "') case " k " in " x "*) echo '';;esac;;" )))]
    (str "nmlquery(){ case " n " in " (strmap f1 ms) "*) echo '';;esac; }\n")))

(defn- fmt-bash [m]
  (fmt-sh m #(str "\"${" % ",,}\"")))

(defn- fmt-ksh [m]
  (fmt-sh m #(str "\"$(echo $" % " | tr [:upper:] [:lower:])\"")))

(defn- fmt-namelist [m]
  (let [f0 (fn [[dataref values]] (str "  " dataref "=" (valstr values) "\n"))
        f1 (fn [[name nv_sequence]] (str "&" name "\n" (strmap f0 (sort nv_sequence)) "/\n"))]
    (strmap f1 (sort m))))

;; defs

(def formats
  {"bash"     fmt-bash
   "ksh"      fmt-ksh
   "namelist" fmt-namelist})

(def msgs
  {:bad-format    "Bad output format"
   :edit+in       "-i/--in not valid with -e/--edit"
   :edit+out      "-o/--out not valid with -e/--edit"
   :get+edit      "-e/--edit not valid with -g/--get"
   :get+format    "-f/--format not valid with -g/--get"
   :get+set       "-g/--get and -s/--set may not be mixed"
   :multi-edit    "-e/--edit may be specified only once"
   :multi-format  "-f/--format may be specified only once"
   :multi-in      "-i/--in may be specified only once"
   :multi-out     "-o/--out may be specified only once"
   :set+no-prefix "-n/--no-prefix not valid with -s/--set"})

(def parse (insta/parser (clojure.java.io/resource "grammar")))

(def version "0.3")

;; utility defns

(defn- fail [& lines]
  (binding [*out* *err*]
    (doseq [line lines]
      (println (str "nml: " line)))
    (System/exit 1)))

(defn- read-file [in]
  (try (slurp in)
       (catch Exception e
         (fail (str "Could not read from '" in "'")))))

(defn- strmap [f coll]
  (apply str (map f coll)))

(defn- usage [summary]
  (let [f (str "Valid output formats are: " (string/join ", " (keys formats)))]
    (doseq [x ["\nUsage: nml [options]\n\nOptions:\n" summary "" f ""]]
      (println x))
    (System/exit 0)))

(defn- valstr [values]
  (string/join "," values))

;; nml private defns

(defn- nml-gets [m gets no-prefix]
  (let [f (fn [[nml key]]
            (let [val (nml-get m nml key)]
              (if (= "" val) (fail (str nml ":" key " not found")))
              (if no-prefix val (str nml ":" key "=" val))))]
    (str (string/join "\n" (map f gets)) "\n")))

(defn- nml-out [out s]
  (if (= out *out*)
    (println (string/trim s))
    (try (spit out s)
         (catch Exception e
           (fail (str "Could not write to '" out "'"))))))

(defn- nml-parse [text start-symbol provenance]
  (let [result (parse text :start start-symbol)]
    (let [parses (insta/parses parse text :start start-symbol :unhide :all)]
      (binding [*out* *err*]
        (doseq [parse parses] (println (str "----\n" parse)))
        (println (str "### " (count parses)))))
    (if (insta/failure? result)
      (let [{t :text l :line c :column} result]
        (fail (str "Error parsing " provenance " at line " l " column " c ":")
              t
              (str (apply str (repeat (- c 1) " ")) "^")))
      result)))

(defn- nml-sets [m sets]
  (loop [m m s sets]
    (if (empty? s)
      m
      (let [[nml key val] (first s)]
        (if (nil? val) (fail (str "No value supplied for key '" key "'")))
        (recur (nml-set m nml key val) (rest s))))))

;; nml public defns

(defn nml-get [m nml key]
  (valstr (get (get m (string/lower-case nml) {}) (string/lower-case key) "")))

(defn nml-map [text start-symbol provenance]
  (let [tree (nml-parse text start-symbol provenance)
        blank (fn [& _] "")
        string_id (fn [& components] (apply str components))
        string_lc (fn [& components] (string/lower-case (apply string_id components)))]
    (let [new (insta/transform
               {
                :blank blank
                :c identity
                :comma identity
                :complex string_id
                :dataref string_id
                :dec (fn [point & int] (str point (apply str int)))
                :exp string_lc
                :false string_lc
                :int string_id
                :logical identity
                :minus identity
                :name string_lc
                :nv_sequence (fn [& nv_subsequences] (into {} nv_subsequences))
                :nv_subsequence (fn [name values] {name values})
                :nv_subsequence_start identity
                :partref identity
                :plus identity
                :r identity
                :real string_id
                :s (fn [& nv_sequences] (into {} nv_sequences))
                :sign identity
                :stmt (fn [name nv_sequence _] (into {} {name nv_sequence}))
                :true string_lc
                :uint identity
                :star identity
                :string string_id
                :value string_id
                :values (fn [& values] (into [] values))
                } tree)]
      new)))

(defn nml-set [m nml key val]
;; (let [parses (insta/parses parse val :start :values :unhide :all)]
;;   (binding [*out* *err*]
;;     (doseq [parse parses] (println (str "----\n" parse)))
;;     (println (str "### " (count parses)))))
  (let [val (nml-map val :values "user-supplied value")]
    (assoc-in m [(string/lower-case nml) (string/lower-case key)] val)))

;; cli

(defn- assoc-e [m k v]
  (if (k m) (fail (msgs :multi-edit)))
  (assoc m k v))

(defn- assoc-f [m k v]
  (if (k m) (fail (msgs :multi-format)))
  (assoc m k v))

(defn- assoc-g [m k v]
  (let [gets (:get m [])]
    (assoc m :get (into gets [v]))))

(defn- assoc-i [m k v]
  (if (k m) (fail (msgs :multi-in)))
  (assoc m k v))

(defn- assoc-o [m k v]
  (if (k m) (fail (msgs :multi-out)))
  (assoc m k v))

(defn- assoc-s [m k v]
  (let [sets (:set m [])]
    (assoc m :set (into sets [v]))))

(defn- parse-f [x]
  (if-not (contains? formats x) (fail (msgs :bad-format)))
  x)

(defn- parse-g [x]
  (string/split x #":" 2))

(defn- parse-s [x]
  (let [[nml+key val] (string/split x #"=" 2)
        [nml key] (parse-g nml+key)]
    [nml key val]))

(def cliopts
  [["-c" "--create"     "Create new namelist"                                                              ]
   ["-e" "--edit file"  "Edit file (instead of '-i file -o file')"     :assoc-fn assoc-e                   ]
   ["-f" "--format fmt" "Output in format 'fmt' (default: namelist)"   :assoc-fn assoc-f :parse-fn parse-f ]
   ["-g" "--get n:k"    "Get value of key 'k' in namelist 'n'"         :assoc-fn assoc-g :parse-fn parse-g ]
   ["-h" "--help"       "Show usage information"                                                           ]
   ["-i" "--in file"    "Input file (default: stdin)"                  :assoc-fn assoc-i                   ]
   ["-n" "--no-prefix"  "Report values without 'namelist:key=' prefix"                                     ]
   ["-o" "--out file"   "Output file (default: stdout)"                :assoc-fn assoc-o                   ]
   ["-s" "--set n:k=v"  "Set value of key 'k' in namelist 'n' to 'v'"  :assoc-fn assoc-s :parse-fn parse-s ]
   ["-v" "--version"    "Show version information"                                                         ]])

;; main

(defn -main [& args]

  (alter-var-root #'*read-eval* (constantly false))

  ;; bindings

  (let [{:keys [options arguments summary]} (cli/parse-opts args cliopts)
        gets       (:get options)
        sets       (:set options)
        edit       (:edit options)
        in         (or edit (:in options) *in*)
        out        (or edit (:out options) *out*)
        provenance (or edit (:in options) "stdin")]

    ;; error checking

    (if (not-empty arguments) (fail (str "Unexpected argument '" (first arguments) "'")))
    (if (:help options) (usage summary))
    (if (:version options) (do (println version) (System/exit 0)))
    (if (and gets sets) (fail (msgs :get+set)))
    (if (and gets edit) (fail (msgs :get+edit)))
    (if (and edit (:in options)) (fail (msgs :edit+in)))
    (if (and edit (:out options)) (fail (msgs :edit+out)))
    (if (and gets (:format options)) (fail (msgs :get+format)))
    (if (and sets (:no-prefix options)) (fail (msgs :set+no-prefix)))
    (if (and (:create options) (:in options)) (fail (msgs :create+in)))

    ;; read -> parse -> lookup or modify -> output

    (let [fmt (let [f (:format options)] (if f (formats f) fmt-namelist))
          m   (nml-map (if (:create options) "" (read-file in)) :s provenance)]
      (cond gets  (nml-out out (nml-gets m gets (:no-prefix options)))
            sets  (nml-out out (fmt (nml-sets m sets)))
            :else (nml-out out (fmt m))))))

(ns nml.core
  (:require [clojure.string    :as string])
  (:require [instaparse.core   :as insta ])
  (:require [clojure.tools.cli :as cli   ])
  (:gen-class))

(declare nml-get nml-parse nml-set strmap valstr)

;; formatting

(defn- fmt-sh [m lo]
  (let [ms  (sort m)
        n   (lo 1)
        k   (lo 2)
        eq #(string/replace % "\"" "\\\"")
        f0  (fn [[dataref values]]
              (let [v (eq values)]
                (str "'" dataref "') echo \"" v "\";;")))
        f1  (fn [[name nv_sequence]]
              (let [x (strmap f0 nv_sequence)]
                (str "'" name "') case " k " in " x "*) echo '';;esac;;" )))]
    (str "nmlquery(){ case " n " in " (strmap f1 ms) "*) echo '';;esac; }\n")))

(defn- fmt-bash [m]
  (fmt-sh m #(str "\"${" % ",,}\"")))

(defn- fmt-ksh [m]
  (fmt-sh m #(str "\"$(echo $" % " | tr [:upper:] [:lower:])\"")))

(defn- fmt-namelist [m]
  (let [f0 (fn [[dataref values]] (str "  " dataref "=" (valstr values) "\n"))
        f1 (fn [[name nv_sequence]] (str "&" name "\n" (strmap f0 (sort nv_sequence)) "/\n"))]
    (strmap f1 (sort m))))

;; defs

(def formats
  {"bash"     fmt-bash
   "ksh"      fmt-ksh
   "namelist" fmt-namelist})

(def msgs
  {:bad-format    "Bad output format"
   :edit+in       "-i/--in not valid with -e/--edit"
   :edit+out      "-o/--out not valid with -e/--edit"
   :get+edit      "-e/--edit not valid with -g/--get"
   :get+format    "-f/--format not valid with -g/--get"
   :get+set       "-g/--get and -s/--set may not be mixed"
   :multi-edit    "-e/--edit may be specified only once"
   :multi-format  "-f/--format may be specified only once"
   :multi-in      "-i/--in may be specified only once"
   :multi-out     "-o/--out may be specified only once"
   :set+no-prefix "-n/--no-prefix not valid with -s/--set"})

(def parse (insta/parser (clojure.java.io/resource "grammar")))

(def version "0.3")

;; utility defns

(defn- fail [& lines]
  (binding [*out* *err*]
    (doseq [line lines]
      (println (str "nml: " line)))
    (System/exit 1)))

(defn- read-file [in]
  (try (slurp in)
       (catch Exception e
         (fail (str "Could not read from '" in "'")))))

(defn- strmap [f coll]
  (apply str (map f coll)))

(defn- usage [summary]
  (let [f (str "Valid output formats are: " (string/join ", " (keys formats)))]
    (doseq [x ["\nUsage: nml [options]\n\nOptions:\n" summary "" f ""]]
      (println x))
    (System/exit 0)))

(defn- valstr [values]
  (string/join "," values))

;; nml private defns

(defn- nml-gets [m gets no-prefix]
  (let [f (fn [[nml key]]
            (let [val (nml-get m nml key)]
              (if (= "" val) (fail (str nml ":" key " not found")))
              (if no-prefix val (str nml ":" key "=" val))))]
    (str (string/join "\n" (map f gets)) "\n")))

(defn- nml-out [out s]
  (if (= out *out*)
    (println (string/trim s))
    (try (spit out s)
         (catch Exception e
           (fail (str "Could not write to '" out "'"))))))

(defn- nml-parse [text start-symbol provenance]
  (let [result (parse text :start start-symbol)]
    (if (insta/failure? result)
      (let [{t :text l :line c :column} result]
        (fail (str "Error parsing " provenance " at line " l " column " c ":")
              t
              (str (apply str (repeat (- c 1) " ")) "^")))
      result)))

(defn- nml-sets [m sets]
  (loop [m m s sets]
    (if (empty? s)
      m
      (let [[nml key val] (first s)]
        (if (nil? val) (fail (str "No value supplied for key '" key "'")))
        (recur (nml-set m nml key val) (rest s))))))

;; nml public defns

(defn nml-get [m nml key]
  (valstr (get (get m (string/lower-case nml) {}) (string/lower-case key) "")))

(defn nml-map [text start-symbol provenance]
  (let [tree (nml-parse text start-symbol provenance)
        blank (fn [& _] "")
        string_id (fn [& components] (apply str components))
        string_lc (fn [& components] (string/lower-case (apply string_id components)))]
    (let [new (insta/transform
               {
                :blank blank
                :c identity
                :comma identity
                :complex string_id
                :dataref string_id
                :dec (fn [point & int] (str point (apply str int)))
                :exp string_lc
                :false string_lc
                :int string_id
                :logical identity
                :minus identity
                :name string_lc
                :nv_sequence (fn [& nv_subsequences] (into {} nv_subsequences))
                :nv_subsequence (fn [name values] {name values})
                :nv_subsequence_start identity
                :partref identity
                :plus identity
                :r identity
                :real string_id
                :s (fn [& nv_sequences] (into {} nv_sequences))
                :sign identity
                :stmt (fn [name nv_sequence _] (into {} {name nv_sequence}))
                :true string_lc
                :uint identity
                :star identity
                :string string_id
                :value string_id
                :values (fn [& values] (into [] values))
                } tree)]
      new)))

(defn nml-set [m nml key val]
  (let [val (nml-map val :values "user-supplied value")]
    (assoc-in m [(string/lower-case nml) (string/lower-case key)] val)))

;; cli

(defn- assoc-e [m k v]
  (if (k m) (fail (msgs :multi-edit)))
  (assoc m k v))

(defn- assoc-f [m k v]
  (if (k m) (fail (msgs :multi-format)))
  (assoc m k v))

(defn- assoc-g [m k v]
  (let [gets (:get m [])]
    (assoc m :get (into gets [v]))))

(defn- assoc-i [m k v]
  (if (k m) (fail (msgs :multi-in)))
  (assoc m k v))

(defn- assoc-o [m k v]
  (if (k m) (fail (msgs :multi-out)))
  (assoc m k v))

(defn- assoc-s [m k v]
  (let [sets (:set m [])]
    (assoc m :set (into sets [v]))))

(defn- parse-f [x]
  (if-not (contains? formats x) (fail (msgs :bad-format)))
  x)

(defn- parse-g [x]
  (string/split x #":" 2))

(defn- parse-s [x]
  (let [[nml+key val] (string/split x #"=" 2)
        [nml key] (parse-g nml+key)]
    [nml key val]))

(def cliopts
  [["-c" "--create"     "Create new namelist"                                                              ]
   ["-e" "--edit file"  "Edit file (instead of '-i file -o file')"     :assoc-fn assoc-e                   ]
   ["-f" "--format fmt" "Output in format 'fmt' (default: namelist)"   :assoc-fn assoc-f :parse-fn parse-f ]
   ["-g" "--get n:k"    "Get value of key 'k' in namelist 'n'"         :assoc-fn assoc-g :parse-fn parse-g ]
   ["-h" "--help"       "Show usage information"                                                           ]
   ["-i" "--in file"    "Input file (default: stdin)"                  :assoc-fn assoc-i                   ]
   ["-n" "--no-prefix"  "Report values without 'namelist:key=' prefix"                                     ]
   ["-o" "--out file"   "Output file (default: stdout)"                :assoc-fn assoc-o                   ]
   ["-s" "--set n:k=v"  "Set value of key 'k' in namelist 'n' to 'v'"  :assoc-fn assoc-s :parse-fn parse-s ]
   ["-v" "--version"    "Show version information"                                                         ]])

;; main

(defn -main [& args]

  (alter-var-root #'*read-eval* (constantly false))

  ;; bindings

  (let [{:keys [options arguments summary]} (cli/parse-opts args cliopts)
        gets       (:get options)
        sets       (:set options)
        edit       (:edit options)
        in         (or edit (:in options) *in*)
        out        (or edit (:out options) *out*)
        provenance (or edit (:in options) "stdin")]

    ;; error checking

    (if (not-empty arguments) (fail (str "Unexpected argument '" (first arguments) "'")))
    (if (:help options) (usage summary))
    (if (:version options) (do (println version) (System/exit 0)))
    (if (and gets sets) (fail (msgs :get+set)))
    (if (and gets edit) (fail (msgs :get+edit)))
    (if (and edit (:in options)) (fail (msgs :edit+in)))
    (if (and edit (:out options)) (fail (msgs :edit+out)))
    (if (and gets (:format options)) (fail (msgs :get+format)))
    (if (and sets (:no-prefix options)) (fail (msgs :set+no-prefix)))
    (if (and (:create options) (:in options)) (fail (msgs :create+in)))

    ;; read -> parse -> lookup or modify -> output

    (let [fmt (let [f (:format options)] (if f (formats f) fmt-namelist))
          m   (nml-map (if (:create options) "" (read-file in)) :s provenance)]
      (cond gets  (nml-out out (nml-gets m gets (:no-prefix options)))
            sets  (nml-out out (fmt (nml-sets m sets)))
            :else (nml-out out (fmt m))))))

Remove debugging code

Remove debugging code


(ns nube.app
  (:require [bidi.bidi :refer [match-route]]
            [taoensso.carmine :as car :refer [wcar]]
            [clojure.data.json :as json]
            [org.httpkit.client :as http]
            [org.httpkit.server :refer [with-channel send!]]
            [pandect.core :refer [sha1]]
            [ring.middleware.basic-authentication :refer [basic-authentication-request authentication-failure]]))

(def env (atom {:controller "localhost"
                :port "8080"
                :redishost "127.0.0.1"
                :redisport "6379"
                :dockerport "4243"}))

(defn redis-conf []
  {:spec {:host (:redishost @env)
          :port (read-string (:redisport @env))
          :password (:redispassword @env)}})

(defmacro redis! [& body] `(car/wcar (redis-conf) ~@body))

(def port-range (set (range 8000 8999)))
(def router (atom {:instances {} :envs {} :unhealthy #{}}))

(defn mark-host-health [host healthy]
  (swap! router update-in [:unhealthy] #((if healthy disj conj) % host))
  healthy)

(defn docker!
  ([method host uri] (docker! method host uri {}))
  ([method host uri options]
     (let [res @((if (= :get method) http/get http/post) (str "http://" host ":" (:dockerport @env) "/" uri) options)
           status (:status res)]
       (if (and status (< 199 status 300))
          (let [body (:body res)]
            (if (clojure.string/blank? body)
              {}
              (json/read-str body :key-fn keyword)))
          (throw (Exception. (str "Docker remote api error. Status: " status)))))))

(defn ssplit [s] (when s (clojure.string/split s #":")))
(defn create-token [] (let [token (sha1 (pr-str (java.util.Date.)))] (redis! (car/set :token token)) token))
(defn get-token [] (if-let [token (redis! (car/get :token))] token (create-token)))

(defn notify-routers [] (redis! (car/publish "updates" (java.util.Date.))))

(defn load-apps [] (redis! (car/smembers :apps)))
(defn add-app [app] (redis! (car/sadd :apps app)))
(defn remove-app [app] (redis! (car/srem :apps app)))

(defn add-app-env [app env val] (redis! (car/hset (str app ":envs") env val)))
(defn remove-app-env [app env] (redis! (car/hdel (str app ":envs") env)))
(defn load-app-envs [app] (apply hash-map (redis! (car/hgetall (str app ":envs")))))

(defn load-app-instances [app] (redis! (car/smembers (str app ":instances"))))
(defn add-app-instance [app instance] (redis! (car/sadd (str app ":instances") instance) (notify-routers)))
(defn remove-app-instance [app instance] (redis! (car/srem (str app ":instances") instance) (notify-routers)))

(defn load-pending-app-instances [app] (redis! (car/smembers (str app ":pending-instances"))))
(defn add-pending-app-instance [app instance] (redis! (car/sadd (str app ":pending-instances") instance)))
(defn remove-pending-app-instance [app instance] (redis! (car/srem (str app ":pending-instances") instance)))

(defn load-hosts [] (redis! (car/smembers :hosts)))
(defn add-host [host] (redis! (car/sadd :hosts host)))
(defn remove-host [host] (redis! (car/srem :hosts host)))

(defn load-deployments [app] (redis! (car/lrange (str "deployments:" app) -100 -1)))
(defn save-deployments [app image count]
  (redis! (car/lpush (str "deployments:" app)
                     {:timestamp (java.util.Date.)
                      :app app
                      :image image
                      :count count})))

(defn get-containers [host] (docker! :get host "containers/json"))

(defn run-container [host port internal-port image envs]
  (let [internal-port (or internal-port "80/tcp")
        options {:Hostname "" :User "" :AttachStdin false :AttachStdout true :AttachStderr true
                 :Tty true :OpenStdin false :StdinOnce false :Cmd nil :Volumes {}
                 :Env (mapv (fn [[k v]] (str k "=" v)) envs)
                 :Image image :ExposedPorts {internal-port {}}}
        start-options {:PortBindings {internal-port [{:HostPort (str port)}]}}
        id (:Id (docker! :post host "containers/create"
                         {:headers {"Content-Type" "application/json"}
                          :body (json/write-str options)}))]
    (println "Container with id" id "created.")
    (docker! :post host (str "containers/" id "/start")
             {:headers {"Content-Type" "application/json"}
              :body (json/write-str start-options)})
    id))

(defn init-routing-table []
  (doseq [app (load-apps)]
    (swap! router assoc-in [:instances app] (load-app-instances app))))

(defn load-ports-in-use [host]
  (set (mapv #(:PublicPort (first (:Ports %))) (get-containers host))))

(defn find-available-port [host]
  (rand-nth (vec (clojure.set/difference port-range (load-ports-in-use host)))))

(defn load-container-by-host-and-port [host port]
  (first (filter #(= port (str (:PublicPort (first (:Ports %))))) (get-containers host))))

(defn stop-container [host id]
  (docker! :post host (str "containers/" id "/stop")))

(defn stop-container-by-port [host port]
  (stop-container host (:Id (load-container-by-host-and-port host port))))

(defn health-check-host [host port]
  (mark-host-health host
   (loop [n 10]
     (when (pos? n)
       (if (= 200 (:status @(http/get (str "http://" host ":" port "/") {:timeout 5000})))
         true
         (recur (dec n)))))))

(defn health-check-instances []
  (doseq [i (vals (:instances @router))]
    (health-check-host i 80)))

(defn pull-docker-image [host image]
  (let [[image tag] (ssplit image)]
    (docker! :post host (str "images/create?fromImage=" image (if tag (str "&tag=" tag) "")))))

(defn kill-app-instance [app host port]
  (println "Killing instance at" (str host ":" port))
  (stop-container-by-port host port)
  (remove-app-instance app (str host ":" port)))

(defn deploy-app-instance [app host port internal-port image]
  (println "Pulling new tags for" image)
  (pull-docker-image host image)
  (println "Starting new container at" (str host ":" port))
  (let [id (run-container host port internal-port image (load-app-envs app))]
    (println "Checking host health")
    (if-not (health-check-host host port)
      (do
        (stop-container host id)
        (throw (Exception. "Failed to deploy new instance.")))
      (try
        (println "Adding" (str host ":" port) "to as pending")
        (add-pending-app-instance app (str host ":" port))
        (catch Exception e
          (println "Deploy failed. Rolling back.")
          (try (kill-app-instance app host port)
               (throw (Exception. "Deployment failed. Rolling back."))
               (catch Exception e (throw (Exception. "Rollback failed. System may be in an invalid state.")))))))))

(defn deploy-new-app-instances [app image count internal-port]
  (let [count (if (string? count) (read-string count) count)
        dist (into {} (map #(vector % (clojure.core/count (get-containers %))) (load-hosts)))
        total-containers (apply + (map second dist))
        hosts (vec (keys dist))
        total-hosts (clojure.core/count hosts)
        ideal-count-per-host (Math/ceil (/ (+ total-containers count) total-hosts))
        launching (loop [count count launching (reduce #(assoc % %2 0) {} hosts)]
                    (if (zero? count)
                      launching
                      (let [host (hosts (mod count total-hosts))]
                        (if (< (dist host) ideal-count-per-host)
                          (recur (dec count) (update-in launching [host] inc))
                          launching))))]
    (doseq [host hosts]
      (dotimes [n (launching host)]
        (deploy-app-instance app host (find-available-port host) internal-port image)))))

(defn deploy-app-instances [app image count internal-port]
  (println "Deploying" count app "with" image)
  (try
    (let [instances (load-app-instances app)]
      (deploy-new-app-instances app image count internal-port)
      (save-deployments app image count)
      (doseq [instance (load-pending-app-instances app)]
        (add-app-instance app instance)
        (remove-pending-app-instance app instance))
      (doseq [instance instances]
        (let [[image tag] (ssplit instance)]
          (kill-app-instance app image tag))))
    "App successfully deployed!"
    (catch Exception e
      (println "Rolling back deploy")
      (doseq [instance (load-pending-app-instances app)]
        (let [[host port] (ssplit instance)]
          (stop-container-by-port host port))
        (remove-pending-app-instance app instance))
      (throw (Exception. "Deploy failed. Rolling back.")))))

(defn load-app-logs [app]
  (vec
   (for [instance (load-app-instances app)]
     (let [[host port] (ssplit instance)]
       (docker! :get host (str "containers/" (:Id (load-container-by-host-and-port host port))
                               "/logs?stderr=1&stdout=1&timestamps=1"))))))

(defn kill-app-instances [app]
  (doseq [instance (load-app-instances app)]
    (let [[host port] (ssplit instance)]
      (kill-app-instance app host port))))

(defn describe []
  (into {} (for [app (load-apps)]
             (let [instances (load-app-instances app)]
               [app {:instances instances
                     :envs (load-app-envs app)
                     :image (when-let [[host port] (ssplit (first instances))]
                              (:Image (load-container-by-host-and-port host port)))}]))))

(def routes
  ["/" {"describe" #'describe
        "apps" {"" #'load-apps
                ["/add/" :app] #'add-app
                ["/delete/" :app] #'remove-app}
        "hosts" {"" #'load-hosts
                 ["/add/" :host] #'add-host
                 ["/delete/" :host] #'remove-host}
        [:app] {"/deploy" #'deploy-app-instances
                "/instances" #'load-app-instances
                "/history" #'load-deployments
                "/envs" {"" #'load-app-envs
                         ["/add/" :env "/" :val] #'add-app-env
                         ["/delete/" :env] #'remove-app-env}
                "/logs" #'load-app-logs
                "/kill" #'kill-app-instances}}])

(defn controller-app [{:keys [params uri] :as req}]
  (if-not (= (get-token) (params "x-token"))
    {:status 500
     :headers {"Content-Type" "text/plain"}
     :body (pr-str {:error "Bad token"})}
    (->> (if-let [{:keys [handler route-params] :as all} (match-route routes uri)]
           (let [params (merge (into {} (map (fn [[k v]] [(keyword k) v]) params)) route-params)
                 fn-params (mapv params (map (comp keyword name) (first (:arglists (meta handler)))))]
             (try
               {:status 200
                :headers {"Content-Type" "text/plain"}
                :body (pr-str {:data (or (apply (var-get handler) fn-params) :ok)})}
               (catch Exception e
                 (.printStackTrace e) ; todo notify
                 {:status 500
                  :headers {"Content-Type" "text/plain"}
                  :body (pr-str {:error (.getMessage e)})})))
           {:status 404
            :headers {"Content-Type" "text/plain"}
            :body (pr-str {:error "Page not found"})})
         (send! channel)
         future
         (with-channel req channel))))

(defn extract-app [req] (first (ssplit ((:headers req) "host"))))

(defn pipe-instance [req app]
  (if-let [instances (get-in @router [:instances app])]
    (if (seq instances)
      (if-let [instance (rand-nth (vec (clojure.set/difference (set instances) (:unhealthy @router))))]
        (with-channel req channel
          (http/request
           {:url (str (name (:scheme req)) "://" instance (:uri req)
                      (let [q (:query-string req)] (if (clojure.string/blank? q) "" (str "?" q))))
            :method (:request-method req)
            :headers (:headers req)
            :form-params (:form-params req)
            :body (:body req)
            :user-agent ((:headers req) "user-agent")}
           #(send! channel {:status (:status %)
                            :body (:body %)
                            :headers (into {} (map (fn [[k v]] (vector (name k) v)) (:headers %)))})))
        {:status 503 :body (str "No backend available for " app)})
      {:status 503 :body (str "No backend available for " app)})
    {:status 404 :body (str "No backend found for " app)}))

(defn pipe [req]
  (if-let [app (extract-app req)]
    (let [envs (load-app-envs app)]
      (if (envs "auth-user")
        (let [auth-req (basic-authentication-request req #(and (= % (envs "auth-user")) (= %2 (envs "auth-password"))))]
          (if (:basic-authentication auth-req)
            (pipe-instance auth-req app)
            (authentication-failure nil nil)))
        (pipe-instance req app)))
    {:status 404 :body "Invalid hostname"}))

(defn app [req]
  (if (= (:controller @env) (extract-app req))
    (controller-app req)
    (pipe req)))

(defn init []
  (get-token)
  (init-routing-table)
  (car/with-new-pubsub-listener (:spec (redis-conf)) {"updates" (fn [_] (init-routing-table))}
    (car/subscribe "updates"))
  (future
    (loop []
      (health-check-instances)
      (Thread/sleep 10000)
      (recur))))

(ns nube.app
  (:require [bidi.bidi :refer [match-route]]
            [taoensso.carmine :as car :refer [wcar]]
            [clojure.data.json :as json]
            [org.httpkit.client :as http]
            [org.httpkit.server :refer [with-channel send!]]
            [pandect.core :refer [sha1]]
            [ring.middleware.basic-authentication :refer [basic-authentication-request authentication-failure]]))

(def env (atom {:controller "localhost"
                :port "8080"
                :redishost "127.0.0.1"
                :redisport "6379"
                :dockerport "4243"}))

(defn redis-conf []
  {:spec {:host (:redishost @env)
          :port (read-string (:redisport @env))
          :password (:redispassword @env)}})

(defmacro redis! [& body] `(car/wcar (redis-conf) ~@body))

(def port-range (set (range 8000 8999)))
(def router (atom {:instances {} :envs {} :unhealthy #{}}))

(defn mark-host-health [host healthy]
  (swap! router update-in [:unhealthy] #((if healthy disj conj) % host))
  healthy)

(defn docker!
  ([method host uri] (docker! method host uri {}))
  ([method host uri options]
     (let [res @((if (= :get method) http/get http/post) (str "http://" host ":" (:dockerport @env) "/" uri) options)
           status (:status res)]
       (if (and status (< 199 status 300))
          (let [body (:body res)]
            (if (clojure.string/blank? body)
              {}
              (json/read-str body :key-fn keyword)))
          (throw (Exception. (str "Docker remote api error. Status: " status)))))))

(defn ssplit [s] (when s (clojure.string/split s #":")))
(defn create-token [] (let [token (sha1 (pr-str (java.util.Date.)))] (redis! (car/set :token token)) token))
(defn get-token [] (if-let [token (redis! (car/get :token))] token (create-token)))

(defn notify-routers [] (redis! (car/publish "updates" (java.util.Date.))))

(defn load-apps [] (redis! (car/smembers :apps)))
(defn add-app [app] (redis! (car/sadd :apps app)))
(defn remove-app [app] (redis! (car/srem :apps app)))

(defn add-app-env [app env val] (redis! (car/hset (str app ":envs") env val)))
(defn remove-app-env [app env] (redis! (car/hdel (str app ":envs") env)))
(defn load-app-envs [app] (apply hash-map (redis! (car/hgetall (str app ":envs")))))

(defn load-app-instances [app] (redis! (car/smembers (str app ":instances"))))
(defn add-app-instance [app instance] (redis! (car/sadd (str app ":instances") instance) (notify-routers)))
(defn remove-app-instance [app instance] (redis! (car/srem (str app ":instances") instance) (notify-routers)))

(defn load-pending-app-instances [app] (redis! (car/smembers (str app ":pending-instances"))))
(defn add-pending-app-instance [app instance] (redis! (car/sadd (str app ":pending-instances") instance)))
(defn remove-pending-app-instance [app instance] (redis! (car/srem (str app ":pending-instances") instance)))

(defn load-hosts [] (redis! (car/smembers :hosts)))
(defn add-host [host] (redis! (car/sadd :hosts host)))
(defn remove-host [host] (redis! (car/srem :hosts host)))

(defn load-deployments [app] (redis! (car/lrange (str "deployments:" app) -100 -1)))
(defn save-deployments [app image count]
  (redis! (car/lpush (str "deployments:" app)
                     {:timestamp (java.util.Date.)
                      :app app
                      :image image
                      :count count})))

(defn get-containers [host] (docker! :get host "containers/json"))

(defn run-container [host port internal-port image envs]
  (let [internal-port (or internal-port "80/tcp")
        options {:Hostname "" :User "" :AttachStdin false :AttachStdout true :AttachStderr true
                 :Tty true :OpenStdin false :StdinOnce false :Cmd nil :Volumes {}
                 :Env (mapv (fn [[k v]] (str k "=" v)) envs)
                 :Image image :ExposedPorts {internal-port {}}}
        start-options {:PortBindings {internal-port [{:HostPort (str port)}]}}
        id (:Id (docker! :post host "containers/create"
                         {:headers {"Content-Type" "application/json"}
                          :body (json/write-str options)}))]
    (println "Container with id" id "created.")
    (docker! :post host (str "containers/" id "/start")
             {:headers {"Content-Type" "application/json"}
              :body (json/write-str start-options)})
    id))

(defn init-routing-table []
  (doseq [app (load-apps)]
    (swap! router assoc-in [:instances app] (load-app-instances app))))

(defn load-ports-in-use [host]
  (set (mapv #(:PublicPort (first (:Ports %))) (get-containers host))))

(defn find-available-port [host]
  (rand-nth (vec (clojure.set/difference port-range (load-ports-in-use host)))))

(defn load-container-by-host-and-port [host port]
  (first (filter #(= port (str (:PublicPort (first (:Ports %))))) (get-containers host))))

(defn stop-container [host id]
  (docker! :post host (str "containers/" id "/stop")))

(defn stop-container-by-port [host port]
  (when-let [id (:Id (load-container-by-host-and-port host port))]
    (stop-container host id)))

(defn health-check-host [host port]
  (mark-host-health host
   (loop [n 10]
     (when (pos? n)
       (if (= 200 (:status @(http/get (str "http://" host ":" port "/") {:timeout 5000})))
         true
         (recur (dec n)))))))

(defn health-check-instances []
  (doseq [i (vals (:instances @router))]
    (health-check-host i 80)))

(defn pull-docker-image [host image]
  (let [[image tag] (ssplit image)]
    (docker! :post host (str "images/create?fromImage=" image (if tag (str "&tag=" tag) "")))))

(defn kill-app-instance [app host port]
  (println "Killing instance at" (str host ":" port))
  (stop-container-by-port host port)
  (remove-app-instance app (str host ":" port)))

(defn deploy-app-instance [app host port internal-port image]
  (println "Pulling new tags for" image)
  (pull-docker-image host image)
  (println "Starting new container at" (str host ":" port))
  (let [id (run-container host port internal-port image (load-app-envs app))]
    (println "Checking host health")
    (if-not (health-check-host host port)
      (do
        (stop-container host id)
        (throw (Exception. "Failed to deploy new instance.")))
      (try
        (println "Adding" (str host ":" port) "to as pending")
        (add-pending-app-instance app (str host ":" port))
        (catch Exception e
          (println "Deploy failed. Rolling back.")
          (try (kill-app-instance app host port)
               (throw (Exception. "Deployment failed. Rolling back."))
               (catch Exception e (throw (Exception. "Rollback failed. System may be in an invalid state.")))))))))

(defn deploy-new-app-instances [app image count internal-port]
  (let [count (if (string? count) (read-string count) count)
        dist (into {} (map #(vector % (clojure.core/count (get-containers %))) (load-hosts)))
        total-containers (apply + (map second dist))
        hosts (vec (keys dist))
        total-hosts (clojure.core/count hosts)
        ideal-count-per-host (Math/ceil (/ (+ total-containers count) total-hosts))
        launching (loop [count count launching (reduce #(assoc % %2 0) {} hosts)]
                    (if (zero? count)
                      launching
                      (let [host (hosts (mod count total-hosts))]
                        (if (< (dist host) ideal-count-per-host)
                          (recur (dec count) (update-in launching [host] inc))
                          launching))))]
    (doseq [host hosts]
      (dotimes [n (launching host)]
        (deploy-app-instance app host (find-available-port host) internal-port image)))))

(defn deploy-app-instances [app image count internal-port]
  (println "Deploying" count app "with" image)
  (try
    (let [instances (load-app-instances app)]
      (deploy-new-app-instances app image count internal-port)
      (save-deployments app image count)
      (doseq [instance (load-pending-app-instances app)]
        (add-app-instance app instance)
        (remove-pending-app-instance app instance))
      (doseq [instance instances]
        (let [[image tag] (ssplit instance)]
          (kill-app-instance app image tag))))
    "App successfully deployed!"
    (catch Exception e
      (println "Rolling back deploy")
      (doseq [instance (load-pending-app-instances app)]
        (let [[host port] (ssplit instance)]
          (stop-container-by-port host port))
        (remove-pending-app-instance app instance))
      (throw (Exception. "Deploy failed. Rolling back.")))))

(defn load-app-logs [app]
  (vec
   (for [instance (load-app-instances app)]
     (let [[host port] (ssplit instance)]
       (docker! :get host (str "containers/" (:Id (load-container-by-host-and-port host port))
                               "/logs?stderr=1&stdout=1&timestamps=1"))))))

(defn kill-app-instances [app]
  (doseq [instance (load-app-instances app)]
    (let [[host port] (ssplit instance)]
      (kill-app-instance app host port))))

(defn describe []
  (into {} (for [app (load-apps)]
             (let [instances (load-app-instances app)]
               [app {:instances instances
                     :envs (load-app-envs app)
                     :image (when-let [[host port] (ssplit (first instances))]
                              (:Image (load-container-by-host-and-port host port)))}]))))

(def routes
  ["/" {"describe" #'describe
        "apps" {"" #'load-apps
                ["/add/" :app] #'add-app
                ["/delete/" :app] #'remove-app}
        "hosts" {"" #'load-hosts
                 ["/add/" :host] #'add-host
                 ["/delete/" :host] #'remove-host}
        [:app] {"/deploy" #'deploy-app-instances
                "/instances" #'load-app-instances
                "/history" #'load-deployments
                "/envs" {"" #'load-app-envs
                         ["/add/" :env "/" :val] #'add-app-env
                         ["/delete/" :env] #'remove-app-env}
                "/logs" #'load-app-logs
                "/kill" #'kill-app-instances}}])

(defn controller-app [{:keys [params uri] :as req}]
  (if-not (= (get-token) (params "x-token"))
    {:status 500
     :headers {"Content-Type" "text/plain"}
     :body (pr-str {:error "Bad token"})}
    (->> (if-let [{:keys [handler route-params] :as all} (match-route routes uri)]
           (let [params (merge (into {} (map (fn [[k v]] [(keyword k) v]) params)) route-params)
                 fn-params (mapv params (map (comp keyword name) (first (:arglists (meta handler)))))]
             (try
               {:status 200
                :headers {"Content-Type" "text/plain"}
                :body (pr-str {:data (or (apply (var-get handler) fn-params) :ok)})}
               (catch Exception e
                 (.printStackTrace e) ; todo notify
                 {:status 500
                  :headers {"Content-Type" "text/plain"}
                  :body (pr-str {:error (.getMessage e)})})))
           {:status 404
            :headers {"Content-Type" "text/plain"}
            :body (pr-str {:error "Page not found"})})
         (send! channel)
         future
         (with-channel req channel))))

(defn extract-app [req] (first (ssplit ((:headers req) "host"))))

(defn pipe-instance [req app]
  (if-let [instances (get-in @router [:instances app])]
    (if (seq instances)
      (if-let [instance (rand-nth (vec (clojure.set/difference (set instances) (:unhealthy @router))))]
        (with-channel req channel
          (http/request
           {:url (str (name (:scheme req)) "://" instance (:uri req)
                      (let [q (:query-string req)] (if (clojure.string/blank? q) "" (str "?" q))))
            :method (:request-method req)
            :headers (:headers req)
            :form-params (:form-params req)
            :body (:body req)
            :user-agent ((:headers req) "user-agent")}
           #(send! channel {:status (:status %)
                            :body (:body %)
                            :headers (into {} (map (fn [[k v]] (vector (name k) v)) (:headers %)))})))
        {:status 503 :body (str "No backend available for " app)})
      {:status 503 :body (str "No backend available for " app)})
    {:status 404 :body (str "No backend found for " app)}))

(defn pipe [req]
  (if-let [app (extract-app req)]
    (let [envs (load-app-envs app)]
      (if (envs "auth-user")
        (let [auth-req (basic-authentication-request req #(and (= % (envs "auth-user")) (= %2 (envs "auth-password"))))]
          (if (:basic-authentication auth-req)
            (pipe-instance auth-req app)
            (authentication-failure nil nil)))
        (pipe-instance req app)))
    {:status 404 :body "Invalid hostname"}))

(defn app [req]
  (if (= (:controller @env) (extract-app req))
    (controller-app req)
    (pipe req)))

(defn init []
  (get-token)
  (init-routing-table)
  (car/with-new-pubsub-listener (:spec (redis-conf)) {"updates" (fn [_] (init-routing-table))}
    (car/subscribe "updates"))
  (future
    (loop []
      (health-check-instances)
      (Thread/sleep 10000)
      (recur))))

Fix NPE on stop-container container

Fix NPE on stop-container container


(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [immutant.transactions :refer [transaction]]
            [immutant.transactions.jdbc :refer [factory]]
            [environ.core :refer [env]]
            [clj-time.core :as t]
            [clj-time.coerce :refer [to-date]]
            [org.tobereplaced.nio.file :as nio]
            [me.raynes.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.repair :as repair]
            [mdr2.rdf :as rdf]
            [mdr2.util :as util]))

(def ^:private db {:factory factory :name "java:jboss/datasources/archive"})

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn container-root-path
  "Return the root container path for a given `production` and
  `sektion`"
  [production sektion]
  (file spool-dir (container-id production sektion)))

(defn container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)]
    (.getPath (file root-path "produkt"))))

(defn container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file root-path rdf-name))))

(defn- db-job
  "Return a map that can be used to insert a job in the archive db for
  given `production` and `sektion`"
  [production sektion]
  {:archivar "Madras2"
   :abholer ""
   :aktion (if (> (:revision production) 1) "update" "save")
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""
   :verzeichnis (container-id production sektion)
   :sektion (case sektion :master "master" :dist-master "cdimage")
   :datum (to-date (t/now))})

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [update (> (:revision production) 1)
        job (db-job production sektion)]
    (if update
      (let [container-id (repair/container-id production sektion)]
        (log/debugf "Updating %s (%s, %s) in archive db" (:id production) sektion container-id)
        (jdbc/update! db :container job ["id = ?" container-id]))
      (do
        (log/debugf "Adding %s (%s) to archive db" (:id production) sektion)
        (jdbc/insert! db :container job)))))

(defn set-file-permissions
  "Set file permissions on `root` to g+w recursively"
  [file-tree]
  (let [permissions (conj (set (nio/posix-file-permissions file-tree))
                          (nio/posix-file-permission :group-write))
        visitor-fn (fn [f] (nio/set-posix-file-permissions! f permissions) nil)
        visitor (nio/naive-visitor
                 :pre-visit-directory visitor-fn
                 :visit-file visitor-fn)]
    (nio/walk-file-tree file-tree visitor)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-root-path (container-root-path production sektion)]
    (if (fs/exists? archive-root-path)
      (log/errorf "Archive root path %s already exists" archive-root-path)
      (let [archive-path (container-path production sektion)]
        (fs/mkdir archive-root-path)
        (log/debugf "Copying files for %s (%s)" (:id production) sektion)
        (case sektion
          :master
          (fs/copy-dir (path/recorded-path production)
                       (file archive-path (prod/dam-number production)))
          :dist-master
          (doseq [volume (range 1 (inc (:volumes production)))]
            (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                  iso-archive-path (.getPath (file archive-path iso-archive-name))]
              (fs/copy+ (path/iso-name production volume) iso-archive-path))))
        (set-file-permissions archive-root-path)))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        rdf-path (container-rdf-path production sektion)]
    (log/debugf "Creating rdf for %s (%s)" (:id production) sektion)
    (spit rdf-path rdf)))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (transaction
   (archive-sektion production :master)
   (archive-sektion production :dist-master)
   (prod/set-state-archived! production)))

(defmethod archive "periodical"
  [production]
  (transaction
   (archive-sektion production :master)
   ;; archive the periodical iso(s)
   (let [dam-number (prod/dam-number production)
         archive-path (.getPath (file periodical-spool-dir dam-number))
         multi-volume? (prod/multi-volume? production)]
     (when (fs/exists? archive-path)
       ;; when repairing the production is already in the spool dir
       (log/warnf "Archive path %s for periodical already exists, removing" archive-path)
       (util/delete-directory! archive-path))
     (nio/create-directory! archive-path)
     ;; create the rdf
     (let [rdf-path (file archive-path (str dam-number ".rdf"))
           rdf (rdf/rdf production)]
       (spit rdf-path rdf))
     ;; copy all volumes
     (doseq [volume (range 1 (inc (:volumes production)))]
       (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
             iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
         (fs/copy+ (path/iso-name production volume) iso-archive-path)))
     (set-file-permissions (file archive-path))
     (prod/set-state-archived! production))))

(defmethod archive "other"
  [production]
  (transaction
   (archive-sektion production :master)
   ;; place the iso(s) in a spool directory
   (let [dam-number (prod/dam-number production)
         archive-path (.getPath (file other-spool-dir dam-number))
         multi-volume? (prod/multi-volume? production)]
     (when (fs/exists? archive-path)
       ;; when repairing the production is already in the spool dir
       (log/warnf "Archive path %s for other production already exists, removing" archive-path)
       (util/delete-directory! archive-path))
     (nio/create-directory! archive-path)
     ;; create the rdf
     (let [rdf-path (file archive-path (str dam-number ".rdf"))
           rdf (rdf/rdf production)]
       (spit rdf-path rdf))
     ;; copy all volumes
     (doseq [volume (range 1 (inc (:volumes production)))]
       (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
             iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
         (fs/copy+ (path/iso-name production volume) iso-archive-path)
         (set-file-permissions (file iso-archive-path))))
     (prod/set-state-archived! production))))

(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [immutant.transactions :refer [transaction]]
            [immutant.transactions.jdbc :refer [factory]]
            [environ.core :refer [env]]
            [clj-time.core :as t]
            [clj-time.coerce :refer [to-date]]
            [org.tobereplaced.nio.file :as nio]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.repair :as repair]
            [mdr2.rdf :as rdf]
            [mdr2.util :as util]))

(def ^:private db {:factory factory :name "java:jboss/datasources/archive"})

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn container-root-path
  "Return the root container path for a given `production` and
  `sektion`"
  [production sektion]
  (file spool-dir (container-id production sektion)))

(defn container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)]
    (.getPath (file root-path "produkt"))))

(defn container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file root-path rdf-name))))

(defn- db-job
  "Return a map that can be used to insert a job in the archive db for
  given `production` and `sektion`"
  [production sektion]
  {:archivar "Madras2"
   :abholer ""
   :aktion (if (> (:revision production) 1) "update" "save")
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""
   :verzeichnis (container-id production sektion)
   :sektion (case sektion :master "master" :dist-master "cdimage")
   :datum (to-date (t/now))})

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [update (> (:revision production) 1)
        job (db-job production sektion)]
    (if update
      (let [container-id (repair/container-id production sektion)]
        (log/debugf "Updating %s (%s, %s) in archive db" (:id production) sektion container-id)
        (jdbc/update! db :container job ["id = ?" container-id]))
      (do
        (log/debugf "Adding %s (%s) to archive db" (:id production) sektion)
        (jdbc/insert! db :container job)))))

(defn set-file-permissions
  "Set file permissions on `root` to g+w recursively"
  [file-tree]
  (let [permissions (conj (set (nio/posix-file-permissions file-tree))
                          (nio/posix-file-permission :group-write))
        visitor-fn (fn [f] (nio/set-posix-file-permissions! f permissions) nil)
        visitor (nio/naive-visitor
                 :pre-visit-directory visitor-fn
                 :visit-file visitor-fn)]
    (nio/walk-file-tree file-tree visitor)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-root-path (container-root-path production sektion)]
    (if (nio/exists? archive-root-path)
      (log/errorf "Archive root path %s already exists" archive-root-path)
      (let [archive-path (container-path production sektion)]
        (nio/create-directory! archive-root-path)
        (log/debugf "Copying files for %s (%s)" (:id production) sektion)
        (case sektion
          :master
          (util/copy-directory! (path/recorded-path production)
                                (file archive-path (prod/dam-number production)))
          :dist-master
          (doseq [volume (range 1 (inc (:volumes production)))]
            (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                  iso-archive-path (.getPath (file archive-path iso-archive-name))]
              (nio/create-directories! iso-archive-path)
              (nio/copy! (path/iso-name production volume) iso-archive-path))))
        (set-file-permissions archive-root-path)))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        rdf-path (container-rdf-path production sektion)]
    (log/debugf "Creating rdf for %s (%s)" (:id production) sektion)
    (spit rdf-path rdf)))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (transaction
   (archive-sektion production :master)
   (archive-sektion production :dist-master)
   (prod/set-state-archived! production)))

(defmethod archive "periodical"
  [production]
  (transaction
   (archive-sektion production :master)
   ;; archive the periodical iso(s)
   (let [dam-number (prod/dam-number production)
         archive-path (.getPath (file periodical-spool-dir dam-number))
         multi-volume? (prod/multi-volume? production)]
     (when (nio/exists? archive-path)
       ;; when repairing the production is already in the spool dir
       (log/warnf "Archive path %s for periodical already exists, removing" archive-path)
       (util/delete-directory! archive-path))
     (nio/create-directory! archive-path)
     ;; create the rdf
     (let [rdf-path (file archive-path (str dam-number ".rdf"))
           rdf (rdf/rdf production)]
       (spit rdf-path rdf))
     ;; copy all volumes
     (doseq [volume (range 1 (inc (:volumes production)))]
       (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
             iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
         (nio/create-directories! iso-archive-path)
         (nio/copy! (path/iso-name production volume) iso-archive-path)))
     (set-file-permissions (file archive-path))
     (prod/set-state-archived! production))))

(defmethod archive "other"
  [production]
  (transaction
   (archive-sektion production :master)
   ;; place the iso(s) in a spool directory
   (let [dam-number (prod/dam-number production)
         archive-path (.getPath (file other-spool-dir dam-number))
         multi-volume? (prod/multi-volume? production)]
     (when (nio/exists? archive-path)
       ;; when repairing the production is already in the spool dir
       (log/warnf "Archive path %s for other production already exists, removing" archive-path)
       (util/delete-directory! archive-path))
     (nio/create-directory! archive-path)
     ;; create the rdf
     (let [rdf-path (file archive-path (str dam-number ".rdf"))
           rdf (rdf/rdf production)]
       (spit rdf-path rdf))
     ;; copy all volumes
     (doseq [volume (range 1 (inc (:volumes production)))]
       (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
             iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
         (nio/create-directories! iso-archive-path)
         (nio/copy! (path/iso-name production volume) iso-archive-path)
         (set-file-permissions (file iso-archive-path))))
     (prod/set-state-archived! production))))

Use nio for copying files when archiving


(ns silly-image-store.store
  (:require [clojure.java.io :as io]))

(def exists? #(and % (.exists %)))
(def file? #(.isFile %))
(def filename #(.getName %))

(defn load-image [& paths]
  (let [file (apply io/file paths)]
    (if (exists? file) file nil)))

(defn list-images [& paths]
  (let [image-directory (apply load-image paths)]
    (if (exists? image-directory)
      (->> image-directory
       .listFiles
       (filter file?)
       (map filename))
      nil)))

(defn random-image [basedir]
  (let [random-image-name (rand-nth (list-images basedir))]
    (load-image basedir random-image-name)))

(ns silly-image-store.store
  (:require [clojure.java.io :as io]))

(def exists? #(and % (.exists %)))
(def file? #(.isFile %))
(def filename #(.getName %))

(defn load-image [& paths]
  (let [file (apply io/file paths)]
    (if (exists? file) file)))

(defn list-images [& paths]
  (let [image-directory (apply load-image paths)]
    (if (exists? image-directory)
      (->> image-directory
       .listFiles
       (filter file?)
       (map filename)))))

(defn random-image [basedir]
  (let [random-image-name (rand-nth (list-images basedir))]
    (load-image basedir random-image-name)))

Remove nils as it's redundnnat

Remove nils as it's redundnnat