(ns org.broadinstitute.firecloud-ui.page.methods-configs-acl
  (:require
   [dmohs.react :as react]
   [clojure.string :refer [trim]]
   [org.broadinstitute.firecloud-ui.common :as common]
   [org.broadinstitute.firecloud-ui.common.components :as comps]
   [org.broadinstitute.firecloud-ui.common.dialog :as dialog]
   [org.broadinstitute.firecloud-ui.common.style :as style]
   [org.broadinstitute.firecloud-ui.common.table :as table]
   [org.broadinstitute.firecloud-ui.endpoints :as endpoints]
   [org.broadinstitute.firecloud-ui.utils :as utils]
   ))

(defn- get-ordered-name [entity]
  (clojure.string/join ":"
    [(entity "namespace")
     (entity "name")
     (entity "snapshotId")]))

(def ^:private access-levels
  ["READER" "OWNER" "NO ACCESS"])

(defn- index-to-access-level [idx]
  (str (nth access-levels idx)))

(defn- access-level-to-index [access-level]
  (case access-level
    "READER" 0
    "OWNER" 1
    "NO ACCESS" 2))

(def ^:private column-width "calc(50% - 4px)")

(defn- correspondsToReader [access-level]
  (if
    (or
      (= access-level "READER")
      (= access-level "OWNER"))
    true
    false))

(defn- filter-public [acl-vec]
  (let [hasNotPublicUser
        (fn [m]
          (not
            (and
              (map? m)
              (contains? m :user)
              (= "public" (:user m)))))]
    (filterv hasNotPublicUser acl-vec)))

(defn- make-ui-vec [a-map]
  {:user (get a-map "user")
   :role (get a-map "role")})

(defn- extract-last-public-access-level [acl-vec]
  (let [hasPublicUser
        (fn [m]
          (and
            (map? m)
            (contains? m :user)
            (= "public" (:user m))))
        justPublic (filterv hasPublicUser acl-vec)
        numJustPublic (count justPublic)]
      (if (<= numJustPublic 0)
      ;if public isn't in the acl-return NO ACCESS
      "NO ACCESS"
      (let [lastPublic (get justPublic (- numJustPublic 1))
            lastPublicAccessLevel (get lastPublic :role)]
        ;if public is in the acl return the value of the last one
        lastPublicAccessLevel))))

