(ns qcast.cache
  (:gen-class)
  (:require [qcast.db        :as db]
            [taoensso.timbre :as timbre :refer :all]))

;;; Globals
(defonce ^:private db-spec (db/sqlite))

;;; Internals
(defn- pre-process [row]
  (-> row
      (update-in [:data] db/from-edn)
      (update-in [:publish_date] db/from-inst)))

(defn- post-process [row]
  (-> row
      (update-in [:publish_date] db/to-inst)
      (update-in [:data] db/to-edn)))

;;; Interface

(defn init []
  (info "Initializing cache")
  (db/create-table db-spec :presentations
                   [:id :TEXT "PRIMARY KEY" "NOT NULL"]
                   [:creation_date :DATETIME "NOT NULL" "DEFAULT CURRENT_TIMESTAMP"]
                   [:publish_date :DATETIME "NOT NULL"]
                   [:data :BLOB "NOT NULL"]))

(defn put [item]
  (try ;; Protect against existing entries
    (->> {:id (:id item), :publish_date (:publish-date item), :data item}
         pre-process
         (db/insert db-spec :presentations))
    (catch java.sql.SQLException e
      (warn "Presentation already exists" item))))

(defn lookup [id]
  (map post-process (db/select' db-spec :presentations (db/where {:id id}))))

(defn latest
  ([] (first (latest 1)))
  ([n]
    (map post-process (db/select' db-spec * :presentations
                                  (db/order-by {:publish_date :desc})
                                  (db/limit n)))))

(ns qcast.cache
  (:gen-class)
  (:require [qcast.db        :as db]
            [taoensso.timbre :as timbre :refer :all]))

;;; Globals
(defonce ^:private db-spec (db/sqlite))

;;; Internals
(defn- pre-process [row]
  (-> row
      (update-in [:data] db/from-edn)
      (update-in [:publish_date] db/from-inst)))

(defn- post-process [row]
  (-> row
      (update-in [:publish_date] db/to-inst)
      (update-in [:data] db/to-edn)))

;;; Interface

(defn init []
  (info "Initializing cache")
  (db/create-table db-spec :presentations
                   [:id :TEXT "PRIMARY KEY" "NOT NULL"]
                   [:creation_date :DATETIME "NOT NULL" "DEFAULT CURRENT_TIMESTAMP"]
                   [:publish_date :DATETIME "NOT NULL"]
                   [:data :BLOB "NOT NULL"]))

(defn put [item]
  (try ;; Protect against existing entries
    (->> {:id (:id item), :publish_date (:publish-date item), :data item}
         pre-process
         (db/insert db-spec :presentations))
    (catch java.sql.SQLException e
      (warn "Presentation already exists" item))))

(defn lookup [id]
  (map post-process (db/select' db-spec :presentations (db/where {:id id}))))

(defn latest
  ([] (first (latest 1)))
  ([n]
    (map post-process (db/select' db-spec * :presentations
                                  (db/order-by [{:publish_date :desc}
                                                {:creation_date :desc}])
                                  (db/limit n)))))

Fix latest item sorting

Fix latest item sorting


(ns demogorgon.core
  (:import [org.apache.log4j Logger]
           [java.util Random])
  (:require [tachyon.core :as irc])
  (:require [tachyon.hooks :as irc-hooks])
  (:use [clj-stacktrace core repl]
        [demogorgon.config]
        [demogorgon.unicode :only (unicode-hook)]
        [demogorgon.web :only (start-web stop-web)]
        [demogorgon.nh :only (online-players-hook last-dump-hook whereis-hook nh-start nh-init nh-stop)])
  (:gen-class))

(def logger (Logger/getLogger "demogorgon.core"))

(defn get-memory-info []
  (let [runtime (Runtime/getRuntime)
        total (int (/ (.totalMemory runtime) 1048576))
        free (int (/ (.freeMemory runtime) 1048576))
        max (int (/ (.maxMemory runtime) 1048576))
        used (- total free)]
    (str "used " used " free " free " total " total " max " max)))

(defn print-debug []
  (.debug logger (str "before " (get-memory-info)))
  (.gc (Runtime/getRuntime))
  (.debug logger (str "after  " (get-memory-info))))

(defn rand-hook [irc object match]
  (let [words (.split (second match) " ")
        random (Random.)
        idx (.nextInt random (alength words))
        word (aget words idx)]
    word))

(defn create []
  (let [irc (irc/create (:irc config))]
    {:connection irc
    :nh (nh-init irc)
    :web (ref nil)}))

(defn start [bot]
  (let [logger (Logger/getLogger "main")]
    (nh-start (:nh bot))

    (irc-hooks/add-message-hook (:connection bot) #"^\.rng (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.rnd (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.random (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) ".debug" (fn [& rest] (get-memory-info)))
    (irc-hooks/add-message-hook (:connection bot) ".gc" (fn [& rest] (.gc (Runtime/getRuntime))))
    (irc-hooks/add-message-hook (:connection bot) #"^\.u ?(.*)?" #'unicode-hook)
    (irc-hooks/add-message-hook (:connection bot) ".cur" #'online-players-hook)
    (irc-hooks/add-message-hook (:connection bot) ".online" #'online-players-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.last ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.lastdump ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.lasturl ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.whereis ?(.*)?" #'whereis-hook)
    (irc/connect (:connection bot))
    (dosync
     (ref-set (:web bot) (start-web)))))

(defn -main[& args]
  (try
    (start (create))
    (catch Exception e
      (pst e))))

(ns demogorgon.core
  (:import [org.apache.log4j Logger]
           [java.util Random])
  (:require [tachyon.core :as irc])
  (:require [tachyon.hooks :as irc-hooks])
  (:require [clj-stacktrace.repl :as stacktrace])
  (:use [demogorgon.config]
        [demogorgon.unicode :only (unicode-hook)]
        [demogorgon.web :only (start-web stop-web)]
        [demogorgon.nh :only (online-players-hook last-dump-hook whereis-hook nh-start nh-init nh-stop)])
  (:gen-class))

(def logger (Logger/getLogger "demogorgon.core"))

(defn get-memory-info []
  (let [runtime (Runtime/getRuntime)
        total (int (/ (.totalMemory runtime) 1048576))
        free (int (/ (.freeMemory runtime) 1048576))
        max (int (/ (.maxMemory runtime) 1048576))
        used (- total free)]
    (str "used " used " free " free " total " total " max " max)))

(defn print-debug []
  (.debug logger (str "before " (get-memory-info)))
  (.gc (Runtime/getRuntime))
  (.debug logger (str "after  " (get-memory-info))))

(defn rand-hook [irc object match]
  (let [words (.split (second match) " ")
        random (Random.)
        idx (.nextInt random (alength words))
        word (aget words idx)]
    word))

(defn create []
  (let [irc (irc/create (:irc config))]
    {:connection irc
    :nh (nh-init irc)
    :web (ref nil)}))

(defn start [bot]
  (let [logger (Logger/getLogger "main")]
    (nh-start (:nh bot))

    (irc-hooks/add-message-hook (:connection bot) #"^\.rng (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.rnd (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.random (.+)" #'rand-hook)
    (irc-hooks/add-message-hook (:connection bot) ".debug" (fn [& rest] (get-memory-info)))
    (irc-hooks/add-message-hook (:connection bot) ".gc" (fn [& rest] (.gc (Runtime/getRuntime))))
    (irc-hooks/add-message-hook (:connection bot) #"^\.u ?(.*)?" #'unicode-hook)
    (irc-hooks/add-message-hook (:connection bot) ".cur" #'online-players-hook)
    (irc-hooks/add-message-hook (:connection bot) ".online" #'online-players-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.last ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.lastdump ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.lasturl ?(.*)?" #'last-dump-hook)
    (irc-hooks/add-message-hook (:connection bot) #"^\.whereis ?(.*)?" #'whereis-hook)
    (irc/connect (:connection bot))
    (dosync
     (ref-set (:web bot) (start-web)))))

(defn -main[& args]
  (try
    (start (create))
    (catch Exception e
      (stacktrace/pst e))))

Use require with clj-stacktrace

Use require with clj-stacktrace


(ns detritus.update
  "A collection of helper functions useful for updating and
  conditionally updating datastructures.")

(defn map-vals
  "λ {A → B} → (λ B → more* → C) → more* → {A → C}

  Computes a new map from m preserving the keys of m, but mapping the
  keys of m to (apply f (get m k) args)."
  [m f & args]
  (->> (for [[k v] m]
       [k (apply f v args)])
     (into {})))

(defn fix
  "λ (fn T → T) → T → T

  Eagerly computes the fixed point combinator of the input function
  and value. As this computation is eager, it will terminate only when
  a fixed point is reached which may be never."
  [f dat]
  (let [dat' (f dat)]
    (if (= dat dat')
      dat
      (recur f dat'))))

(defn update
  "λ {A → B} → A → (λ B → args* → C) → args* → {A → C}

  Updates a key in the map by applying f to the value at that key more
  arguments, returning the resulting map."
  [map key f & args]
  (assoc map key
         (apply f (get map key) args)))

(defn ->when-update
  "Function of a value, a predicate, an updater and optional
  varargs. If the predicate is true of the value, returns (apply f x
  args), otherwise returns x.

  Example:
    (-> 1 (->when-update #(<= 0 %) inc))"
  [x pred f & args]
  (if (pred x)
    (apply f x args)
    x))

(defn ->>when-update
  "Function of a predicate, an updater, optional varargs and a
  value. If the predicate is true of the value, returns (apply f x
  args), otherwise returns x.

  Example:
    (->> 1 (->>when-update #(<= 0 %) inc))"
  [pred f & args]
  (let [x    (last args)
        args (butlast args)]
    (if (pred x)
      (apply f x args)
      x)))

(ns detritus.update
  "A collection of helper functions useful for updating and
  conditionally updating datastructures.")

;; Mapping update operations
;;--------------------------------------------------------------------

(defn map-vals
  "λ {A → B} → (λ B → more* → C) → more* → {A → C}

  Computes a new map from m preserving the keys of m, but mapping the
  keys of m to (apply f (get m k) args)."
  [m f & args]
  (->> (for [[k v] m]
       [k (apply f v args)])
     (into {})))

(defn map-keys
  "Create a new map from m by calling function f on each key to get a
  new key."
  [m f & args]
  (when m
    (into {}
          (for [[k v] m]
            (map-entry (apply f k args) v)))))

(defn map-vals-with-keys
  "Create a new map from m by calling function f, with two
  arguments (the key and value) to get a new value."
  [m f & args]
  (when m
    (into {}
          (for [[k v] m]
            (map-entry k (apply f k v args))))))

(defn map-keys-and-vals
  "Create a new map from m by calling function f on each key & each
  value to get a new key & value"
  [m f & args]
  (when m
    (into {}
          (for [[k v] m]
            (map-entry (apply f k args) (apply f v args))))))

(defn fix
  "λ (fn T → T) → T → T

  Eagerly computes the fixed point combinator of the input function
  and value. As this computation is eager, it will terminate only when
  a fixed point is reached which may be never."
  [f dat]
  (let [dat' (f dat)]
    (if (= dat dat')
      dat
      (recur f dat'))))

(defn update
  "λ {A → B} → A → (λ B → args* → C) → args* → {A → C}

  Updates a key in the map by applying f to the value at that key more
  arguments, returning the resulting map."
  [map key f & args]
  (assoc map key
         (apply f (get map key) args)))

;; Conditional update operations
;;--------------------------------------------------------------------

(defn ->when-update
  "Function of a value, a predicate, an updater and optional
  varargs. If the predicate is true of the value, returns (apply f x
  args), otherwise returns x.

  Example:
    (-> 1 (->when-update #(<= 0 %) inc))"
  [x pred f & args]
  (if (pred x)
    (apply f x args)
    x))

(defn ->>when-update
  "Function of a predicate, an updater, optional varargs and a
  value. If the predicate is true of the value, returns (apply f x
  args), otherwise returns x.

  Example:
    (->> 1 (->>when-update #(<= 0 %) inc))"
  [pred f & args]
  (let [x    (last args)
        args (butlast args)]
    (if (pred x)
      (apply f x args)
      x)))

Add a bunch of handy update uperations

Add a bunch of handy update uperations


(ns edu.berkeley.ai.util.traits
  (:require [edu.berkeley.ai.util :as util]))

(defn- parse-protocols-and-method-pairs [args]
  (when (seq args)
    (let [[proto & rest] args
          [methods more] (split-with coll? rest)]
      (assert (symbol? proto))
      (cons [proto methods]
            (parse-protocols-and-method-pairs more)))))

(defn rewrite-pm-pair [ns args [proto method]]
;  (println ns args proto method)
  (let [method-name    (first method)
        method-args    (second method)
        method-body    (next (next method))
        all-args       (vec (concat method-args args))
        fn-name        (gensym (str proto "-" method-name))
        scoped-fn-name (symbol ns (name fn-name))]
    (assert (apply distinct? (cons nil all-args)))
    [(symbol ns (name proto))
     `(~method-name ~method-args (~scoped-fn-name ~@all-args))
     `(defn ~fn-name ~all-args (loop ~(vec (interleave (next method-args) (next method-args))) ~@method-body))]))
;; Loop allows proper recur semantics ...

(defn- parse-protocols-and-methods [args specs]
  (let [methods-by-proto (parse-protocols-and-method-pairs specs)
        ns               (name (ns-name *ns*))
        pm-pairs         (for [[p ms] methods-by-proto, m ms] [p m])
;        _ (println pm-pairs)
        pm-triples       (map #(rewrite-pm-pair ns args %) pm-pairs)]
    (assert (apply distinct? (cons nil (map first methods-by-proto))))
    [(map #(nth % 2) pm-triples)
     (util/map-vals #(map second %) (group-by first pm-triples))]))

(defn merge-traits [& traits]
  (let [bindings  (vec (apply concat (map first traits)))]
    (assert (apply distinct? (cons nil (take-nth 2 bindings))))
    [bindings
     (reduce util/merge-disjoint {} (map second traits))]))

;; To allow traits to be used from other namespaces, easiest option is to emit named fns in defining ns ?

(defn parse-trait-form [traits]
  (vec (map #(if (list? %)
               (cons (first %) (map (fn [x] `'~x) (rest %)))
               (list %)) traits)))

;; Internal rep. of a trait is a fn from args to [binding-seq impl-map]
;; TODO: forn ow, args may be multiple evaluated?
(defmacro deftrait [name args state-bindings child-traits & protocols-and-methods]
  (let [[method-fn-defs protocol-method-bodies]
        (parse-protocols-and-methods (concat args (take-nth 2 state-bindings)) protocols-and-methods)]
;    (println method-fn-defs "\n" protocol-method-bodies)
    `(do (defn ~name ~args
           (apply merge-traits
                  [(concat (interleave '~args ~args) '~state-bindings)
                   '~protocol-method-bodies]
                  ~(parse-trait-form child-traits)))
         ~@method-fn-defs)))

(defn- render-trait-methods-inline [trait-map]
  (apply concat (map (partial apply cons) trait-map)))

(defmacro reify-traits [[& traits] & specs]
  (let [[trait-bindings trait-methods] (apply merge-traits (eval (parse-trait-form traits)))]
    `(let ~trait-bindings
       (reify
        ~@(render-trait-methods-inline trait-methods)
        ~@specs))))

(do #_comment

 (defprotocol P2
   (p21 [x y])
   (p22 [x]))

 (defprotocol P1
   (p11 [x y]))

 (defprotocol P0)

 (deftrait +foo+ [x] [y (atom x)] [] P2 (p21 [foo z] (+ z @y)) (p22 [foo] (swap! y inc)) P0)

                                        ; (deftrait +bar+ [w] [z (inc w)] [(+foo+ (* w 2))] P1 (p11 [bar y] (- y w)))
 )

(ns edu.berkeley.ai.util.traits
  (:require [edu.berkeley.ai.util :as util]))

(defn- parse-protocols-and-method-pairs [args]
  (when (seq args)
    (let [[proto & rest] args
          [methods more] (split-with coll? rest)]
      (assert (symbol? proto))
      (cons [proto methods]
            (parse-protocols-and-method-pairs more)))))

(defn rewrite-pm-pair [ns args [proto method]]
;  (println ns args proto method)
  (let [method-name    (first method)
        method-args    (second method)
        method-body    (next (next method))
        all-args       (vec (concat method-args args))
        fn-name        (gensym (str (name proto) "-" method-name))
        scoped-fn-name (symbol ns (name fn-name))]
    (assert (apply distinct? (cons nil all-args)))
    [proto #_(symbol ns (name proto))
     `(~method-name ~method-args (~scoped-fn-name ~@all-args))
     `(defn ~fn-name ~all-args (loop ~(vec (interleave (next method-args) (next method-args))) ~@method-body))]))
;; Loop allows proper recur semantics ...

(defn- parse-protocols-and-methods [args specs]
  (let [methods-by-proto (parse-protocols-and-method-pairs specs)
        ns               (name (ns-name *ns*))
        pm-pairs         (for [[p ms] methods-by-proto, m ms] [p m])
;        _ (println pm-pairs)
        pm-triples       (map #(rewrite-pm-pair ns args %) pm-pairs)]
    (assert (apply distinct? (cons nil (map first methods-by-proto))))
    [(map #(nth % 2) pm-triples)
     (util/map-vals #(map second %) (group-by first pm-triples))]))

(defn merge-traits [& traits]
  (let [bindings  (vec (apply concat (map first traits)))]
    (assert (apply distinct? (cons nil (take-nth 2 bindings))))
    [bindings
     (reduce util/merge-disjoint {} (map second traits))]))

;; To allow traits to be used from other namespaces, easiest option is to emit named fns in defining ns ?

(defn parse-trait-form [traits]
  (vec (map #(if (list? %)
               (cons (first %) (map (fn [x] `'~x) (rest %)))
               (list %)) traits)))

;; Internal rep. of a trait is a fn from args to [binding-seq impl-map]
;; TODO: forn ow, args may be multiple evaluated?
(defmacro deftrait [name args state-bindings child-traits & protocols-and-methods]
  (let [[method-fn-defs protocol-method-bodies]
        (parse-protocols-and-methods (concat args (take-nth 2 state-bindings)) protocols-and-methods)]
;    (println method-fn-defs "\n" protocol-method-bodies)
    `(do (defn ~name ~args
           (apply merge-traits
                  [(concat (interleave '~args ~args) '~state-bindings)
                   '~protocol-method-bodies]
                  ~(parse-trait-form child-traits)))
         ~@method-fn-defs)))

(defn- render-trait-methods-inline [trait-map]
  (apply concat (map (partial apply cons) trait-map)))

(defmacro reify-traits [[& traits] & specs]
  (let [[trait-bindings trait-methods] (apply merge-traits (eval (parse-trait-form traits)))]
    `(let ~trait-bindings
       (reify
        ~@(render-trait-methods-inline trait-methods)
        ~@specs))))

(do #_comment

 (defprotocol P2
   (p21 [x y])
   (p22 [x]))

 (defprotocol P1
   (p11 [x y]))

 (defprotocol P0)

 (deftrait +foo+ [x] [y (atom x)] [] P2 (p21 [foo z] (+ z @y)) (p22 [foo] (swap! y inc)) P0)

                                        ; (deftrait +bar+ [w] [z (inc w)] [(+foo+ (* w 2))] P1 (p11 [bar y] (- y w)))
 )

Fix ns bug in traits

Fix ns bug in traits


(ns ecregister.core
  (:gen-class)
  (:use [seesaw.core])
  (:use [seesaw.mig])
  (:use [seesaw.border])
  (:use [seesaw.widgets.log-window])
  (:require [clojure.string :refer [blank?]])
  (:require [clojure.core.async :refer [chan >!! <!! <! >! alts!! alts! timeout thread put! go go-loop close!]])
  (:require [ecregister.avatars :as av])
  )
(require '[ecregister.avatars :as av])
(use '[seesaw.border])

;; to be evaluated in *scratch*, to be executed in clj buffer
;; (define-key clojure-mode-map (kbd "C-c SPC")
;;   (lambda ()
;;     (interactive)
;;     (cider-interactive-eval
;;      ;; customize this to liking per dev session needs...
;;      "(config! f :content (build-content))")))

(def state (atom {:stamp-type :bottom
                  :stamp-path {:bottom "/home/dimka/free-away/avatars/stamp_bot.png"
                               :top    "/home/dimka/free-away/avatars/stamp_top.png"} }))
(defn update-state [& args]
  (apply swap! state assoc args))

;;(require '[clojure.core.async :refer [chan >!! <!! <! >! alts!! alts! timeout thread put! go go-loop close!]])
(defn prepare-avatars [username lb-log form]
  "Fetches an avatar from server, fills in image views, stamps it"
  (when (not (blank? username))
    (log lb-log (str "retrieving avatar for " username "\n"))
    (go
     (let [c (chan)
           resp (<! (av/get-avatar-url username c))]
       (if (= resp :error)
         (log lb-log (str "failed to retrieve avatar image for '" username "'\n"))
         (let [image (<! (av/read-image (first resp) c))
               ext (second resp)]
           (log lb-log (str "successfully read image, detected extension is '" ext "'\n"))
           (config! (select form [:#orig-ava]) :icon image)
           (update-state :image-orig image :image-ext ext)
           (update-stamped-image form)
           ))
       ))))

(defn update-stamped-image [form]
  "Gets an image from state, [re]stamps it according to state config,
saves newly stamped to state updates widgets"
  (when-let [image-orig (:image-orig @state)]
    (update-state :image-stamped
                  (av/stamped image-orig
                              (get-in @state [:stamp-path (:stamp-type @state)])
                              (:image-ext @state)))
    (config! (select form [:#stamped-ava]) :icon (:image-stamped @state))))

(defn build-avatars-tab []
  (let [bg-stamp-pos (button-group)
        form (mig-panel
              :items [[(label "Имя пользователя:") ""]
                      [(text :id :username :columns 15)]
                      [(label :id :orig-ava
                              :border (line-border :color "#ddd" :thickness 1)
                              :halign :center)
                       "span 1 3,w 105px::, h 105px::,wrap,top"]
                      [(label "Положение штампа:")]
                      [(flow-panel :items [(radio :id :top
                                                  :text "Сверху"
                                                  :group bg-stamp-pos
                                                  :selected? (not= :bottom (:stamp-type @state)))
                                           (radio :id :bottom
                                                  :text "Снизу"
                                                  :group bg-stamp-pos
                                                  :selected? (= :bottom (:stamp-type @state))
                                                  )]) "wrap"]
                      [(button :text "Проштамповать") "wrap,skip 1"]
                      [(label "") "grow,push,span 2"] ;; empty filler
                      [(label :id :stamped-ava
                              :border (line-border :color "#ddd" :thickness 1)
                              :halign :center)
                       "w 105px::, h 105px::,wrap,top,gaptop 20px"]
                      [(scrollable (log-window :id :log
                                               :rows 8
                                               :columns 80
                                               ))
                       "span,growx"]]
              :constraints ["fill", "[][grow][]", ""])
        te-name (select form [:#username])
        lb-log (select form [:#log])
        active-chan (chan 1)
        keys-chan (chan 1)
        stop-listening (fn []
                         ;; (log lb-log "Stopping listening\n")
                         (go
                          (if (<! active-chan)
                            (do
                              ;; important to put it back to channel immediately so others could read
                              (>! active-chan false)
                              (prepare-avatars (text te-name) lb-log form)
                              ))))

        start-listening (fn []
                          ;;(log lb-log "Starting listening\n")
                          (go
                           (>! active-chan true)
                           (loop []
                             (let [[v ch] (alts! [keys-chan (timeout 800)])]
                               (if (not (blank? v))
                                 (recur)
                                 (do
                                   ;;       (log lb-log "timeout reached\n")
                                   (stop-listening))
                                 ))
                             )))]
    ;; It is important in this scheme to return value to the channel as soon as it had been read:
    ;; so that others interested can read back
    (listen te-name
            :focus-gained (fn [e]
                            (put! active-chan false))

            :document (fn [e]
                        (go
                         (if (<! active-chan)
                           (do
                             ;; important to put it back to channel immediately so others could read
                             (>! active-chan true)
                             (>! keys-chan "1"))
                           (do
                                        ;(log lb-log "in not-active mode, initiating listening\n")
                             (start-listening)))))
            :focus-lost (fn [e]
                                        ;(log lb-log "focus lost, stopping\n")
                          (stop-listening)))
    (listen bg-stamp-pos :selection
            (fn [e]
              (when-let [image (:image-orig @state)]
                (when-let [s (selection bg-stamp-pos)]
                  (update-state :stamp-type (config s :id))
                  (update-stamped-image form)
                  ))))
    form))

(defn build-posts-tab []
  (label "Posts"))

(defn build-content []
  (horizontal-panel
   :items [(tabbed-panel
            :placement :bottom
            :tabs [ {:title "Аватарки" :content (build-avatars-tab)}
                    {:title "Посты" :content (build-posts-tab)}])
           ]))

(defn make-frame [content]
  (println "content " content)
  (frame
   :title "Free Away Admin"
   :on-close :hide
   :size [640 :by 480]
   :content (label "hello") ;; TODO replace label => (build-content)
   ))

(def f (make-frame (build-content)))
(show! f)
(config! f :content (build-content))

(defn -main [& args]
  (invoke-later
   (->
    (build-content)
    (make-frame)
;;    pack!
    show!
    ))
)

(ns ecregister.core
  (:gen-class)
  (:use [seesaw.core])
  (:use [seesaw.mig])
  (:use [seesaw.border])
  (:use [seesaw.widgets.log-window])
  (:require [clojure.string :refer [blank?]])
  (:require [clojure.core.async :refer [chan >!! <!! <! >! alts!! alts! timeout thread put! go go-loop close!]])
  (:require [ecregister.avatars :as av])
  )
(require '[ecregister.avatars :as av])
(use '[seesaw.border])

;; to be evaluated in *scratch*, to be executed in clj buffer
;; (define-key clojure-mode-map (kbd "C-c SPC")
;;   (lambda ()
;;     (interactive)
;;     (cider-interactive-eval
;;      ;; customize this to liking per dev session needs...
;;      "(config! f :content (build-content))")))

(def state (atom {:stamp-type :bottom
                  :stamp-path {:bottom "/home/dimka/free-away/avatars/stamp_bot.png"
                               :top    "/home/dimka/free-away/avatars/stamp_top.png"}
                  :save-dir-orig "/home/dimka/free-away/avatars/orig/"
                  :save-dir-new "/home/dimka/free-away/avatars/new/"
                  }))
(defn update-state [& args]
  (apply swap! state assoc args))

;;(require '[clojure.core.async :refer [chan >!! <!! <! >! alts!! alts! timeout thread put! go go-loop close!]])
(defn prepare-avatars [username lb-log form]
  "Fetches an avatar from server, fills in image views, stamps it"
  (when (not (blank? username))
    (log lb-log (str "retrieving avatar for " username "\n"))
    (go
     (let [c (chan)
           resp (<! (av/get-avatar-url username c))]
       (if (= resp :error)
         (log lb-log (str "failed to retrieve avatar image for '" username "'\n"))
         (let [image (<! (av/read-image (first resp) c))
               ext (second resp)]
           (log lb-log (str "successfully read image, detected extension is '" ext "'\n"))
           (config! (select form [:#orig-ava]) :icon image)
           (update-state :image-orig image :image-ext ext)
           (update-stamped-image form)
           ))
       ))))

(defn update-stamped-image [form]
  "Gets an image from state, [re]stamps it according to state config,
saves newly stamped to state updates widgets"
  (when-let [image-orig (:image-orig @state)]
    (update-state :image-stamped
                  (av/stamped image-orig
                              (get-in @state [:stamp-path (:stamp-type @state)])
                              (:image-ext @state)))
    (config! (select form [:#stamped-ava]) :icon (:image-stamped @state))
    (let [filename (str (:username @state) "." (:image-ext @state))]
      (config! (select form [:#save-label-orig])
               :text (str (:save-dir-orig @state) filename))
      (config! (select form [:#save-label-new])
               :text (str (:save-dir-new @state) filename)))))

(defn build-avatars-tab []
  (let [bg-stamp-pos (button-group)
        form (mig-panel
              :items [[(label "Имя пользователя:") ""]
                      [(text :id :username :columns 15)]
                      [(vertical-panel
                        :items [(label :id :orig-ava
                                       :border (line-border :color "#ddd" :thickness 1)
                                       :halign :center
                                       :valign :center
                                       :size [106 :by 106]) [:fill-v 10]
                                (label :id :stamped-ava
                                       :border (line-border :color "#ddd" :thickness 1)
                                       :halign :center
                                       :valign :center
                                       :size [106 :by 106]
                                       )])
                       "span 1 7,wrap,top"]
                      [(label "Положение штампа:")]
                      [(flow-panel :items [(radio :id :top
                                                  :text "Сверху"
                                                  :group bg-stamp-pos
                                                  :selected? (not= :bottom (:stamp-type @state)))
                                           (radio :id :bottom
                                                  :text "Снизу"
                                                  :group bg-stamp-pos
                                                  :selected? (= :bottom (:stamp-type @state))
                                                  )]) "wrap"]
                      [(label
                        :foreground "#bbb"
                        :font "Terminus"
                        :text "Аватарки будут сохранены в:") "span 2,wrap"]
                      [(label :id :save-label-orig
                              :font "Terminus"
                              :foreground "#bbb"
                              :text (:save-dir-orig @state)) "span 2,wrap"]
                      [(label :id :save-label-new
                              :font "Terminus"
                              :foreground "#bbb"
                              :text (:save-dir-new @state)) "span 2,wrap"]
                      [(button :text "Проштамповать") "wrap,skip 1"]
                      [(label "") "grow,push,span 2,wrap"] ;; empty filler
                      [(scrollable (log-window :id :log
                                               :rows 8
                                               :columns 80
                                               ))
                       "span,growx"]]
              :constraints ["fill", "[][grow][]", ""])
        te-name (select form [:#username])
        lb-log (select form [:#log])
        active-chan (chan 1)
        keys-chan (chan 1)
        stop-listening (fn []
                         ;; (log lb-log "Stopping listening\n")
                         (go
                          (if (<! active-chan)
                            (do
                              ;; important to put it back to channel immediately so others could read
                              (>! active-chan false)
                              (update-state :username (text te-name))
                              (prepare-avatars (text te-name) lb-log form)
                              ))))

        start-listening (fn []
                          ;;(log lb-log "Starting listening\n")
                          (go
                           (>! active-chan true)
                           (loop []
                             (let [[v ch] (alts! [keys-chan (timeout 800)])]
                               (if (not (blank? v))
                                 (recur)
                                 (do
                                   ;;       (log lb-log "timeout reached\n")
                                   (stop-listening))
                                 ))
                             )))]
    ;; It is important in this scheme to return value to the channel as soon as it had been read:
    ;; so that others interested can read back
    (listen te-name
            :focus-gained (fn [e]
                            (put! active-chan false))

            :document (fn [e]
                        (go
                         (if (<! active-chan)
                           (do
                             ;; important to put it back to channel immediately so others could read
                             (>! active-chan true)
                             (>! keys-chan "1"))
                           (do
                                        ;(log lb-log "in not-active mode, initiating listening\n")
                             (start-listening)))))
            :focus-lost (fn [e]
                                        ;(log lb-log "focus lost, stopping\n")
                          (stop-listening)))
    (listen bg-stamp-pos :selection
            (fn [e]
              (when-let [image (:image-orig @state)]
                (when-let [s (selection bg-stamp-pos)]
                  (update-state :stamp-type (config s :id))
                  (update-stamped-image form)
                  ))))
    form))

(defn build-posts-tab []
  (label "Posts"))

(defn build-content []
  (horizontal-panel
   :items [(tabbed-panel
            :placement :bottom
            :tabs [ {:title "Аватарки" :content (build-avatars-tab)}
                    {:title "Посты" :content (build-posts-tab)}])
           ]))

(defn make-frame [content]
  (println "content " content)
  (frame
   :title "Free Away Admin"
   :on-close :hide
   :size [640 :by 480]
   :content (label "hello") ;; TODO replace label => (build-content)
   ))

(def f (make-frame (build-content)))
(show! f)
(config! f :content (build-content))

(defn -main [& args]
  (invoke-later
   (->
    (build-content)
    (make-frame)
;;    pack!
    show!
    ))
)

Add showing save paths, rework layout a bit


(ns fscrawler-tika-convert.core
  (:require [langohr.basic :as lb])
  (:require [langohr.core :as rmq])
  (:require [langohr.queue :as lq])
  (:require [langohr.channel :as lch])
  (:require [langohr.consumers :as lcons])
  ;; (:require [me.raynes.fs :as fs])
  (:require [clojure.tools.cli :as cli])
  (:require [clojure.data.json :as json])
  (:require [clojure.string :as string])
  (:require [tika])
  (:import java.io.File)
  (:gen-class))

(defn handle-message
  [ch metadata ^bytes payload]
  (let [body (json/read-json (String. payload "UTF-8"))
        ;; {:keys [directory relpath] body}
        directory (:directory body)
        relpath (:relpath (:entry body))
        fp (string/join File/separator [directory relpath])
        converted (tika/parse fp)
        ]
        ;;
    (println "dir" fp " ****" (:content-type converted))))

;; (println "got message" metadata (String. payload "UTF-8")))

(defn run-with-connection
  []
  (let [conn       (rmq/connect)
        ch         (lch/open conn)
        queue-name "nextbot.extract_content.fscrawler:test"
        handler    (fn [ch {:keys [headers delivery-tag redelivery?]} ^bytes payload]
                     (println "hello")
                     (println "headers" headers)
                     ;; (println (format "[consumer] Received %s" (String. payload "UTF-8")))
                     (lb/ack ch delivery-tag))]
    ;; (lq/declare ch queue-name :exclusive false :auto-delete true)
    ;; (lq/bind    ch queue-name "nextbot")
    (lcons/subscribe ch queue-name handle-message :auto-ack false)))

(defn -main [& args]
  ;; work around dangerous default behaviour in Clojure
  (alter-var-root #'*read-eval* (constantly false))

  (let [[options args banner]
        (cli/cli args
                 ["--ampqp-url" "amqp url to connect to"]
                 ["--port" "Port to listen on" :default 5000]
                 ["--root" "Root directory of web server" :default "public"])]
    (println "port:" (:port options))
    (println "root:" (:root options)))
  (run-with-connection)
)

(ns fscrawler-tika-convert.core
  (:require [langohr.basic :as lb])
  (:require [langohr.core :as rmq])
  (:require [langohr.queue :as lq])
  (:require [langohr.channel :as lch])
  (:require [langohr.consumers :as lcons])
  ;; (:require [me.raynes.fs :as fs])
  (:require [clojure.tools.cli :as cli])
  (:require [clojure.data.json :as json])
  (:require [clojure.string :as string])
  (:require [tika])
  (:import java.io.File)
  (:gen-class))

(defn handle-message
  [ch metadata ^bytes payload]
  (let [body (json/read-json (String. payload "UTF-8"))
        ;; {:keys [directory relpath] body}
        directory (:directory body)
        relpath (:relpath (:entry body))
        fp (string/join File/separator [directory relpath])
        ;; converted (tika/parse fp)
        ]
        ;;
    (future (let [converted (tika/parse fp)]
              (println "before ack" (Thread/currentThread) (:delivery-tag metadata))
              (lb/ack ch (:delivery-tag metadata))
              (println "done" fp " ****" )))

    (println "scheduled" fp " ****" )))

    ;; (println "dir" fp " ****" (:content-type converted))))

;; (println "got message" metadata (String. payload "UTF-8")))

(defn run-with-connection
  []
  (let [conn       (rmq/connect)
        ch         (lch/open conn)
        queue-name "nextbot.extract_content.fscrawler:test"
        handler    (fn [ch {:keys [headers delivery-tag redelivery?]} ^bytes payload]
                     (println "hello")
                     (println "headers" headers)
                     ;; (println (format "[consumer] Received %s" (String. payload "UTF-8")))
                     (lb/ack ch delivery-tag))]
    ;; (lq/declare ch queue-name :exclusive false :auto-delete true)
    ;; (lq/bind    ch queue-name "nextbot")
    (lb/qos ch 10)
    (lcons/subscribe ch queue-name handle-message :auto-ack false)
    (println "done with subscribing")))

(defn -main [& args]
  ;; work around dangerous default behaviour in Clojure
  (alter-var-root #'*read-eval* (constantly false))

  (let [[options args banner]
        (cli/cli args
                 ["--ampqp-url" "amqp url to connect to"]
                 ["--port" "Port to listen on" :default 5000]
                 ["--root" "Root directory of web server" :default "public"])]
    (println "port:" (:port options))
    (println "root:" (:root options)))
  (run-with-connection))

use threads to convert files

use threads to convert files


(ns user
  (:use cake cake.ant)
  (:import [org.apache.tools.ant.taskdefs Copy ExecTask]))

(defn build [srcdir dest environment]
  (ant ExecTask {:dir (file srcdir) :executable "./configure"}
       (args [(str "--prefix=" dest)])
       (env environment))
  (ant ExecTask {:dir (file srcdir) :executable "make"}
       (args ["install"])))

(deftask compile-native
  (let [dest (file "build/install")]
    (when-not (.exists dest)
      (.mkdirs dest)
      (let [dest (.getPath dest)]
        (build "src/tokyocabinet-1.4.45" dest {})
        (build "src/tokyocabinet-java-1.23" dest
               {"JAVA_HOME" (System/getProperty "java.home")
                "CPPFLAGS"  (str "-I" dest "/include -L" dest "/lib")})
        (ant Copy {:todir (file "classes")}
             (add-zipfileset {:src (str dest "/lib/tokyocabinet.jar") :includes "**/*.class"}))))))

(ns user
  (:use cake cake.ant)
  (:import [org.apache.tools.ant.taskdefs Copy ExecTask]))

(defn build [srcdir dest environment]
  (ant ExecTask {:dir (file srcdir) :executable "./configure"}
       (args [(str "--prefix=" dest)])
       (env environment))
  (ant ExecTask {:dir (file srcdir) :executable "make"})
  (ant ExecTask {:dir (file srcdir) :executable "make"} (args ["install"])))

(deftask compile-native
  (let [dest (file "build/native")]
    (when-not (.exists dest)
      (.mkdirs dest)
      (let [dest (.getPath dest)]
        (build "src/tokyocabinet-1.4.45" dest {})
        (build "src/tokyocabinet-java-1.23" dest
               {"JAVA_HOME" (System/getProperty "java.home")
                "CPPFLAGS"  (str "-I" dest "/include -L" dest "/lib")})
        (ant Copy {:todir (file "classes")}
             (add-zipfileset {:src (str dest "/lib/tokyocabinet.jar") :includes "**/*.class"}))))))

(defn clean [srcdir]
  (ant ExecTask {:dir (file srcdir) :executable "make"} (args ["clean"])))

(deftask clean
  (clean "src/tokyocabinet-1.4.45")
  (clean "src/tokyocabinet-java-1.23"))

install to build/native. fix make. add make clean


(ns grimoire.things
  "This namespace implements a \"thing\" structure, approximating a URI, for
  uniquely naming and referencing entities in a Grimoire documentation
  store.

  Thing     ::= Sum[Group, Artifact, Version, Platform,
                    Namespace, Def, Note, Example];
  Group     ::= Record[                   Name: String];
  Artifact  ::= Record[Parent: Group,     Name: String];
  Version   ::= Record[Parent: Artifact,  Name: String];
  Platform  ::= Record[Parent: Version,   Name: String];
  Namespace ::= Record[Parent: Platform,  Name: String];
  Def       ::= Record[Parent: Namespace, Name: String];

  Note      ::= Record[Parent: Thing,     Handle: String];
  Example   ::= Record[Parent: Thing,     Handle: String];"
  (:refer-clojure :exclude [def namespace])
  (:require [clojure.string :as string]
            [clojure.core.match :refer [match]]
            [grimoire.util :as u]
            [guten-tag.core :as t]
            [cemerick.url :as url]))

(t/deftag group
  "Represents a Maven group."
  [name]
  {:pre [(string? name)]})

(t/deftag artifact
  "Represents a Maven artifact, rooted on a group."
  [parent, name]
  {:pre [(group? parent)
         (string? name)]})

(t/deftag version
  "Represents a Maven version, rooted on an artifact."
  [parent, name]
  {:pre [(artifact? parent)
         (string? name)]})

(t/deftag platform
  "Represents a Clojure \"platform\" rooted on a version of an
  artifact.

  Platforms are a construct and represent a versioned set of
  namespaces (and thus of defs) defining the versioned package at that
  version. The idea is that a single artifact may have \"platform\"
  code for any of Clojure, ClojureScript, ClojureCLR and soforth
  simultaneously. Selecting a platform in a tree thus selects a set of
  namespaces and defs which are particular to this platform. It also
  allows Grimoire to host what would otherwise be name-colliding
  functions which are really implicitly differentiated by platform."
  [parent, name]
  {:pre [(version? parent)
         (string? name)]})

(t/deftag namespace
  "Represents a Clojure \"namespace\" rooted on a platform in a
  version of an artifact."
  [parent, name]
  {:pre [(platform? parent)
         (string? name)]})

(t/deftag def
  "Represents a Clojure \"Def\" rooted in a namespace on a platform in
  a version of an artifact."
  [parent, name]
  {:pre [(namespace? parent)
         (string? name)]})

(declare thing?)

(t/deftag note
  "Represents a single block of notes on an arbitrary Thing as
  identified by a Handle. The Handle is intended to be some structure
  such as a file path, record ID, UUID or something else uniquely
  naming a specific note."
  [parent, name, handle]
  {:pre [(thing? parent)
         (string? name)
         (string? handle)]})

(t/deftag example
  "Represents a single example on an arbitrary Thing as identified by
  a Handle. The Handle is intended to be some structure such as a file
  path, record ID, UUID or other unique identifier for that singular
  specific example."
  [parent, name, handle]
  {:pre [(thing? parent)
         (string? name)
         (string? handle)]})

;; Helpers for walking thing paths

(defn leaf?
  "Predicate testing whether the input Thing is either an example or a
  note."
  [t]
  (or (note? t)
      (example? t)))

(defn namespaced?
  "Predicate testing whether the input either is a namespace or has a namespace
  as a parent."
  [t]
  (or (namespace? t)
      (def? t)
      (and (leaf? t)
           (namespaced? (:parent t)))))

(defn platformed?
  "Predicate testing whether the input either is a platform or has a platform as
  a parent."
  [t]
  (or (namespaced? t)
      (platform? t)
      (and (leaf? t)
           (platformed? (:parent t)))))

(defn versioned?
  "Predicate testing whether the input exists within the subset of the \"thing\"
  variant which can be said to be \"versioned\" in that it is rooted on a
  Version instance and thus a version instance can be reached by upwards
  traversal."
  [t]
  (or (platformed? t)
      (version? t)
      (and (leaf? t)
           (versioned? (:parent t)))))

(defn artifacted?
  "Predicate testing whether the input either is an artifact or has an artifact
  as a parent."
  [t]
  (or (versioned? t)
      (artifact? t)
      (and (leaf? t)
           (artifacted? (:parent t)))))

(defn grouped?
  "Predicate testing whether the input either is a group or has a group as a
  parent."
  [t]
  (or (artifacted? t)
      (group? t)
      (and (leaf? t)
           (grouped? (:parent t)))))

(defn thing?
  "Predicate testing whether the input exists within the \"thing\" variant of
  Σ[Group, Artifact,Version, Platform, Namespace, Def]"
  [t]
  (grouped? t))

(defn thing->parent
  "Function from any object to Maybe[Thing]. If the input is a thing, returns
  the parent (maybe nil) of that Thing. Otherwise returns nil."
  [t]
  (when (thing? t)
    (:parent t)))

(defn thing->name
  "Function from an object to Maybe[String]. If the input is a thing, returns
  the name of the Thing. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (:name t))

;; smarter url caching constructors

(declare thing->url-path)

(defn ->Group
  ([groupid]
   {:pre [(string? groupid)]}
   (let [v (->group groupid)]
     (assoc v ::url (thing->url-path v))))

  ([_ groupid]
   (->Group groupid)))

(defn ->Artifact
  [group artifact]
  (let [v (->artifact group artifact)]
    (assoc v ::url (thing->url-path v))))

(defn ->Version
  [artifact version]
  (let [v (->version artifact version)]
    (assoc v ::url (thing->url-path v))))

(defn ->Platform
  [version platform]
  (let [v (->platform version (u/normalize-platform platform))]
    (assoc v ::url (thing->url-path v))))

(defn ->Ns
  [platform namespace]
  (let [v (->namespace platform namespace)]
    (assoc v ::url (thing->url-path v))))

(defn ->Def
  [namespace name]
  (let [v (->def namespace name)]
    (assoc v ::url (thing->url-path v))))

(defn ->Example
  [thing name handle]
  (let [v (->example thing name handle)]
    (assoc v ::url handle)))

(defn ->Note
  [thing name handle]
  (let [v (->note thing name handle)]
    (assoc v ::url handle)))

;; Manipulating things and strings

(defn thing->path
  "Provides a mechanism for converting one of the Handle objects into a
  cannonical \"path\" which can be serialized, deserialized and walked back into
  a Handle."
  [t]
  {:pre [(thing? t)]}
  (or (::url t)
      (thing->url-path t)))

(defn path->thing
  "String to Thing transformer which builds a Thing tree by splitting on /. The
  resulting things are rooted on a Group as required by the definition of a
  Thing."
  [path]
  (->> (string/split path #"/" 6)
       (map vector [->Group ->Artifact ->Version ->Platform ->Ns ->Def])
       (reduce (fn [acc [f v]]
                 (if v (f acc v) acc))
               nil)))

(defn ensure-thing
  "Transformer which, if given a string, will construct a Thing (with a warning)
  and if given a Thing will return the Thing without modification. Intended as a
  guard for potentially mixed input situations."
  [maybe-thing]
  (cond (string? maybe-thing)
        ,,(do (.write *err* "Warning: building a thing from a string via ensure-string!\n")
              (path->thing maybe-thing))

        (thing? maybe-thing)
        ,,maybe-thing

        :else
        ,,(throw
           (Exception.
            (str "Unsupported ensure-thing value "
                 (pr-str maybe-thing))))))

;; Traversing things

(defn thing->group
  "Function from a Thing to a Group. If the Thing is rooted on a Group,
  or is a Group, traverses thing->parent until a Group is produced. Otherwise
  returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (grouped? t)
    (if-not (group? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->artifact
  "Function from a Thing to an Artifact. If the Thing is rooted on an Artifact,
  or is an Artifact, traverses thing->parent until the rooting Artifact is
  reached and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (artifacted? t)
    (if-not (artifact? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->version
  "Function from a Thing to a Verison. If the Thing is rooted on a Version or is
  a Version, traverses thing->parent until the rooting Version is reached and
  then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (versioned? t)
    (if-not (version? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->platform
  "Function from a Thing to a Platform. If the Thing is rooted on a Platform or
  is a Platform traverses thing->parent until the rooting Platform is reached
  and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (platformed? t)
    (if-not (platform? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->namespace
  "Function from a Thing to a Namespace. If the Thing is rooted on a Platform or
  is a Platform traverses thing->parent until the rooting Platform is reached
  and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (namespaced? t)
    (if-not (namespace? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->def
  "Function from a Thing to a Def. If the Thing either is a Def or is rooted on
  a Def, traverses thing->parent until the rooting Def is reached and then
  returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (def? t) t))

;; Bits and bats

(defn thing->url-path
  "Function from a Thing to a munged and URL safe Thing path"
  [t]
  {:pre [(thing? t)]}
  (match [t]
    [([::def   {:name n :parent p}] :seq)]
    ,,(str (thing->url-path p) "/" (u/munge n))

    [([::group {:name n}] :seq)]
    ,,n

    [([_       {:name n :parent p}] :seq)]
    ,,(str (thing->url-path p) "/" n)))

;; FIXME: this function could probably be a little more principled,
;; but so be it.
(defn url-path->thing
  "Function from a URL to a Thing. Complement of thing->url-path."
  [url]
  (let [path-elems (string/split url #"/")
        path-elems (if (<= 6 (count path-elems))
                     (concat
                      (take 5 path-elems)
                      [(url/url-decode (nth path-elems 5))]
                      (drop 6 path-elems))
                     path-elems)]
    (path->thing (string/join "/" path-elems))))

(defn thing->type-name
  [t]
  {:pre [(thing? t)]}
  (match [t]
    [([::group     {}] :seq)] "group"
    [([::artifact  {}] :seq)] "artifact"
    [([::version   {}] :seq)] "version"
    [([::platform  {}] :seq)] "platform"
    [([::namespace {}] :seq)] "namespace"
    [([::def       {}] :seq)] "def"))

(defn thing->full-uri
  "Function from a Thing to a String representing a unique Thing naming URI.

  URIs have the same structure as thing->url-path but are prefixed by <t>:
  where <t> is the lower cased name of the type of the input Thing.

  For example, a Thing represeting org.clojure/clojure would give the full URI
  grim+artifact:org.clojure/clojure. A Thing representing org.clojure/clojure/1.6.0
  would likewise be grim+version:org.clojure/clojure/1.6.0 and soforth."
  [t]
  {:pre [(thing? t)]}
  (format "grim+%s:%s"
          (thing->type-name t)
          (thing->url-path t)))

(def full-uri-pattern
  #"(grim\+(group|artifact|version|platform|namespace|def)(\+(note|example))?):([^?&#]+)([?&#].*)?")

(defn full-uri->thing
  "Complement of thing->full-uri."
  [uri-string]
  {:pre [(string? uri-string)]}
  (let [[_ scheme type _ extension path
         :as groups] (re-find full-uri-pattern uri-string)]
    (assert groups "Failed to parse URI. No regex match!")
    (println groups)
    (let [t (url-path->thing path)]
      (assert (= (thing->type-name t) type)
              "Failed to parse URI. Path didn't round trip to expected type!")
      t)))

(def short-string-pattern
  #"(\w{3,6})::([^\s/,;:\"'\[\]\(\)\s]+)(/([^,;:\"\[\]\(\)\s]+))?")

(defn thing->short-string
  "Function from a Thing to a String representing a mostly unique naming string.

  Unlike thing->full-uri, thing->short-string will discard exact artifact, group
  and verison information instead giving only a URI with respect to the
  platform, namespace and name of a Thing.

  For example, the Thing representing
  org.clojure/clojure/1.6.0/clj/clojure.core/+ would give the short string
  clj::clojure.core/+."
  [t]
  {:pre  [(platformed? t)]
   :post [(re-find short-string-pattern %)]}
  (match [t]
    [([::namespace {:name nn
                    :parent {:name pn}}]
      :seq)]
    ,,(format "%s::%s" pn nn)

    [([::def {:name n
              :parent {:name nn
                       :parent {:name pn}}}]
      :seq)]
    ,,(format "%s::%s/%s"
              pn nn n)))

;; short-string->thing to be defined in terms of a search for the latest version.
(defn parse-short-string
  "Function from a String as generated by thing->short-string to one of
  either [:def nil nil nil <ns-name> <def-name>] or [:ns nil nil nil
  <ns-name>]. The intention is that this function can be used to parse
  short-strings into structures for which Things can be looked up out of a
  datastore. Returns nil on failure to parse."
  [s]
  {:pre [(string? s)]}
  (let [[_s platform ns _ ?def :as match] (re-find short-string-pattern s)]
    (when match
      (if ?def
        [:def nil nil nil platform ns ?def]
        [:ns  nil nil nil platform ns]))))

(ns grimoire.things
  "This namespace implements a \"thing\" structure, approximating a URI, for
  uniquely naming and referencing entities in a Grimoire documentation
  store.

  Thing     ::= Sum[Group, Artifact, Version, Platform,
                    Namespace, Def, Note, Example];
  Group     ::= Record[                   Name: String];
  Artifact  ::= Record[Parent: Group,     Name: String];
  Version   ::= Record[Parent: Artifact,  Name: String];
  Platform  ::= Record[Parent: Version,   Name: String];
  Namespace ::= Record[Parent: Platform,  Name: String];
  Def       ::= Record[Parent: Namespace, Name: String];

  Note      ::= Record[Parent: Thing,     Handle: String];
  Example   ::= Record[Parent: Thing,     Handle: String];"
  (:refer-clojure :exclude [def namespace])
  (:require [clojure.string :as string]
            [clojure.core.match :refer [match]]
            [grimoire.util :as u]
            [guten-tag.core :as t]
            [cemerick.url :as url]))

(t/deftag group
  "Represents a Maven group."
  [name]
  {:pre [(string? name)]})

(t/deftag artifact
  "Represents a Maven artifact, rooted on a group."
  [parent, name]
  {:pre [(group? parent)
         (string? name)]})

(t/deftag version
  "Represents a Maven version, rooted on an artifact."
  [parent, name]
  {:pre [(artifact? parent)
         (string? name)]})

(t/deftag platform
  "Represents a Clojure \"platform\" rooted on a version of an
  artifact.

  Platforms are a construct and represent a versioned set of
  namespaces (and thus of defs) defining the versioned package at that
  version. The idea is that a single artifact may have \"platform\"
  code for any of Clojure, ClojureScript, ClojureCLR and soforth
  simultaneously. Selecting a platform in a tree thus selects a set of
  namespaces and defs which are particular to this platform. It also
  allows Grimoire to host what would otherwise be name-colliding
  functions which are really implicitly differentiated by platform."
  [parent, name]
  {:pre [(version? parent)
         (string? name)]})

(t/deftag namespace
  "Represents a Clojure \"namespace\" rooted on a platform in a
  version of an artifact."
  [parent, name]
  {:pre [(platform? parent)
         (string? name)]})

(t/deftag def
  "Represents a Clojure \"Def\" rooted in a namespace on a platform in
  a version of an artifact."
  [parent, name]
  {:pre [(namespace? parent)
         (string? name)]})

(declare thing?)

(t/deftag note
  "Represents a single block of notes on an arbitrary Thing as
  identified by a Handle. The Handle is intended to be some structure
  such as a file path, record ID, UUID or something else uniquely
  naming a specific note."
  [parent, name, handle]
  {:pre [(thing? parent)
         (string? name)
         (string? handle)]})

(t/deftag example
  "Represents a single example on an arbitrary Thing as identified by
  a Handle. The Handle is intended to be some structure such as a file
  path, record ID, UUID or other unique identifier for that singular
  specific example."
  [parent, name, handle]
  {:pre [(thing? parent)
         (string? name)
         (string? handle)]})

;; Helpers for walking thing paths

(defn leaf?
  "Predicate testing whether the input Thing is either an example or a
  note."
  [t]
  (or (note? t)
      (example? t)))

(defn namespaced?
  "Predicate testing whether the input either is a namespace or has a namespace
  as a parent."
  [t]
  (or (namespace? t)
      (def? t)
      (and (leaf? t)
           (namespaced? (:parent t)))))

(defn platformed?
  "Predicate testing whether the input either is a platform or has a platform as
  a parent."
  [t]
  (or (namespaced? t)
      (platform? t)
      (and (leaf? t)
           (platformed? (:parent t)))))

(defn versioned?
  "Predicate testing whether the input exists within the subset of the \"thing\"
  variant which can be said to be \"versioned\" in that it is rooted on a
  Version instance and thus a version instance can be reached by upwards
  traversal."
  [t]
  (or (platformed? t)
      (version? t)
      (and (leaf? t)
           (versioned? (:parent t)))))

(defn artifacted?
  "Predicate testing whether the input either is an artifact or has an artifact
  as a parent."
  [t]
  (or (versioned? t)
      (artifact? t)
      (and (leaf? t)
           (artifacted? (:parent t)))))

(defn grouped?
  "Predicate testing whether the input either is a group or has a group as a
  parent."
  [t]
  (or (artifacted? t)
      (group? t)
      (and (leaf? t)
           (grouped? (:parent t)))))

(defn thing?
  "Predicate testing whether the input exists within the \"thing\" variant of
  Σ[Group, Artifact,Version, Platform, Namespace, Def]"
  [t]
  (grouped? t))

(defn thing->parent
  "Function from any object to Maybe[Thing]. If the input is a thing, returns
  the parent (maybe nil) of that Thing. Otherwise returns nil."
  [t]
  (when (thing? t)
    (:parent t)))

(defn thing->name
  "Function from an object to Maybe[String]. If the input is a thing, returns
  the name of the Thing. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (:name t))

;; smarter url caching constructors

(declare thing->url-path)

(defn ->Group
  ([groupid]
   {:pre [(string? groupid)]}
   (let [v (->group groupid)]
     (assoc v ::url (thing->url-path v))))

  ([_ groupid]
   (->Group groupid)))

(defn ->Artifact
  [group artifact]
  (let [v (->artifact group artifact)]
    (assoc v ::url (thing->url-path v))))

(defn ->Version
  [artifact version]
  (let [v (->version artifact version)]
    (assoc v ::url (thing->url-path v))))

(defn ->Platform
  [version platform]
  (let [v (->platform version (u/normalize-platform platform))]
    (assoc v ::url (thing->url-path v))))

(defn ->Ns
  [platform namespace]
  (let [v (->namespace platform namespace)]
    (assoc v ::url (thing->url-path v))))

(defn ->Def
  [namespace name]
  (let [v (->def namespace name)]
    (assoc v ::url (thing->url-path v))))

(defn ->Example
  [thing name handle]
  (let [v (->example thing name handle)]
    (assoc v ::url handle)))

(defn ->Note
  [thing name handle]
  (let [v (->note thing name handle)]
    (assoc v ::url handle)))

;; Manipulating things and strings

(defn thing->path
  "Provides a mechanism for converting one of the Handle objects into a
  cannonical \"path\" which can be serialized, deserialized and walked back into
  a Handle."
  [t]
  {:pre [(thing? t)]}
  (or (::url t)
      (thing->url-path t)))

(defn path->thing
  "String to Thing transformer which builds a Thing tree by splitting on /. The
  resulting things are rooted on a Group as required by the definition of a
  Thing."
  [path]
  (->> (string/split path #"/" 6)
       (map vector [->Group ->Artifact ->Version ->Platform ->Ns ->Def])
       (reduce (fn [acc [f v]]
                 (if v (f acc v) acc))
               nil)))

(defn ensure-thing
  "Transformer which, if given a string, will construct a Thing (with a warning)
  and if given a Thing will return the Thing without modification. Intended as a
  guard for potentially mixed input situations."
  [maybe-thing]
  (cond (string? maybe-thing)
        ,,(do (.write *err* "Warning: building a thing from a string via ensure-string!\n")
              (path->thing maybe-thing))

        (thing? maybe-thing)
        ,,maybe-thing

        :else
        ,,(throw
           (Exception.
            (str "Unsupported ensure-thing value "
                 (pr-str maybe-thing))))))

;; Traversing things

(defn thing->group
  "Function from a Thing to a Group. If the Thing is rooted on a Group,
  or is a Group, traverses thing->parent until a Group is produced. Otherwise
  returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (grouped? t)
    (if-not (group? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->artifact
  "Function from a Thing to an Artifact. If the Thing is rooted on an Artifact,
  or is an Artifact, traverses thing->parent until the rooting Artifact is
  reached and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (artifacted? t)
    (if-not (artifact? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->version
  "Function from a Thing to a Verison. If the Thing is rooted on a Version or is
  a Version, traverses thing->parent until the rooting Version is reached and
  then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (versioned? t)
    (if-not (version? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->platform
  "Function from a Thing to a Platform. If the Thing is rooted on a Platform or
  is a Platform traverses thing->parent until the rooting Platform is reached
  and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (platformed? t)
    (if-not (platform? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->namespace
  "Function from a Thing to a Namespace. If the Thing is rooted on a Platform or
  is a Platform traverses thing->parent until the rooting Platform is reached
  and then returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (namespaced? t)
    (if-not (namespace? t)
      (when t
        (recur (thing->parent t)))
      t)))

(defn thing->def
  "Function from a Thing to a Def. If the Thing either is a Def or is rooted on
  a Def, traverses thing->parent until the rooting Def is reached and then
  returns that value. Otherwise returns nil."
  [t]
  {:pre [(thing? t)]}
  (when (def? t) t))

;; Bits and bats

(defn thing->url-path
  "Function from a Thing to a munged and URL safe Thing path"
  [t]
  {:pre [(thing? t)]}
  (match [t]
    [([::def   {:name n :parent p}] :seq)]
    ,,(str (thing->url-path p) "/" (u/munge n))

    [([::group {:name n}] :seq)]
    ,,n

    [([_       {:name n :parent p}] :seq)]
    ,,(str (thing->url-path p) "/" n)))

;; FIXME: this function could probably be a little more principled,
;; but so be it.
(defn url-path->thing
  "Function from a URL to a Thing. Complement of thing->url-path."
  [url]
  (let [path-elems (string/split url #"/")
        path-elems (if (<= 6 (count path-elems))
                     (concat
                      (take 5 path-elems)
                      [(url/url-decode (nth path-elems 5))]
                      (drop 6 path-elems))
                     path-elems)]
    (path->thing (string/join "/" path-elems))))

(defn thing->type-name
  [t]
  {:pre [(thing? t)]}
  (match [t]
    [([::group     {}] :seq)] "group"
    [([::artifact  {}] :seq)] "artifact"
    [([::version   {}] :seq)] "version"
    [([::platform  {}] :seq)] "platform"
    [([::namespace {}] :seq)] "namespace"
    [([::def       {}] :seq)] "def"))

(defn thing->full-uri
  "Function from a Thing to a String representing a unique Thing naming URI.

  URIs have the same structure as thing->url-path but are prefixed by <t>:
  where <t> is the lower cased name of the type of the input Thing.

  For example, a Thing represeting org.clojure/clojure would give the full URI
  grim+artifact:org.clojure/clojure. A Thing representing org.clojure/clojure/1.6.0
  would likewise be grim+version:org.clojure/clojure/1.6.0 and soforth."
  [t]
  {:pre [(thing? t)]}
  (format "grim+%s:%s"
          (thing->type-name t)
          (thing->url-path t)))

(def full-uri-pattern
  #"(grim\+(group|artifact|version|platform|namespace|def)(\+(note|example))?):([^?&#]+)([?&#].*)?")

(defn full-uri->thing
  "Complement of thing->full-uri."
  [uri-string]
  {:pre [(string? uri-string)]}
  (let [[_ scheme type _ extension path
         :as groups] (re-find full-uri-pattern uri-string)]
    (assert groups "Failed to parse URI. No regex match!")
    (let [t (url-path->thing path)]
      (assert (= (thing->type-name t) type)
              "Failed to parse URI. Path didn't round trip to expected type!")
      t)))

(def short-string-pattern
  #"(\w{3,6})::([^\s/,;:\"'\[\]\(\)\s]+)(/([^,;:\"\[\]\(\)\s]+))?")

(defn thing->short-string
  "Function from a Thing to a String representing a mostly unique naming string.

  Unlike thing->full-uri, thing->short-string will discard exact artifact, group
  and verison information instead giving only a URI with respect to the
  platform, namespace and name of a Thing.

  For example, the Thing representing
  org.clojure/clojure/1.6.0/clj/clojure.core/+ would give the short string
  clj::clojure.core/+."
  [t]
  {:pre  [(platformed? t)]
   :post [(re-find short-string-pattern %)]}
  (match [t]
    [([::namespace {:name nn
                    :parent {:name pn}}]
      :seq)]
    ,,(format "%s::%s" pn nn)

    [([::def {:name n
              :parent {:name nn
                       :parent {:name pn}}}]
      :seq)]
    ,,(format "%s::%s/%s"
              pn nn n)))

;; short-string->thing to be defined in terms of a search for the latest version.
(defn parse-short-string
  "Function from a String as generated by thing->short-string to one of
  either [:def nil nil nil <ns-name> <def-name>] or [:ns nil nil nil
  <ns-name>]. The intention is that this function can be used to parse
  short-strings into structures for which Things can be looked up out of a
  datastore. Returns nil on failure to parse."
  [s]
  {:pre [(string? s)]}
  (let [[_s platform ns _ ?def :as match] (re-find short-string-pattern s)]
    (when match
      (if ?def
        [:def nil nil nil platform ns ?def]
        [:ns  nil nil nil platform ns]))))

Remove println that made prod

Remove println that made prod


(ns leiningen.new.lein-quick-om
  (:require [leiningen.new.templates :refer [renderer name-to-path ->files]]
            [leiningen.core.main :as main]))

(def render (renderer "lein-quick-om"))

(defn lein-quick-om
  "FIXME: write documentation"
  [name]
  (let [data {:name name
              :sanitized (name-to-path name)}]
    (main/info "Generating fresh 'lein new' lein-quick-om project.")
    (->files data
             ["src/{{sanitized}}/core.cljs" (render "core.cljs" data)]
             ["project.clj" (render "project.clj" data)]
             ["Dockerfile" (render "Dockerfile" data)]
             ["Makefile" (render "Makefile" data)]
             [".dockerignore" (render ".dockerignore" data)]
             ["resources/public/index.html" (render "index.html" data)]
             ["resources/public/css/style.css" (render "style.css" data)]
             )))

(ns leiningen.new.lein-quick-om
  (:require [leiningen.new.templates :refer [renderer name-to-path ->files]]
            [leiningen.core.main :as main]))

(def render (renderer "lein-quick-om"))

(defn lein-quick-om
  "FIXME: write documentation"
  [name]
  (let [data {:name name
              :sanitized (name-to-path name)}]
    (main/info "Generating fresh 'lein new' lein-quick-om project.")
    (->files data
             ["src/{{sanitized}}/core.cljs" (render "core.cljs" data)]
             ["src/{{sanitized}}/devbar.cljs" (render "devbar.cljs" data)]
             ["project.clj" (render "project.clj" data)]
             ["Dockerfile" (render "Dockerfile" data)]
             ["Makefile" (render "Makefile" data)]
             [".dockerignore" (render ".dockerignore" data)]
             ["resources/public/index.html" (render "index.html" data)]
             ["resources/public/css/style.css" (render "style.css" data)]
             )))

add devbar to template file list

add devbar to template file list


(ns lambdacd.new-ui
  (:use compojure.core)
  (:require [compojure.route :as route]
            [hiccup.core :as hc]
            [clojure.data.json :as json :only [write-str]]
            [lambdacd.presentation :as presentation]
            [lambdacd.manualtrigger :as manualtrigger]
            [lambdacd.util :as util]
            [ring.util.response :as resp]
            [lambdacd.execution :as execution]
            [lambdacd.pipeline-state :as pipeline-state]))
;; FIXME: proper hiccup here:
(def page-start "<html>
  <head>
  <title>LambdaCD - Pipeline</title>
  </head>
  <link rel=\"stylesheet\" type=\"text/css\" href=\"/ui2/semantic-ui/semantic.css\"/>
<link rel=\"stylesheet\" type=\"text/css\" href=\"/ui2/css/main.css\"/>
<body>")

(def page-end "<script src=\"//ajax.googleapis.com/ajax/libs/jquery/2.1.1/jquery.min.js\"></script>
<script src=\"/ui2/semantic-ui/semantic.js\"></script>
</body>
</html>")

(defn- icon-style-for [{status :status}]
  (case status
    :running "teal notched circle loading icon"
    :ok "green check circle icon"
    :failure "red remove circle icon"
    :waiting "blue wait circle icon"
    :unknown "yellow help circle icon"))

(defn- status-label-for [{status :status}]
  (case status
    :running "running..."
    :ok "successful"
    :failure "failure"
    :waiting "waiting..."
    :unknown "unknown"))

(defn history-item [item]
  [:li {:class "item"}
   [:div {:class "ui mini image"}
    [:i {:class (icon-style-for item)}]]
   [:div {:class "content"}
    [:div {:class "header"} (str "Build " (:build-number item))]
    [:div {:class "meta"} (status-label-for item)]]]
  )

(declare pipeline) ;; mutual recursion...

(defn- pipeline-step [build-state {name :name type :type children :children step-id :step-id}]
  (let [
        step-state (get build-state step-id)
        step-status (:status step-state)
        child-pipeline (pipeline children (not= type :parallel) build-state)
        title-div [:div.title name]
        content (if (empty? children)
                  title-div
                  (list title-div child-pipeline))
        result [:div.step {:data-step-id (str step-id) :data-status step-status}
                 [:div.content
                  content]]]
    result))

(defn- pipeline [p horizontal build-state]
  [:div {:class (if horizontal "div ui steps" "ui steps vertical")}
   (map (partial pipeline-step build-state) p)])

(defn history [h]
  (list [:h1 "Build History"]
        [:ul {:class "ui relaxed divided items"} (map history-item h)]))

(defn body [history content]
  (let [header [:h1 {:class "segment" } "LambdaCD"]
        history-column [:div {:class "ui three wide column"} history]
        content-column [:div {:class "ui thirteen wide column"} content]
        columns [:div {:class "ui segment stackable grid"} history-column content-column]
        body (hc/html (list header columns))]
    (str page-start page-end body page-end)))

(defn- pipeline-view [pipeline-def pipeline-state build-number]
  (let [build-history (pipeline-state/history-for pipeline-state)
        pipeline-state-for-build (get pipeline-state (Integer/parseInt build-number))]
    (println "build number" build-number)
    (body (history build-history)
          (pipeline (presentation/display-representation pipeline-def) true pipeline-state-for-build))))

(defn new-ui-routes [pipeline-def pipeline-state]
  (routes
    (GET "/:build-number" [build-number] (pipeline-view pipeline-def @pipeline-state build-number))
    (GET "/" [] (resp/redirect (str "./" (pipeline-state/most-recent-build-number-in @pipeline-state))))))

(ns lambdacd.new-ui
  (:use compojure.core)
  (:require [compojure.route :as route]
            [hiccup.core :as hc]
            [clojure.data.json :as json :only [write-str]]
            [lambdacd.presentation :as presentation]
            [lambdacd.manualtrigger :as manualtrigger]
            [lambdacd.util :as util]
            [ring.util.response :as resp]
            [lambdacd.execution :as execution]
            [lambdacd.pipeline-state :as pipeline-state]))
;; FIXME: proper hiccup here:
(def page-start "<html>
  <head>
  <title>LambdaCD - Pipeline</title>
  </head>
   <meta http-equiv=\"refresh\" content=\"5\">
  <link rel=\"stylesheet\" type=\"text/css\" href=\"/ui2/semantic-ui/semantic.css\"/>
<link rel=\"stylesheet\" type=\"text/css\" href=\"/ui2/css/main.css\"/>
<body>")

(def page-end "<script src=\"//ajax.googleapis.com/ajax/libs/jquery/2.1.1/jquery.min.js\"></script>
<script src=\"/ui2/semantic-ui/semantic.js\"></script>
</body>
</html>")

(defn- icon-style-for [{status :status}]
  (case status
    :running "teal notched circle loading icon"
    :ok "green check circle icon"
    :failure "red remove circle icon"
    :waiting "blue wait circle icon"
    :unknown "yellow help circle icon"))

(defn- status-label-for [{status :status}]
  (case status
    :running "running..."
    :ok "successful"
    :failure "failure"
    :waiting "waiting..."
    :unknown "unknown"))

(defn history-item [item]
  [:li {:class "item"}
   [:div {:class "ui mini image"}
    [:i {:class (icon-style-for item)}]]
   [:div {:class "content"}
    [:div {:class "header"} (str "Build " (:build-number item))]
    [:div {:class "meta"} (status-label-for item)]]]
  )

(declare pipeline) ;; mutual recursion...

(defn- pipeline-step [build-state {name :name type :type children :children step-id :step-id}]
  (let [
        step-state (get build-state step-id)
        step-status (:status step-state)
        child-pipeline (pipeline children (not= type :parallel) build-state)
        title-div [:div.title name]
        content (if (empty? children)
                  title-div
                  (list title-div child-pipeline))
        result [:div.step {:data-step-id (str step-id) :data-status step-status}
                 [:div.content
                  content]]]
    result))

(defn- pipeline [p horizontal build-state]
  [:div {:class (if horizontal "div ui steps" "ui steps vertical")}
   (map (partial pipeline-step build-state) p)])

(defn history [h]
  (list [:h1 "Build History"]
        [:ul {:class "ui relaxed divided items"} (map history-item h)]))

(defn body [history content]
  (let [header [:h1 {:class "segment" } "LambdaCD"]
        history-column [:div {:class "ui three wide column"} history]
        content-column [:div {:class "ui thirteen wide column"} content]
        columns [:div {:class "ui segment stackable grid"} history-column content-column]
        body (hc/html (list header columns))]
    (str page-start page-end body page-end)))

(defn- pipeline-view [pipeline-def pipeline-state build-number]
  (let [build-history (pipeline-state/history-for pipeline-state)
        pipeline-state-for-build (get pipeline-state (Integer/parseInt build-number))]
    (println "build number" build-number)
    (body (history build-history)
          (pipeline (presentation/display-representation pipeline-def) true pipeline-state-for-build))))

(defn new-ui-routes [pipeline-def pipeline-state]
  (routes
    (GET "/:build-number" [build-number] (pipeline-view pipeline-def @pipeline-state build-number))
    (GET "/" [] (resp/redirect (str "./" (pipeline-state/most-recent-build-number-in @pipeline-state))))))

refresh new ui every 5 seconds

refresh new ui every 5 seconds


(ns frontend.components.builds-table
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.datetime :as datetime]
            [frontend.components.common :as common]
            [frontend.components.forms :as forms]
            [frontend.models.build :as build-model]
            [frontend.models.feature :as feature]
            [frontend.utils :as utils :include-macros true]
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true])
  (:require-macros [frontend.utils :refer [html]]))

(defn build-row [build owner {:keys [show-actions? show-branch? show-project?]}]
  (let [url (build-model/path-for (select-keys build [:vcs_url]) build)]
    [:tr {:class (when (:dont_build build) "dont_build")}
     [:td
      [:a {:title (str (:username build) "/" (:reponame build) " #" (:build_num build))
          :href url}
       (when show-project? (str (:username build) "/" (:reponame build) " ")) "#" (:build_num build)]]
     [:td
      (if-not (:vcs_revision build)
        [:a {:href url}]
        [:a {:title (build-model/github-revision build)
             :href url}
         (build-model/github-revision build)])]
     (when show-branch?
       [:td
        [:a
         {:title (build-model/vcs-ref-name build)
          :href url}
         (-> build build-model/vcs-ref-name (utils/trim-middle 23))]])
     [:td.recent-user
      [:a
       {:title (build-model/ui-user build)
        :href url}
       (build-model/author build)]]
     [:td.recent-log
      [:a
       {:title (:body build)
        :href url}
       (:subject build)]]
     (if (or (not (:start_time build))
             (= "not_run" (:status build)))
       [:td {:col-span 2}]
       (list [:td.recent-time
              [:a
               {:title  (datetime/full-datetime (js/Date.parse (:start_time build)))
                :href url}
               (om/build common/updating-duration {:start (:start_time build)} {:opts {:formatter datetime/time-ago}})
               " ago"]]
             [:td.recent-time
              [:a
               {:title (build-model/duration build)
                :href url}
               (om/build common/updating-duration {:start (:start_time build)
                                                   :stop (:stop_time build)})]]))
     [:td.recent-status-badge
      [:a
       {:title "status"
        :href url
        :class (build-model/status-class build)}
       (build-model/status-words build)]]
     (when show-actions?
       [:td.build_actions
        (when (build-model/can-cancel? build)
          (let [build-id (build-model/id build)
                vcs-url (:vcs_url build)
                build-num (:build_num build)]
            ;; TODO: how are we going to get back to the correct build in the app-state?
            ;;       Not a problem here, b/c the websocket will be updated, but something to think about
            (forms/managed-button
             [:button.cancel_build
              {:on-click #(raise! owner [:cancel-build-clicked {:build-id build-id
                                                                :vcs-url vcs-url
                                                                :build-num build-num}])}
              "Cancel"])))])]))

(defn builds-table-v1 [builds owner {:keys [show-actions? show-branch? show-project?]
                                     :or {show-branch? true
                                          show-project? true}}]
  (reify
    om/IDisplayName (display-name [_] "Builds Table V1")
    om/IRender
    (render [_]
      (html
       [:table.recent-builds-table
        [:thead
         [:tr
          [:th "Build"]
          [:th "Revision"]
          (when show-branch?
            [:th "Branch"])
          [:th "Author"]
          [:th "Log"]
          [:th.condense "Started"]
          [:th.condense "Length"]
          [:th.condense "Status"]
          (when show-actions?
            [:th.condense "Actions"])]]
        [:tbody
         (map #(build-row % owner {:show-actions? show-actions?
                                   :show-branch? show-branch?
                                   :show-project? show-project?})
              builds)]]))))

(defn dashboard-icon [name]
  [:img.dashboard-icon { :src (utils/cdn-path (str "/img/inner/icons/" name ".svg"))}])

(defn build-row-v2 [build owner {:keys [show-actions? show-branch? show-project?]}]
  (let [url (build-model/path-for (select-keys build [:vcs_url]) build)]
    [:div.build {:class (when (:dont_build build) "dont_build")}
     [:div.status-area
      [:div.recent-status-badge
       [:a
        {:title "status"
         :href url
         :class (build-model/status-class build)}
        (build-model/status-words build)]]

      (when show-actions?
        [:td.build_actions
         (when (build-model/can-cancel? build)
           (let [build-id (build-model/id build)
                 vcs-url (:vcs_url build)
                 build-num (:build_num build)]
             ;; TODO: how are we going to get back to the correct build in the app-state?
             ;;       Not a problem here, b/c the websocket will be updated, but something to think about
             (forms/managed-button
               [:button.cancel_build
                {:on-click #(raise! owner [:cancel-build-clicked {:build-id build-id
                                                                  :vcs-url vcs-url
                                                                  :build-num build-num}])}
                "Cancel"])))])]
     [:div.build-info
      [:div.build-info-header
       [:div.contextual-identifier
        [:a {:title (str (:username build) "/" (:reponame build) " #" (:build_num build))
             :href url}

         (when show-project?
           (str (:username build) " / " (:reponame build) " "))

         (when (and show-project? show-branch?) " / ")

         (when show-branch?
           [:a
            {:title (build-model/vcs-ref-name build)
             :href url}
            (-> build build-model/vcs-ref-name)])
         " #"
         (:build_num build)]]

       [:div.metadata
        [:div.metadata-item
         (if-not (:vcs_revision build)
           [:a {:href url}]
           (list (dashboard-icon "Builds-CommitNumber")
                 [:a {:title (build-model/github-revision build)
                      :href url}
                  (build-model/github-revision build)]))]

        [:div.metadata-item.recent-user
         {:title (build-model/ui-user build)}
          (when-let [author (build-model/author build)]
            (list
              (dashboard-icon "Builds-Author")
              author))]

        (if (or (not (:start_time build))
                (= "not_run" (:status build)))
          nil
          (list [:div.metadata-item.recent-time
                 {:title  (datetime/full-datetime (js/Date.parse (:start_time build))) }
                 (dashboard-icon "Builds-StartTime")
                 (om/build common/updating-duration {:start (:start_time build)} {:opts {:formatter datetime/time-ago}})
                  " ago"]
                [:div.metadata-item.recent-time
                 {:title (build-model/duration build)}
                 (dashboard-icon "Builds-Duration")
                 (om/build common/updating-duration {:start (:start_time build)
                                                     :stop (:stop_time build)})]))]]
      [:div.recent-commit-msg
       [:a.recent-log
        {:title (:body build)
         :href url}
        (:subject build)]]]]))

(defn builds-table-v2 [builds owner {:keys [show-actions? show-branch? show-project?]
                                     :or {show-branch? true
                                          show-project? true}}]
  (reify
    om/IDisplayName (display-name [_] "Builds Table V2")
    om/IRender
    (render [_]
      (html
        [:div.container-fluid
         (map #(build-row-v2 % owner {:show-actions? show-actions?
                                      :show-branch? show-branch?
                                      :show-project? show-project?})
              builds)]))))

(defn builds-table [builds owner opts]
  (if (feature/enabled? :ui-v2)
    (builds-table-v2 builds owner opts)
    (builds-table-v1 builds owner opts)))

(ns frontend.components.builds-table
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.datetime :as datetime]
            [frontend.components.common :as common]
            [frontend.components.forms :as forms]
            [frontend.models.build :as build-model]
            [frontend.models.feature :as feature]
            [frontend.utils :as utils :include-macros true]
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true])
  (:require-macros [frontend.utils :refer [html]]))

(defn build-row [build owner {:keys [show-actions? show-branch? show-project?]}]
  (let [url (build-model/path-for (select-keys build [:vcs_url]) build)]
    [:tr {:class (when (:dont_build build) "dont_build")}
     [:td
      [:a {:title (str (:username build) "/" (:reponame build) " #" (:build_num build))
          :href url}
       (when show-project? (str (:username build) "/" (:reponame build) " ")) "#" (:build_num build)]]
     [:td
      (if-not (:vcs_revision build)
        [:a {:href url}]
        [:a {:title (build-model/github-revision build)
             :href url}
         (build-model/github-revision build)])]
     (when show-branch?
       [:td
        [:a
         {:title (build-model/vcs-ref-name build)
          :href url}
         (-> build build-model/vcs-ref-name (utils/trim-middle 23))]])
     [:td.recent-user
      [:a
       {:title (build-model/ui-user build)
        :href url}
       (build-model/author build)]]
     [:td.recent-log
      [:a
       {:title (:body build)
        :href url}
       (:subject build)]]
     (if (or (not (:start_time build))
             (= "not_run" (:status build)))
       [:td {:col-span 2}]
       (list [:td.recent-time
              [:a
               {:title  (datetime/full-datetime (js/Date.parse (:start_time build)))
                :href url}
               (om/build common/updating-duration {:start (:start_time build)} {:opts {:formatter datetime/time-ago}})
               " ago"]]
             [:td.recent-time
              [:a
               {:title (build-model/duration build)
                :href url}
               (om/build common/updating-duration {:start (:start_time build)
                                                   :stop (:stop_time build)})]]))
     [:td.recent-status-badge
      [:a
       {:title "status"
        :href url
        :class (build-model/status-class build)}
       (build-model/status-words build)]]
     (when show-actions?
       [:td.build_actions
        (when (build-model/can-cancel? build)
          (let [build-id (build-model/id build)
                vcs-url (:vcs_url build)
                build-num (:build_num build)]
            ;; TODO: how are we going to get back to the correct build in the app-state?
            ;;       Not a problem here, b/c the websocket will be updated, but something to think about
            (forms/managed-button
             [:button.cancel_build
              {:on-click #(raise! owner [:cancel-build-clicked {:build-id build-id
                                                                :vcs-url vcs-url
                                                                :build-num build-num}])}
              "Cancel"])))])]))

(defn builds-table-v1 [builds owner {:keys [show-actions? show-branch? show-project?]
                                     :or {show-branch? true
                                          show-project? true}}]
  (reify
    om/IDisplayName (display-name [_] "Builds Table V1")
    om/IRender
    (render [_]
      (html
       [:table.recent-builds-table
        [:thead
         [:tr
          [:th "Build"]
          [:th "Revision"]
          (when show-branch?
            [:th "Branch"])
          [:th "Author"]
          [:th "Log"]
          [:th.condense "Started"]
          [:th.condense "Length"]
          [:th.condense "Status"]
          (when show-actions?
            [:th.condense "Actions"])]]
        [:tbody
         (map #(build-row % owner {:show-actions? show-actions?
                                   :show-branch? show-branch?
                                   :show-project? show-project?})
              builds)]]))))

(defn dashboard-icon [name]
  [:img.dashboard-icon { :src (utils/cdn-path (str "/img/inner/icons/" name ".svg"))}])

(defn build-row-v2 [build owner {:keys [show-actions? show-branch? show-project?]}]
  (let [url (build-model/path-for (select-keys build [:vcs_url]) build)]
    [:div.build {:class (when (:dont_build build) "dont_build")}
     [:div.status-area
      [:div.recent-status-badge
       [:a
        {:title "status"
         :href url
         :class (build-model/status-class build)}
        (build-model/status-words build)]]

      (when show-actions?
        [:td.build_actions
         (when (build-model/can-cancel? build)
           (let [build-id (build-model/id build)
                 vcs-url (:vcs_url build)
                 build-num (:build_num build)]
             ;; TODO: how are we going to get back to the correct build in the app-state?
             ;;       Not a problem here, b/c the websocket will be updated, but something to think about
             (forms/managed-button
               [:button.cancel_build
                {:on-click #(raise! owner [:cancel-build-clicked {:build-id build-id
                                                                  :vcs-url vcs-url
                                                                  :build-num build-num}])}
                "Cancel"])))])]
     [:div.build-info
      [:div.build-info-header
       [:div.contextual-identifier
        [:a {:title (str (:username build) "/" (:reponame build) " #" (:build_num build))
             :href url}

         (when show-project?
           (str (:username build) " / " (:reponame build) " "))

         (when (and show-project? show-branch?) " / ")

         (when show-branch?
           [:a
            {:title (build-model/vcs-ref-name build)
             :href url}
            (-> build build-model/vcs-ref-name)])
         " #"
         (:build_num build)]]

       [:div.metadata
        [:div.metadata-item
         (if-not (:vcs_revision build)
           [:a {:href url}]
           (list (dashboard-icon "Builds-CommitNumber")
                 [:a {:title (build-model/github-revision build)
                      :href url}
                  (build-model/github-revision build)]))]

        (when-let [author (build-model/author build)]
          [:div.metadata-item.recent-user
           {:title (build-model/ui-user build)}
           (dashboard-icon "Builds-Author")
           author])

        (if (or (not (:start_time build))
                (= "not_run" (:status build)))
          nil
          (list [:div.metadata-item.recent-time
                 {:title  (datetime/full-datetime (js/Date.parse (:start_time build))) }
                 (dashboard-icon "Builds-StartTime")
                 (om/build common/updating-duration {:start (:start_time build)} {:opts {:formatter datetime/time-ago}})
                  " ago"]
                [:div.metadata-item.recent-time
                 {:title (build-model/duration build)}
                 (dashboard-icon "Builds-Duration")
                 (om/build common/updating-duration {:start (:start_time build)
                                                     :stop (:stop_time build)})]))]]
      [:div.recent-commit-msg
       [:a.recent-log
        {:title (:body build)
         :href url}
        (:subject build)]]]]))

(defn builds-table-v2 [builds owner {:keys [show-actions? show-branch? show-project?]
                                     :or {show-branch? true
                                          show-project? true}}]
  (reify
    om/IDisplayName (display-name [_] "Builds Table V2")
    om/IRender
    (render [_]
      (html
        [:div.container-fluid
         (map #(build-row-v2 % owner {:show-actions? show-actions?
                                      :show-branch? show-branch?
                                      :show-project? show-project?})
              builds)]))))

(defn builds-table [builds owner opts]
  (if (feature/enabled? :ui-v2)
    (builds-table-v2 builds owner opts)
    (builds-table-v1 builds owner opts)))

Fix accidental padding introduced by empty div