(react/defc AgoraPermsEditor
  {:render
   (fn [{:keys [props refs state this]}]
     [dialog/Dialog

      {:width "75%"
       :blocking? true
       :dismiss-self (:dismiss-self props)
       :content (react/create-element
                  [:div {:style {:background "#fff" :padding "2em"}}
                   [comps/XButton {:dismiss (:dismiss-self props)}]
                   (cond
                     (:acl-vec @state)
                     [:div {}
                      (when (:saving? @state)
                        [comps/Blocker {:banner "Updating..."}])
                      [:div {:style {:paddingBottom "0.5em" :fontSize "90%"}}
                       [:h4 {} (let [sel-ent (:selected-entity props)
                                     ent-type (sel-ent "entityType")
                                     disp (get-ordered-name sel-ent)]
                                 (str "Permissions for " ent-type " " disp))]
                       [:div {:style
                              {:float "left" :width column-width}}
                        "User or Group ID"]
                       [:div {:style
                              {:float "right" :width column-width}}
                        "Access Level"]
                       (common/clear-both)]
                      (map-indexed
                        (fn [i acl-entry]
                          [:div {}
                           (style/create-text-field
                             {:ref (str "acl-key" i)
                              :style {:float "left" :width column-width
                                      :backgroundColor (when (< i (:count-orig @state))
                                                         (:background-gray style/colors))}
                              :disabled (< i (:count-orig @state))
                              :spellCheck false
                              :defaultValue (:user acl-entry)
                              :onChange (fn [e]
                                          (let [new-val (-> e .-target .-value)
                                                new-val-is-public (= "public" new-val)]
                                            (when new-val-is-public
                                              (do
                                                (js/alert "Cannot set value to 'public'!  Use the check-box instead.")
                                                (set! (-> e .-target .-value) "")))))})
                           (style/create-select
                             {:ref (str "acl-value" i)
                              :style {:float "right" :width column-width :height 33}
                              :defaultValue (access-level-to-index (:role acl-entry))}
                             access-levels)
                           (common/clear-both)])
                        (:acl-vec @state))
                      [comps/Button {:text "Add new" :style :add
                                     :onClick #(swap! state assoc :acl-vec
                                                (conj
                                                  (react/call :capture-ui-state this)
                                                  {:user "" :role "READER"}))}]
                      [:input {:type "checkbox"
                               :ref "publicbox"
                               :onChange (fn []
                                           (let [checkValue (-> (@refs "publicbox") .getDOMNode .-checked)]
                                             (swap! state assoc :public-status checkValue)))
                               :checked (:public-status @state)}]
                      "Publicly Readable?"
                      [:div {:style {:textAlign "center" :marginTop "1em"}}
                       [:a {:href "javascript:;"
                            :style {:textDecoration "none"
                                    :color (:button-blue style/colors)
                                    :marginRight "1.5em"}
                            :onClick #((:dismiss-self props))}
                        "Cancel"]
                       [comps/Button {:text "Save"
                                      :onClick #(react/call :persist-acl this)}]]]
                     (:error @state) (style/create-server-error-message (:error @state))
                     :else [comps/Spinner {:text
                                           (str "Loading Permissions for "
                                             ((:selected-entity props) "entityType") " "
                                             (get-ordered-name (:selected-entity props))
                                             "...")}])])}])
   :component-did-mount
   (fn [{:keys [props state]}]
     (endpoints/call-ajax-orch
       {:endpoint (let [ent (:selected-entity props)
                        name (ent "name")
                        nmsp (ent "namespace")
                        sid (ent "snapshotId")]
                    (endpoints/get-agora-method-acl
                      nmsp name sid (:is-conf props)))
        :on-done (fn [{:keys [success? get-parsed-response status-text]}]
                   (if success?
                     (let [parsed-response (get-parsed-response)
                           ui-vec (mapv make-ui-vec parsed-response)
                           public-level (extract-last-public-access-level ui-vec)
                           checkValue (correspondsToReader public-level)
                           filtered-ui-vec (filter-public ui-vec)
                           acl-vec filtered-ui-vec]
                       (swap! state assoc :acl-vec acl-vec
                         :public-status checkValue
                         :count-orig (count acl-vec)))
                     (swap! state assoc :error status-text)))}))
   :persist-acl
   (fn [{:keys [props state this]}]
     (swap! state assoc :saving? true)
     (swap! state assoc :acl-vec
       (flatten [{:user "public" :role
                 (if (:public-status @state) "READER" "NO ACCESS")}
       (react/call :capture-ui-state this)]))
     (endpoints/call-ajax-orch
       {:endpoint (endpoints/persist-agora-method-acl (:selected-entity props))
        :headers {"Content-Type" "application/json"}
        :payload (filterv #(not (empty? (:user %))) (:acl-vec @state))
        :on-done (fn [{:keys [success? status-text]}]
                   (swap! state dissoc :saving?)
                   (if success?
                     ((:dismiss-self props))
                     (js/alert "Error saving permissions: " status-text)))}))
   :capture-ui-state
   (fn [{:keys [state refs]}]
     (mapv
       (fn [i]
         {:user (-> (@refs (str "acl-key" i)) .getDOMNode .-value trim)
          :role (index-to-access-level (int (-> (@refs (str "acl-value" i)) .getDOMNode .-value)))})
       (range (count (:acl-vec @state)))))})

(ns org.broadinstitute.firecloud-ui.page.methods-configs-acl
  (:require
   [dmohs.react :as react]
   [clojure.string :refer [trim]]
   [org.broadinstitute.firecloud-ui.common :as common]
   [org.broadinstitute.firecloud-ui.common.components :as comps]
   [org.broadinstitute.firecloud-ui.common.dialog :as dialog]
   [org.broadinstitute.firecloud-ui.common.style :as style]
   [org.broadinstitute.firecloud-ui.common.table :as table]
   [org.broadinstitute.firecloud-ui.endpoints :as endpoints]
   [org.broadinstitute.firecloud-ui.utils :as utils]
   ))

(defn- get-ordered-name [entity]
  (clojure.string/join ":"
    [(entity "namespace")
     (entity "name")
     (entity "snapshotId")]))

(def ^:private access-levels
  ["READER" "OWNER" "NO ACCESS"])

(def ^:private reader-level (nth access-levels 0))
(def ^:private  owner-level (nth access-levels 1))
(def ^:private  no-access-level (nth access-levels 2))

(defn- index-to-access-level [idx]
  (str (nth access-levels idx)))

(defn- access-level-to-index [access-level]
  (case access-level
    reader-level 0
    owner-level 1
    no-access-level 2))

(def ^:private column-width "calc(50% - 4px)")

(defn- correspondsToReader [access-level]
  (if
    (or
      (= access-level reader-level)
      (= access-level owner-level))
    true
    false))

(defn- filter-public [acl-vec]
  (let [hasNotPublicUser
        (fn [m]
          (not
            (and
              (map? m)
              (contains? m :user)
              (= "public" (:user m)))))]
    (filterv hasNotPublicUser acl-vec)))

(defn- make-ui-vec [a-map]
  {:user (get a-map "user")
   :role (get a-map "role")})

(defn- extract-last-public-access-level [acl-vec]
  (let [hasPublicUser
        (fn [m]
          (and
            (map? m)
            (contains? m :user)
            (= "public" (:user m))))
        justPublic (filterv hasPublicUser acl-vec)
        numJustPublic (count justPublic)]
      (if (<= numJustPublic 0)
      ;if public isn't in the acl-return NO ACCESS
      no-access-level
      (let [lastPublic (get justPublic (- numJustPublic 1))
            lastPublicAccessLevel (get lastPublic :role)]
        ;if public is in the acl return the value of the last one
        lastPublicAccessLevel))))

(react/defc AgoraPermsEditor
  {:render
   (fn [{:keys [props refs state this]}]
     [dialog/Dialog
      {:width "75%"
       :blocking? true
       :dismiss-self (:dismiss-self props)
       :content (react/create-element
                  [:div {:style {:background "#fff" :padding "2em"}}
                   [comps/XButton {:dismiss (:dismiss-self props)}]
                   (cond
                     (:acl-vec @state)
                     [:div {}
                      (when (:saving? @state)
                        [comps/Blocker {:banner "Updating..."}])
                      [:div {:style {:paddingBottom "0.5em" :fontSize "90%"}}
                       [:h4 {} (let [sel-ent (:selected-entity props)
                                     ent-type (sel-ent "entityType")
                                     disp (get-ordered-name sel-ent)]
                                 (str "Permissions for " ent-type " " disp))]
                       [:div {:style
                              {:float "left" :width column-width}}
                        "User or Group ID"]
                       [:div {:style
                              {:float "right" :width column-width}}
                        "Access Level"]
                       (common/clear-both)]
                      (map-indexed
                        (fn [i acl-entry]
                          [:div {}
                           (style/create-text-field
                             {:ref (str "acl-key" i)
                              :style {:float "left" :width column-width
                                      :backgroundColor (when (< i (:count-orig @state))
                                                         (:background-gray style/colors))}
                              :disabled (< i (:count-orig @state))
                              :spellCheck false
                              :defaultValue (:user acl-entry)
                              :onChange (fn [e]
                                          (let [new-val (-> e .-target .-value)
                                                new-val-is-public (= "public" new-val)]
                                            (when new-val-is-public
                                              (do
                                                (js/alert "Cannot set value to 'public'!  Use the check-box instead.")
                                                (set! (-> e .-target .-value) "")))))})
                           (style/create-select
                             {:ref (str "acl-value" i)
                              :style {:float "right" :width column-width :height 33}
                              :defaultValue (access-level-to-index (:role acl-entry))}
                             access-levels)
                           (common/clear-both)])
                        (:acl-vec @state))
                      [comps/Button {:text "Add new" :style :add
                                     :onClick #(swap! state assoc :acl-vec
                                                (conj
                                                  (react/call :capture-ui-state this)
                                                  {:user "" :role reader-level}))}]
                      [:input {:type "checkbox"
                               :ref "publicbox"
                               :onChange (fn []
                                           (let [checkValue (-> (@refs "publicbox") .getDOMNode .-checked)]
                                             (swap! state assoc :public-status checkValue)))
                               :checked (:public-status @state)}]
                      "Publicly Readable?"
                      [:div {:style {:textAlign "center" :marginTop "1em"}}
                       [:a {:href "javascript:;"
                            :style {:textDecoration "none"
                                    :color (:button-blue style/colors)
                                    :marginRight "1.5em"}
                            :onClick #((:dismiss-self props))}
                        "Cancel"]
                       [comps/Button {:text "Save"
                                      :onClick #(react/call :persist-acl this)}]]]
                     (:error @state) (style/create-server-error-message (:error @state))
                     :else [comps/Spinner {:text
                                           (str "Loading Permissions for "
                                             ((:selected-entity props) "entityType") " "
                                             (get-ordered-name (:selected-entity props))
                                             "...")}])])}])
   :component-did-mount
   (fn [{:keys [props state]}]
     (endpoints/call-ajax-orch
       {:endpoint (let [ent (:selected-entity props)
                        name (ent "name")
                        nmsp (ent "namespace")
                        sid (ent "snapshotId")]
                    (endpoints/get-agora-method-acl
                      nmsp name sid (:is-conf props)))
        :on-done (fn [{:keys [success? get-parsed-response status-text]}]
                   (if success?
                     (let [parsed-response (get-parsed-response)
                           ui-vec (mapv make-ui-vec parsed-response)
                           public-level (extract-last-public-access-level ui-vec)
                           checkValue (correspondsToReader public-level)
                           filtered-ui-vec (filter-public ui-vec)
                           acl-vec filtered-ui-vec]
                       (swap! state assoc :acl-vec acl-vec
                         :public-status checkValue
                         :count-orig (count acl-vec)))
                     (swap! state assoc :error status-text)))}))
   :persist-acl
   (fn [{:keys [props state this]}]
     (swap! state assoc :saving? true)
     (swap! state assoc :acl-vec
       (flatten [{:user "public" :role
                 (if (:public-status @state) reader-level no-access-level)}
       (react/call :capture-ui-state this)]))
     (endpoints/call-ajax-orch
       {:endpoint (endpoints/persist-agora-method-acl (:selected-entity props))
        :headers {"Content-Type" "application/json"}
        :payload (filterv #(not (empty? (:user %))) (:acl-vec @state))
        :on-done (fn [{:keys [success? status-text]}]
                   (swap! state dissoc :saving?)
                   (if success?
                     ((:dismiss-self props))
                     (js/alert "Error saving permissions: " status-text)))}))
   :capture-ui-state
   (fn [{:keys [state refs]}]
     (mapv
       (fn [i]
         {:user (-> (@refs (str "acl-key" i)) .getDOMNode .-value trim)
          :role (index-to-access-level (int (-> (@refs (str "acl-value" i)) .getDOMNode .-value)))})
       (range (count (:acl-vec @state)))))})

create constants to refer to strings

create constants to refer to strings


(ns frontend.analytics.google
  (:require [frontend.utils :as utils :include-macros true]))

(defn push [args]
  (let [gaq (aget js/window "_gaq")]
     ((aget gaq "push") (clj->js args))))

(defn track-event [& args]
  (utils/swallow-errors (push "_trackEvent" args)))

(defn track-pageview [& args]
  (utils/swallow-errors (push "_trackPageview" args)))

(ns frontend.analytics.google
  (:require [frontend.utils :as utils :include-macros true]))

(defn push [args]
  (let [gaq (aget js/window "_gaq")]
     ((aget gaq "push") (clj->js args))))

(defn track-event [& args]
  (utils/swallow-errors (push (cons "_trackEvent" args))))

(defn track-pageview [& args]
  (utils/swallow-errors (push (cons "_trackPageview" args))))

fix bug in gaq

fix bug in gaq


(ns re-frame.handlers
  (:refer-clojure :exclude [flush])
  (:require-macros [cljs.core.async.macros :refer [go-loop go]])
  (:require [reagent.core     :refer [flush]]
            [re-frame.db      :refer [app-db]]
            [re-frame.utils   :refer [first-in-vector warn]]
            [cljs.core.async  :refer [chan put! <! timeout]]))

;; -- the register of event handlers --------------------------------------------------------------

(def ^:private id->fn  (atom {}))

(defn register
  "register a handler for an event"
  ([event-id handler-fn]
    (when (contains? @id->fn event-id)
      (warn "re-frame: overwriting an event-handler for: " event-id))   ;; allow it, but warn.
    (swap! id->fn assoc event-id handler-fn))

  ([event-id middleware handler-fn]
    (let  [mware  (if (vector? middleware)
                    (apply comp middleware)   ;; compose the vector of middleware
                    middleware)
           hander-fn (mware handler-fn)]
      (register event-id hander-fn))))

;; -- The Event Conveyor Belt  --------------------------------------------------------------------
;;
;; Moves events from "dispatch" to the router loop.
;; This alows for aysnc handling of events.
;;
(def ^:private event-chan (chan))    ;; TODO: how big should we make the buffer?

;; -- lookup and call -----------------------------------------------------------------------------

(defn- handle
  "Look up the handler for the given event, then call it, passing in 2 parameters."
  [event-v]
  (let [event-id    (first-in-vector event-v)
        handler-fn  (get @id->fn event-id)]
    (if (nil? handler-fn)
      (warn "re-frame: no event handler registered for: \"" event-id "\". Ignoring.")   ;; TODO: make exception
      (handler-fn app-db event-v))))

;; -- router loop ---------------------------------------------------------------------------------
;;
;; In a loop, read events from the dispatch channel, and route them
;; to the right handler.
;;
;; Because handlers occupy the CPU, before each event is handled, hand
;; back control to the browser, via a (<! (timeout 0)) call.
;;
;; In odd cases, we need to pause for an entire annimationFrame, to ensure that
;; the DOM is fully flushed, before then calling a handler known to hog the CPU
;; for an extended period.  In such a case, the event should be laballed with metadata
;; Example usage:
;;   (dispatch ^:flush-dom  [:event-id other params])
;;
;; router loop
(go-loop []
         (let [event-v  (<! event-chan)                   ;; wait for an event
               _        (if (:flush-dom (meta event-v))   ;; check the event for metadata
                          (do (flush) (<! (timeout 20)))  ;; wait just over one annimation frame (16ms), to rensure all pending GUI work is flushed to the DOM.
                          (<! (timeout 0)))]              ;; just in case we are handling one dispatch after an other, give the browser back control to do its stuff
           (handle event-v)
           (recur)))

;; -- dispatch ------------------------------------------------------------------------------------

(defn dispatch
  "reagent components use this function to send events.
  Usage example:
     (dispatch [:delete-item 42])"
  [event-v]
  (if (nil? event-v)
    (warn "re-frame: \"dispatch\" is ignoring a nil event.")     ;; nil would close the channel
    (put! event-chan event-v)))

;; TODO: remove sync handling.  I don't like it, even for testing.
(defn dispatch-sync
  "Invoke the event handler sycronously, avoiding the async-inducing use of core.async/chan"
  [event-v]
  (handle event-v))

(ns re-frame.handlers
  (:refer-clojure :exclude [flush])
  (:require-macros [cljs.core.async.macros :refer [go-loop go]])
  (:require [reagent.core     :refer [flush]]
            [re-frame.db      :refer [app-db]]
            [re-frame.utils   :refer [first-in-vector warn]]
            [cljs.core.async  :refer [chan put! <! timeout]]))

;; -- the register of event handlers --------------------------------------------------------------

(def ^:private id->fn  (atom {}))

(defn register
  "register a handler for an event"
  ([event-id handler-fn]
    (when (contains? @id->fn event-id)
      (warn "re-frame: overwriting an event-handler for: " event-id))   ;; allow it, but warn.
    (swap! id->fn assoc event-id handler-fn))

  ([event-id middleware handler-fn]
    (let  [mware  (if (vector? middleware)
                    (apply comp middleware)   ;; compose the vector of middleware
                    middleware)
           hander-fn (mware handler-fn)]
      (register event-id hander-fn))))

;; -- The Event Conveyor Belt  --------------------------------------------------------------------
;;
;; Moves events from "dispatch" to the router loop.
;; Allows for the aysnc handling of events.
;;
(def ^:private event-chan (chan))    ;; TODO: how big should we make the buffer?

;; -- lookup and call -----------------------------------------------------------------------------

(defn- handle
  "Given an event vector, look up the right handler, then call it.
  By default, handlers are not assumed to be pure. They are called with
  two paramters:
  - the `app-db` atom and
  - the event vector
  The handler is assumed to side-effect on the atom, the return value is ignored.
   To write handlers that are pure functions, use the \"pure\" middleware at handler
   registration time."
  [event-v]
  (let [event-id    (first-in-vector event-v)
        handler-fn  (get @id->fn event-id)]
    (if (nil? handler-fn)
      (warn "re-frame: no event handler registered for: \"" event-id "\". Ignoring.")   ;; TODO: make exception
      (handler-fn app-db event-v))))

;; -- router loop ---------------------------------------------------------------------------------
;;
;; In a perpretual loop, read events from the dispatch channel, and route them
;; to the right handler.
;;
;; Because handlers occupy the CPU, before each event is handled, hand
;; back control to the browser, via a (<! (timeout 0)) call.
;;
;; In odd cases, we need to pause for an entire annimationFrame, to ensure that
;; the DOM is fully flushed, before then calling a handler known to hog the CPU
;; for an extended period.  In such a case, the event should be laballed with metadata
;; Example usage (notice the ":flush-dom" metadata):
;;   (dispatch ^:flush-dom  [:event-id other params])
;;
;; router loop
(go-loop []
         (let [event-v  (<! event-chan)                   ;; wait for an event
               _        (if (:flush-dom (meta event-v))   ;; check the event for metadata
                          (do (flush) (<! (timeout 20)))  ;; wait just over one annimation frame (16ms), to rensure all pending GUI work is flushed to the DOM.
                          (<! (timeout 0)))]              ;; just in case we are handling one dispatch after an other, give the browser back control to do its stuff
           (handle event-v)
           (recur)))

;; -- dispatch ------------------------------------------------------------------------------------

(defn dispatch
  "reagent components use this function to send events.
  Usage example:
     (dispatch [:delete-item 42])"
  [event-v]
  (if (nil? event-v)
    (warn "re-frame: \"dispatch\" is ignoring a nil event.")     ;; nil would close the channel
    (put! event-chan event-v))
  nil)   ;; Ensure nil return. See https://github.com/Day8/re-frame/wiki/Returning-False

;; TODO: remove sync handling.  I don't like it much, even for testing.
(defn dispatch-sync
  "Invoke the event handler sycronously, avoiding the async-inducing use of core.async/chan"
  [event-v]
  (handle event-v))

Improve comments on handlers

Improve comments on handlers


(ns om-tools.core-test
  (:require-macros
   [cemerick.cljs.test :refer [is are deftest testing use-fixtures done]]
   [om-tools.test-utils :refer [with-element]]
   [schema.macros :as sm])
  (:require
   cemerick.cljs.test
   [clojure.set :as set]
   [om-tools.core :as om-tools :refer-macros [defcomponent defcomponentk defmixin]]
   [om-tools.dom :as dom :include-macros true]
   [om.core :as om]
   [schema.core :as s]
   [schema.test :as schema-test]))

(defn composite-component?
  "http://git.io/BPd6uw"
  [x]
  (and (fn? (aget x "render"))
       (fn? (aget x "setState"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(sm/defschema TestComponent
  {:foo s/Str :bar s/Str})

(defcomponent test-component
  [data :- TestComponent owner]
  (display-name [_] (str (:foo data) (:bar data) "!"))
  (init-state [_] :init-state)
  (should-update [_ _ _] :should-update)
  (will-mount [_] :will-mount)
  (did-mount [_] :did-mount)
  (will-unmount [_] :will-unmount)
  (will-update [_ _ _] :will-update)
  (did-update [_ _ _] :did-update)
  (will-receive-props [_ _] :will-receive-props)
  (render [_] :render)
  (render-state [_ _] :render-state))

(deftest defcomponent-test
  (testing "defs"
    (is (fn? test-component))
    (is (fn? ->test-component)))
  (testing "construct object w/ lifecycle protocols"
    (let [c (test-component {:foo "foo" :bar "bar"} nil)]
      (is (= "foobar!" (om/display-name c)))
      (is (= :init-state (om/init-state c)))
      (is (= :should-update (om/should-update c nil nil)))
      (is (= :will-mount (om/will-mount c)))
      (is (= :did-mount (om/did-mount c)))
      (is (= :will-unmount (om/will-unmount c)))
      (is (= :will-update (om/will-update c nil nil)))
      (is (= :did-update (om/did-update c nil nil)))
      (is (= :will-receive-props (om/will-receive-props c nil)))
      (is (= :render (om/render c)))
      (is (= :render-state (om/render-state c nil)))))
  (testing "schema error"
    (is (thrown? js/Error (test-component {:foo :bar :bar "bar"} nil)))
    (is (thrown? js/Error (test-component {:foo {} :bar "bar"} nil))))
  (testing "build constructor"
    (is (composite-component? (->test-component {:foo "foo" :bar "bar"})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk test-componentk
  [[:data foo bar] :- TestComponent owner]
  (display-name [_] (str foo bar "!"))
  (init-state [_] :init-state)
  (should-update [_ _ _] :should-update)
  (will-mount [_] :will-mount)
  (did-mount [_] :did-mount)
  (will-unmount [_] :will-unmount)
  (will-update [_ _ _] :will-update)
  (did-update [_ _ _] :did-update)
  (will-receive-props [_ _] :will-receive-props)
  (render [_] :render)
  (render-state [_ _] :render-state))

(deftest defcomponentk-test
  (testing "defs"
    (is (fn? test-componentk))
    (is (fn? ->test-componentk)))
  (testing "construct object w/ lifecycle protocols"
    (let [c (test-componentk {:foo "foo" :bar "bar"} nil)]
      (is (= "foobar!" (om/display-name c)))
      (is (= :init-state (om/init-state c)))
      (is (= :should-update (om/should-update c nil nil)))
      (is (= :will-mount (om/will-mount c)))
      (is (= :did-mount (om/did-mount c)))
      (is (= :will-unmount (om/will-unmount c)))
      (is (= :will-update (om/will-update c nil nil)))
      (is (= :did-update (om/did-update c nil nil)))
      (is (= :will-receive-props (om/will-receive-props c nil)))
      (is (= :render (om/render c)))
      (is (= :render-state (om/render-state c nil)))))
  (testing "schema error"
    (is (thrown? js/Error (test-componentk {:foo :bar :bar "bar"} nil)))
    (is (thrown? js/Error (test-componentk {:foo {} :bar "bar"} nil))))
  (testing "build constructor"
    (is (composite-component? (->test-componentk {:foo "foo" :bar "bar"})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk shared-data-component
  [[:shared api-host api-version]]
  (render [_]
    (dom/div (str api-host "/" api-version))))

(deftest defcomponentk-shared-test
  (with-element [e "div"]
    (om/root shared-data-component {}
             {:target e
              :shared {:api-host "api.example.com"
                       :api-version "1.5"}})
    (is (= "api.example.com/1.5" (.-innerText e)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk stateful-component [data state]
  (did-mount [_]
    (js/setTimeout #(swap! state assoc :y 2) 20))
  (render [_]
    (dom/div
     (let [{:keys [x y]} @state]
       (str "x=" x ",y=" (or y "nil"))))))

(deftest ^:async state-proxy-test
  (let [e (.createElement js/document "div")]
    (.. js/document -body (appendChild e))
    (om/root stateful-component {} {:target e :init-state {:x 5}})
    (is (= "x=5,y=nil" (.-innerText e)))
    (om/root stateful-component {} {:target e :state {:x 6}})
    (is (= "x=6,y=nil" (.-innerText e)))
    (js/setTimeout
     (fn []
       (testing "swapped on state"
         (is (= "x=6,y=2" (.-innerText e))))
       (done)
       (.. js/document -body (removeChild e)))
     60)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponent component-with-docstring
  "component docstring"
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-attr-map
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-docstring-and-attr-map
  "component docstring"
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-prepost-map
  [data owner]
  {:pre (constantly true) :post (constantly true)}
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-docstring
  "component docstring"
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-attr-map
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-docstring-and-attr-map
  "component docstring"
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-prepost-map
  [data owner]
  {:pre (constantly true) :post (constantly true)}
  (render [_] (dom/div nil "")))

(deftest defcomponent-args-test
  (are [component] (fn? component)
       component-with-docstring
       component-with-attr-map
       component-with-docstring-and-attr-map
       component-with-prepost-map
       componentk-with-docstring
       componentk-with-attr-map
       componentk-with-docstring-and-attr-map
       componentk-with-prepost-map))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmixin test-mixin
  (display-name [] :display-name)
  (init-state [] :init-state)
  (should-update [_ _] :should-update)
  (will-mount [] :will-mount)
  (did-mount [] :did-mount)
  (will-unmount [] :will-unmount)
  (will-update [_ _] :will-update)
  (did-update [_ _] :did-update)
  (will-receive-props [_] :will-receive-props))

(deftest defmixin-test
  (is (object? test-mixin))
  (is (= #{"getDisplayName"
           "getInitialState"
           "shouldComponentUpdate"
           "componentWillMount"
           "componentDidMount"
           "componentWillUnmount"
           "componentWillUpdate"
           "componentDidUpdate"
           "componentWillReceiveProps"}
         (set (js-keys test-mixin))))
  (is (every? fn? (map #(aget test-mixin %) (js-keys test-mixin))))
  (is :display-name
      (.getDisplayName test-mixin))
  (is :init-state
      (.getInitialState test-mixin))
  (is :should-update
      (.shouldComponentUpdate test-mixin nil nil))
  (is :will-mount
      (.componentWillMount test-mixin))
  (is :did-mount
      (.componentDidMount test-mixin))
  (is :will-unmount
      (.componentWillUnmount test-mixin))
  (is :will-update
      (.componentWillUpdate test-mixin nil nil))
  (is :did-update
      (.componentDidUpdate test-mixin nil nil))
  (is :will-receive-props
      (.componentWillReceiveProps test-mixin nil)))

(defmixin test-mixin2
  (will-mount [] (this-as this
                   (om/set-state! this :mixin-mounted? true))))

(defcomponent component-with-mixin [data owner]
  (:mixins [test-mixin2])
  (render-state [_ {:keys [mixin-mounted?]}]
    (dom/div nil (if mixin-mounted?
                   "mixin-mounted"))))

(defcomponent wrapper-component-with-mixin [data owner]
  (render [_]
    (->component-with-mixin {})))

(deftest defcomponent-defmixin-test
  (is (fn? component-with-mixin$ctor))
  (with-element [e "div"]
    (om/root component-with-mixin {}
             {:target e
              :ctor component-with-mixin$ctor})
    (is (= "mixin-mounted" (.-innerText e))))
  (with-element [e "div"]
    (om/root wrapper-component-with-mixin {}
             {:target e})
    (is (= "mixin-mounted" (.-innerText e)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftest set-state?!-test
  (let [mem (atom {})
        calls (atom {})
        owner (reify
                om/IGetState
                (-get-state [this]
                  @mem)
                (-get-state [this ks]
                  (get-in @mem ks))
                om/ISetState
                (-set-state! [this val]
                  (swap! calls update-in [::root] (fnil inc 0))
                  (reset! mem val))
                (-set-state! [this ks val]
                  (swap! calls update-in ks (fnil inc 0))
                  (swap! mem assoc-in ks val)))]
    (is (not (nil? (om-tools/set-state?! owner {:bar "bar"}))))
    (is (= 1 (::root @calls)))
    (is (nil? (om-tools/set-state?! owner {:bar "bar"})))
    (is (= 1 (::root @calls)))
    (is (not (nil? (om-tools/set-state?! owner :foo "foo"))))
    (is (= 1 (:foo @calls)))
    (is (nil? (om-tools/set-state?! owner :foo "foo")))
    (is (= 1 (:foo @calls)))
    (is (not (nil? (om-tools/set-state?! owner :foo "foo2"))))
    (is (= 2 (:foo @calls)))
    (is (not (nil? (om-tools/set-state?! owner [:baz :qux] 42))))
    (is (= 1 (get-in @calls [:baz :qux])))
    (is (nil? (om-tools/set-state?! owner [:baz :qux] 42)))
    (is (= 1 (get-in @calls [:baz :qux])))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(use-fixtures :once schema-test/validate-schemas)

(ns om-tools.core-test
  (:require-macros
   [cemerick.cljs.test :refer [is are deftest testing use-fixtures done]]
   [om-tools.test-utils :refer [with-element]]
   [schema.macros :as sm])
  (:require
   cemerick.cljs.test
   [clojure.set :as set]
   [om-tools.core :as om-tools :refer-macros [defcomponent defcomponentk defmixin]]
   [om-tools.dom :as dom :include-macros true]
   [om.core :as om]
   [schema.core :as s]
   [schema.test :as schema-test]))

(defn composite-component?
  "http://git.io/BPd6uw"
  [x]
  (and (fn? (aget x "render"))
       (fn? (aget x "setState"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(sm/defschema TestComponent
  {:foo s/Str :bar s/Str})

(defcomponent test-component
  [data :- TestComponent owner]
  (display-name [_] (str (:foo data) (:bar data) "!"))
  (init-state [_] :init-state)
  (should-update [_ _ _] :should-update)
  (will-mount [_] :will-mount)
  (did-mount [_] :did-mount)
  (will-unmount [_] :will-unmount)
  (will-update [_ _ _] :will-update)
  (did-update [_ _ _] :did-update)
  (will-receive-props [_ _] :will-receive-props)
  (render [_] :render)
  (render-state [_ _] :render-state))

(deftest defcomponent-test
  (testing "defs"
    (is (fn? test-component))
    (is (fn? ->test-component)))
  (testing "construct object w/ lifecycle protocols"
    (let [c (test-component {:foo "foo" :bar "bar"} nil)]
      (is (= "foobar!" (om/display-name c)))
      (is (= :init-state (om/init-state c)))
      (is (= :should-update (om/should-update c nil nil)))
      (is (= :will-mount (om/will-mount c)))
      (is (= :did-mount (om/did-mount c)))
      (is (= :will-unmount (om/will-unmount c)))
      (is (= :will-update (om/will-update c nil nil)))
      (is (= :did-update (om/did-update c nil nil)))
      (is (= :will-receive-props (om/will-receive-props c nil)))
      (is (= :render (om/render c)))
      (is (= :render-state (om/render-state c nil)))))
  (testing "schema error"
    (is (thrown? js/Error (test-component {:foo :bar :bar "bar"} nil)))
    (is (thrown? js/Error (test-component {:foo {} :bar "bar"} nil))))
  (testing "build constructor"
    (is (composite-component? (->test-component {:foo "foo" :bar "bar"})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk test-componentk
  [[:data foo bar] :- TestComponent owner]
  (display-name [_] (str foo bar "!"))
  (init-state [_] :init-state)
  (should-update [_ _ _] :should-update)
  (will-mount [_] :will-mount)
  (did-mount [_] :did-mount)
  (will-unmount [_] :will-unmount)
  (will-update [_ _ _] :will-update)
  (did-update [_ _ _] :did-update)
  (will-receive-props [_ _] :will-receive-props)
  (render [_] :render)
  (render-state [_ _] :render-state))

(deftest defcomponentk-test
  (testing "defs"
    (is (fn? test-componentk))
    (is (fn? ->test-componentk)))
  (testing "construct object w/ lifecycle protocols"
    (let [c (test-componentk {:foo "foo" :bar "bar"} nil)]
      (is (= "foobar!" (om/display-name c)))
      (is (= :init-state (om/init-state c)))
      (is (= :should-update (om/should-update c nil nil)))
      (is (= :will-mount (om/will-mount c)))
      (is (= :did-mount (om/did-mount c)))
      (is (= :will-unmount (om/will-unmount c)))
      (is (= :will-update (om/will-update c nil nil)))
      (is (= :did-update (om/did-update c nil nil)))
      (is (= :will-receive-props (om/will-receive-props c nil)))
      (is (= :render (om/render c)))
      (is (= :render-state (om/render-state c nil)))))
  (testing "schema error"
    (is (thrown? js/Error (test-componentk {:foo :bar :bar "bar"} nil)))
    (is (thrown? js/Error (test-componentk {:foo {} :bar "bar"} nil))))
  (testing "build constructor"
    (is (composite-component? (->test-componentk {:foo "foo" :bar "bar"})))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk shared-data-component
  [[:shared api-host api-version]]
  (render [_]
    (dom/div (str api-host "/" api-version))))

(deftest defcomponentk-shared-test
  (with-element [e "div"]
    (om/root shared-data-component {}
             {:target e
              :shared {:api-host "api.example.com"
                       :api-version "1.5"}})
    (is (= "api.example.com/1.5" (.-innerText e)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponentk stateful-component [data state]
  (did-mount [_]
    (js/setTimeout #(swap! state assoc :y 2) 20))
  (render [_]
    (dom/div
     (let [{:keys [x y]} @state]
       (str "x=" x ",y=" (or y "nil"))))))

(deftest ^:async state-proxy-test
  (let [e (.createElement js/document "div")]
    (.. js/document -body (appendChild e))
    (om/root stateful-component {} {:target e :init-state {:x 5}})
    (is (= "x=5,y=nil" (.-innerText e)))
    (om/root stateful-component {} {:target e :state {:x 6}})
    (is (= "x=6,y=nil" (.-innerText e)))
    (js/setTimeout
     (fn []
       (testing "swapped on state"
         (is (= "x=6,y=2" (.-innerText e))))
       (done)
       (.. js/document -body (removeChild e)))
     60)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcomponent component-with-docstring
  "component docstring"
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-attr-map
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-docstring-and-attr-map
  "component docstring"
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponent component-with-prepost-map
  [data owner]
  {:pre (constantly true) :post (constantly true)}
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-docstring
  "component docstring"
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-attr-map
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-docstring-and-attr-map
  "component docstring"
  {:attr true}
  [data owner]
  (render [_] (dom/div nil "")))

(defcomponentk componentk-with-prepost-map
  [data owner]
  {:pre (constantly true) :post (constantly true)}
  (render [_] (dom/div nil "")))

(deftest defcomponent-args-test
  (are [component] (fn? component)
       component-with-docstring
       component-with-attr-map
       component-with-docstring-and-attr-map
       component-with-prepost-map
       componentk-with-docstring
       componentk-with-attr-map
       componentk-with-docstring-and-attr-map
       componentk-with-prepost-map))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmixin test-mixin
  (display-name [] :display-name)
  (init-state [] :init-state)
  (should-update [x y] [:should-update x y])
  (will-mount [] :will-mount)
  (did-mount [] :did-mount)
  (will-unmount [] :will-unmount)
  (will-update [x y] [:will-update x y])
  (did-update [x y] [:did-update x y])
  (will-receive-props [x] [:will-receive-props x]))

(deftest defmixin-test
  (is (object? test-mixin))
  (is (= #{"getDisplayName"
           "getInitialState"
           "shouldComponentUpdate"
           "componentWillMount"
           "componentDidMount"
           "componentWillUnmount"
           "componentWillUpdate"
           "componentDidUpdate"
           "componentWillReceiveProps"}
         (set (js-keys test-mixin))))
  (is (every? fn? (map #(aget test-mixin %) (js-keys test-mixin))))
  (is (= :display-name
         (.getDisplayName test-mixin)))
  (is (= :init-state
         (.getInitialState test-mixin)))
  (is (= [:should-update :next-props :next-state]
         (.shouldComponentUpdate test-mixin :next-props :next-state)))
  (is (= :will-mount
         (.componentWillMount test-mixin)))
  (is (= :did-mount
         (.componentDidMount test-mixin)))
  (is (= :will-unmount
         (.componentWillUnmount test-mixin)))
  (is (= [:will-update :next-props :next-state]
         (.componentWillUpdate test-mixin :next-props :next-state)))
  (is (= [:did-update :prev-props :prev-state]
         (.componentDidUpdate test-mixin :prev-props :prev-state)))
  (is (= [:will-receive-props :next-props]
         (.componentWillReceiveProps test-mixin :next-props))))

(defmixin test-mixin2
  (will-mount [] (this-as this
                   (om/set-state! this :mixin-mounted? true))))

(defcomponent component-with-mixin [data owner]
  (:mixins [test-mixin2])
  (render-state [_ {:keys [mixin-mounted?]}]
    (dom/div nil (if mixin-mounted?
                   "mixin-mounted"))))

(defcomponent wrapper-component-with-mixin [data owner]
  (render [_]
    (->component-with-mixin {})))

(deftest defcomponent-defmixin-test
  (is (fn? component-with-mixin$ctor))
  (with-element [e "div"]
    (om/root component-with-mixin {}
             {:target e
              :ctor component-with-mixin$ctor})
    (is (= "mixin-mounted" (.-innerText e))))
  (with-element [e "div"]
    (om/root wrapper-component-with-mixin {}
             {:target e})
    (is (= "mixin-mounted" (.-innerText e)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftest set-state?!-test
  (let [mem (atom {})
        calls (atom {})
        owner (reify
                om/IGetState
                (-get-state [this]
                  @mem)
                (-get-state [this ks]
                  (get-in @mem ks))
                om/ISetState
                (-set-state! [this val]
                  (swap! calls update-in [::root] (fnil inc 0))
                  (reset! mem val))
                (-set-state! [this ks val]
                  (swap! calls update-in ks (fnil inc 0))
                  (swap! mem assoc-in ks val)))]
    (is (not (nil? (om-tools/set-state?! owner {:bar "bar"}))))
    (is (= 1 (::root @calls)))
    (is (nil? (om-tools/set-state?! owner {:bar "bar"})))
    (is (= 1 (::root @calls)))
    (is (not (nil? (om-tools/set-state?! owner :foo "foo"))))
    (is (= 1 (:foo @calls)))
    (is (nil? (om-tools/set-state?! owner :foo "foo")))
    (is (= 1 (:foo @calls)))
    (is (not (nil? (om-tools/set-state?! owner :foo "foo2"))))
    (is (= 2 (:foo @calls)))
    (is (not (nil? (om-tools/set-state?! owner [:baz :qux] 42))))
    (is (= 1 (get-in @calls [:baz :qux])))
    (is (nil? (om-tools/set-state?! owner [:baz :qux] 42)))
    (is (= 1 (get-in @calls [:baz :qux])))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(use-fixtures :once schema-test/validate-schemas)

Fix mixin test

Fix mixin test

Assertions were missing equality check


(ns selmer.test-parser)

(declare parse expr-tag)

(defn render [template params]
  (->> (for [element template]
         (if (string? element) element (element params)))
       (apply str)))

(defn read-char [rdr]
  (let [ch (.read rdr)]
    (if-not (neg? ch) (char ch))))

(defn peek-stream [rdr size]
  (.mark rdr size)
  (let [result (loop [items []]
                 (let [ch (read-char rdr)]
                   (if (and ch (< (count items) size))
                     (recur (conj items ch))
                     items)))]
    (.reset rdr)
    result))

(defn value-tag [{:keys [tag-value]}]
  (let [value (map keyword (.split tag-value "\\."))]
    (fn [params] (get-in params value))))

#_((value-tag {:tag-value "foo.bar.baz"}) {:foo {:bar {:baz "ok"}}})
#_((value-tag {:tag-value "foo"}) {:foo "ok"})

(defn read-tag-info [rdr]
  (let [buf (StringBuilder.)
        tag-type (if (= \{(read-char rdr)) :value :expr)]
    (loop [ch1 (read-char rdr)
           ch2 (read-char rdr)]
      (when-not (and (or  (= \% ch1) (= \} ch1)) (= \} ch2))
        (.append buf ch1)
        (recur ch2 (read-char rdr))))
    (let [content (->>  (.split (.toString buf ) " ") (remove empty?) (map (memfn trim)))]
      (merge {:tag-type tag-type}
             (if (= :value tag-type)
               {:tag-value (first content)}
               {:tag-name (first content)
                :params (rest content)})))))

#_(read-tag-info (java.io.StringReader. "% for i in nums %}"))
#_(read-tag-info (java.io.StringReader. "{ nums }}"))

(defn tag-content [close-tag rdr]
  (let [content (transient [])
        buf (StringBuilder.)]
    (loop [ch (read-char rdr)]
      (if (= \{ ch)
        (let [{:keys [tag-name tag-type] :as tag} (read-tag-info rdr)]
          (when (not= close-tag tag-name)
            (println tag)
            (conj! content (.toString buf))
            (.setLength buf 0)
            (conj! content (if (= :value tag-type)
                             (value-tag tag)
                             (expr-tag tag rdr)))
            (recur (read-char rdr))))
        (do
          (.append buf ch)
          (recur (read-char rdr)))))
    (conj! content (.toString buf))
    (persistent! content)))

#_(tag-content "endfor" (java.io.StringReader. "foo {{name}} bar {% endfor %}"))

#_(render (tag-content "endfor" (java.io.StringReader. "foo {{name.first}} bar {% endfor %}")) {:name {:first "Bob"}})

(def expr-tags
  {:for {:content true
         :close-tag "endfor"}})

(defn expr-tag [{:keys [tag-name params]} rdr]
  (let [{:keys [content close-tag]} (get expr-tags tag-name)]
    (if content
      (tag-content close-tag rdr))))

(defn handle-tag [rdr]
  (let [tag (read-tag-info rdr)]
    ((if (:value tag) value-tag expr-tag) tag)))

(defn parse [file & state]
  (with-open [rdr (clojure.java.io/reader file)]
      (let [template (transient [])
            sb (StringBuilder.)]
        (loop [state state
               ch (.read rdr)]
          (when (pos? ch)
            (let [ch (char ch)]
              (if (= \{ ch)
                (do
                  (conj! template (.toString sb))
                  (.setLength sb 0)
                  (conj! template (handle-tag rdr))
                  (recur state (.read rdr)))
                (do
                  (.append sb ch)
                  (recur state (.read rdr)))))))
        (persistent! template))))

#_(render (parse "home.html") {:name "Bob"})

(ns selmer.test-parser)

(declare parse expr-tag)

(defn render [template params]
  (->> (for [element template]
         (if (string? element) element (element params)))
       (apply str)))

(defn read-char [rdr]
  (let [ch (.read rdr)]
    (if-not (neg? ch) (char ch))))

(defn peek-stream [rdr size]
  (.mark rdr size)
  (let [result (loop [items []]
                 (let [ch (read-char rdr)]
                   (if (and ch (< (count items) size))
                     (recur (conj items ch))
                     items)))]
    (.reset rdr)
    result))

(defn value-tag [{:keys [tag-value]}]
  (let [value (map keyword (.split tag-value "\\."))]
    (fn [params] (get-in params value))))

#_((value-tag {:tag-value "foo.bar.baz"}) {:foo {:bar {:baz "ok"}}})
#_((value-tag {:tag-value "foo"}) {:foo "ok"})
;ok

(defn read-tag-info [rdr]
  (let [buf (StringBuilder.)
        tag-type (if (= \{(read-char rdr)) :value :expr)]
    (loop [ch1 (read-char rdr)
           ch2 (read-char rdr)]
      (when-not (and (or  (= \% ch1) (= \} ch1)) (= \} ch2))
        (.append buf ch1)
        (recur ch2 (read-char rdr))))
    (let [content (->>  (.split (.toString buf ) " ") (remove empty?) (map (memfn trim)))]
      (merge {:tag-type tag-type}
             (if (= :value tag-type)
               {:tag-value (first content)}
               {:tag-name (first content)
                :params (rest content)})))))

#_(read-tag-info (java.io.StringReader. "% for i in nums %}"))
;{:params ("i" "in" "nums"), :tag-name "for", :tag-type :expr}

#_(read-tag-info (java.io.StringReader. "{ nums }}"))
;{:tag-value "nums", :tag-type :value}

(defn tag-content [close-tag rdr]
  (let [content (transient [])
        buf (StringBuilder.)]
    (loop [ch (read-char rdr)]
      (if (= \{ ch)
        (let [{:keys [tag-name tag-type] :as tag} (read-tag-info rdr)]
          (when (not= close-tag tag-name)
            (println tag)
            (conj! content (.toString buf))
            (.setLength buf 0)
            (conj! content (if (= :value tag-type)
                             (value-tag tag)
                             (expr-tag tag rdr)))
            (recur (read-char rdr))))
        (do
          (.append buf ch)
          (recur (read-char rdr)))))
    (conj! content (.toString buf))
    (persistent! content)))

#_(tag-content "endfor" (java.io.StringReader. "foo {{name}} bar {% endfor %}"))

#_(render (tag-content "endfor" (java.io.StringReader. "foo {{name.first}} bar {% endfor %}")) {:name {:first "Bob"}})
;"foo Bob bar "

(def expr-tags
  {:for {:content true
         :close-tag "endfor"}})

(defn expr-tag [{:keys [tag-name params]} rdr]
  (let [{:keys [content close-tag]} (get expr-tags tag-name)]
    (if content
      (tag-content close-tag rdr))))

(defn handle-tag [rdr]
  (let [tag (read-tag-info rdr)]
    ((if (:value tag) value-tag expr-tag) tag)))

(defn parse [file & state]
  (with-open [rdr (clojure.java.io/reader file)]
      (let [template (transient [])
            sb (StringBuilder.)]
        (loop [state state
               ch (.read rdr)]
          (when (pos? ch)
            (let [ch (char ch)]
              (if (= \{ ch)
                (do
                  (conj! template (.toString sb))
                  (.setLength sb 0)
                  (conj! template (handle-tag rdr))
                  (recur state (.read rdr)))
                (do
                  (.append sb ch)
                  (recur state (.read rdr)))))))
        (persistent! template))))

#_(render (parse "home.html") {:name "Bob"})

Update test_parser.clj

Update test_parser.clj


(ns egg.core
  (:require [clojure.tools.cli :refer [parse-opts]]
            [clojure.string :as string])
  (:gen-class))

;; options

(def egg-options
  [;; First three strings describe a short-option, long-option with optional
   ;; example argument description, and a description. All three are optional
   ;; and positional.
   ["-h" "--help"]
   ["-v" "--version"]])

(def validate-options
  [["-h" "--help"]
   ["-p" "--path PATH"]])

;; commands

(defn validate! [options]
  (println options))

;; help

(defn usage [options-summary]
  (->> ["usage: egg [command] [options]"
        ""
        "Options:"
        options-summary
        ""
        "Commands are:"
        "  validate Validate an egg"
        ""
        "See 'egg <command> -h' to read about a specific command."]
       (string/join \newline)))

(defn cmd-usage [cmd options-summary]
  (->> [(str "Name: " cmd)
        ""
        "Options:"
        options-summary]
       (string/join \newline)))

(defn error-msg [errors]
  (str "The following errors occurred while parsing your command:\n\n"
       (string/join \newline errors)))

(defn exit [status msg]
  (println msg))
;;(System/exit status))

;; running

(defn do-cmd! [cmd name cli-options args]
  (let [{:keys [options arguments errors summary]} (parse-opts args cli-options)]
    (cond
     (:help options) (exit 0 (cmd-usage name summary))
     errors (exit 1 (error-msg errors))
     :else (cmd options))))

(defn -main [& args]
  (let [{:keys [options arguments errors summary]} (parse-opts args egg-options :in-order true)]
    (cond
     (:help options) (exit 0 (usage summary))
     (:version options) (exit 0 "Egg version 0.1.0")
     errors (exit 1 (error-msg errors))
     :else (let [cmd-with-args (first arguments)
                 [cmd & cmd-args] (string/split cmd-with-args #" ")]
             (case cmd
               "validate" (do-cmd! validate! "validate" validate-options cmd-args)
               nil (exit 0 (usage summary))
               (exit 1 (error-msg [(str "Unrecognised command: " cmd)
                                   ""
                                   "See 'egg -h' for available commands."])))))))

(ns egg.core
  (:require [clojure.tools.cli :refer [parse-opts]]
            [clojure.string :as string]
            [egg.validate :as validate])
  (:gen-class))

;; options

(def egg-options
  [;; First three strings describe a short-option, long-option with optional
   ;; example argument description, and a description. All three are optional
   ;; and positional.
   ["-h" "--help"]
   ["-v" "--version"]])

(def validate-options
  [["-h" "--help"]
   ["-u" "--uri URI"]])

;; commands

(defn validate! [name options]
  (validate/eggy? (:path options)))

;; help

(defn usage [options-summary]
  (->> ["usage: egg [command] [options]"
        ""
        "Options:"
        options-summary
        ""
        "Commands are:"
        "  validate Validate an egg"
        ""
        "See 'egg <command> -h' to read about a specific command."]
       (string/join \newline)))

(defn cmd-usage [cmd options-summary]
  (->> [(str "Name: " cmd)
        ""
        "Options:"
        options-summary]
       (string/join \newline)))

(defn error-msg [errors]
  (str "The following errors occurred while parsing your command:\n\n"
       (string/join \newline errors)))

(defn exit [status msg]
  (println msg))
;;(System/exit status))

;; running

(defn do-cmd! [cmd name cli-options args]
  (let [{:keys [options arguments errors summary]} (parse-opts args cli-options)]
    (cond
     (:help options) (exit 0 (cmd-usage name summary))
     errors (exit 1 (error-msg errors))
     :else (cmd options))))

(defn -main [& args]
  (let [{:keys [options arguments errors summary]} (parse-opts args egg-options :in-order true)]
    (cond
     (:help options) (exit 0 (usage summary))
     (:version options) (exit 0 "Egg version 0.1.0")
     errors (exit 1 (error-msg errors))
     :else (let [cmd-with-args (first arguments)
                 [cmd & cmd-args] (string/split cmd-with-args #" ")]
             (case cmd
               "validate" (do-cmd! validate! "validate" validate-options cmd-args)
               nil (exit 0 (usage summary))
               (exit 1 (error-msg [(str "Unrecognised command: " cmd)
                                   ""
                                   "See 'egg -h' for available commands."])))))))

Fix validate

Fix validate


(ns gui.main
  (require [seesaw.core :refer :all]
           [seesaw.rsyntax :as syntax]
           [seesaw.dev :refer (show-options)]
           [seesaw.tree :refer (simple-tree-model)]
           [logic.util :as logic])
  (import [java.io File]
          [gui Node]
          [org.fife.ui.rsyntaxtextarea TokenMakerFactory DefaultTokenMakerFactory]))

(native!)

; register own editor parser for highlighting
(let [tmf (TokenMakerFactory/getDefaultInstance)]
  (.putMapping tmf "text/mpa" "fully.qualified.MpaTokenMaker"))

(def test-tree
  (Node. "Project_1" (list
                       (Node. "Formel_1" "a&b")
                       (Node. "Formel_2" "a->b"))))

; tree-model
(def tree-model
  (simple-tree-model
    #(.getChildren %)
    #(.getChildren %)
    test-tree))

; result handling
; this must be placed here, so it can be accessed from handler.clj
(def results-start (scrollable
                     (text
                       :text "Welcome to the Logic Workbench"
                       :multi-line? true
                       :editable? false)
                     :preferred-size [690 :by 200]))

(def results (flow-panel
               :id :res
               :align :left
               :items [results-start]))

; LOADING OF OTHER FILES
(declare editor)

(load "tools")
(load "handler")
(load "menus")

; final window building
(def form-tree (scrollable (tree
                             :id :tree
                             :model tree-model
                             )
                           :preferred-size [255 :by 600]
                           :maximum-size [255 :by 32000]))

(def editor (syntax/text-area :syntax :mpa))
(def form-editor (scrollable editor
                             :preferred-size [690 :by 400]))

(def ver-panel (vertical-panel
                 :items [form-editor
                         results]))

(def hor-panel (horizontal-panel
                 :items [form-tree
                         ver-panel]))

(def main-panel (border-panel
                  :north tool-bar
                  :center hor-panel))

(def main-frame (frame
                  :title "Logical Workbench"
                  :on-close :exit
                  :size [980 :by 600]
                  :content main-panel
                  :menubar (menubar
                             :items [project-menu
                                     tasks-menu
                                     options-menu
                                     help-menu])))

; we're rolling!
(-> main-frame pack! show!)

(ns gui.main
  (require [seesaw.core :refer :all]
           [seesaw.rsyntax :as syntax]
           [seesaw.dev :refer (show-options)]
           [seesaw.tree :refer (simple-tree-model)]
           [logic.util :as logic])
  (import [java.io File]
          [gui Node]
          [org.fife.ui.rsyntaxtextarea TokenMakerFactory DefaultTokenMakerFactory]))

(native!)

; register own editor parser for highlighting
(let [tmf (TokenMakerFactory/getDefaultInstance)]
  (.putMapping tmf "text/mpa" "fully.qualified.MpaTokenMaker"))

; result handling
; this must be placed here, so it can be accessed from handler.clj
(def results-start (scrollable
                     (text
                       :text "Welcome to the Logic Workbench"
                       :multi-line? true
                       :editable? false)
                     :preferred-size [690 :by 200]))

(def results (flow-panel
               :id :res
               :align :left
               :items [results-start]))

; LOADING OF OTHER FILES
(declare editor)

(load "tools")
(load "handler")
(load "menus")

; project file tree
(def test-tree
  (Node. "Project_1" (list
                       (Node. "Formel_1" "a&b")
                       (Node. "Formel_2" "a->b"))))

(def tree-model
  (simple-tree-model
    #(.getChildren %)
    #(.getChildren %)
    test-tree))

(def form-tree (scrollable (tree
                             :id :tree
                             :model tree-model
                             )
                           :preferred-size [255 :by 600]
                           :maximum-size [255 :by 32000]))

; final window building
(def editor (syntax/text-area :syntax :mpa))
(def form-editor (scrollable editor
                             :preferred-size [690 :by 400]))

(def ver-panel (vertical-panel
                 :items [form-editor
                         results]))

(def hor-panel (horizontal-panel
                 :items [form-tree
                         ver-panel]))

(def main-panel (border-panel
                  :north tool-bar
                  :center hor-panel))

(def main-frame (frame
                  :title "Logical Workbench"
                  :on-close :exit
                  :size [980 :by 600]
                  :content main-panel
                  :menubar (menubar
                             :items [project-menu
                                     tasks-menu
                                     options-menu
                                     help-menu])))

; we're rolling!
(-> main-frame pack! show!)

structure of main.clj organised

Gui: structure of main.clj organised


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

(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
         (do
           (Thread/sleep 1000)
           (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))))

Add delay on health check

Add delay on health check