(ns slide-explorer.view
  (:import (javax.swing AbstractAction JComponent JFrame JPanel JLabel KeyStroke)
           (java.awt Color Graphics Graphics2D Rectangle RenderingHints Window)
           (java.util UUID)
           (java.awt.event ComponentAdapter KeyEvent KeyAdapter
                           MouseAdapter WindowAdapter)
           (org.micromanager.utils GUIUpdater))
  (:require [clojure.pprint :as pprint])
  (:use [org.micromanager.mm :only (edt)]
        [slide-explorer.paint :only (enable-anti-aliasing)]
        [slide-explorer.image :only (crop merge-and-scale overlay overlay-memo lut-object)]))
ftile
; Order of operations:
;  Stitch/crop
;  Flatten fields
;  Max intensity projection (z)
;  Rescale
;  Color Overlay

(def MIN-ZOOM 1/256)

(def MAX-ZOOM 1)

(def display-updater (GUIUpdater.))

;; TESTING UTILITIES

(defn reference-viewer [reference key]
  (let [frame (JFrame. key)
        label (JLabel.)
        update-fn #(edt (.setText label (.toString %)))]
    (.add (.getContentPane frame) label)
    (add-watch reference key
               (fn [_ _ _ new-state] (update-fn new-state)))
    (update-fn @reference)
    (doto frame
      (.addWindowListener
        (proxy [WindowAdapter] []
          (windowClosing [e]
                         (remove-watch reference key))))
      .show))
  reference)

(defmacro timer [expr]
  `(let [ret# ~expr] ; (time ~expr)]
    ; (print '~expr)
    ; (println " -->" (pr-str ret#))
     ret#))

;; GUI UTILITIES

(defn window-descendants
  "Returns a depth-first seq of all components contained by window."
  [window]
  (tree-seq (constantly true)
            #(.getComponents %)
            window))

;; TILE <--> PIXELS

(defn floor-int [x]
  (long (Math/floor x)))

(defn tile-to-pixels [[nx ny] [tile-width tile-height] tile-zoom]
  [(int (* tile-zoom nx tile-width))
   (int (* tile-zoom ny tile-height))])

(defn tiles-in-pixel-rectangle
  "Returns a list of tile indices found in a given pixel rectangle."
  [rectangle [tile-width tile-height]]
  (let [nl (floor-int (/ (.x rectangle) tile-width))
        nr (floor-int (/ (+ -1 (.getWidth rectangle) (.x rectangle)) tile-width))
        nt (floor-int (/ (.y rectangle) tile-height))
        nb (floor-int (/ (+ -1 (.getHeight rectangle) (.y rectangle)) tile-height))]
    (for [nx (range nl (inc nr))
          ny (range nt (inc nb))]
      [nx ny])))

(defn unzoomed-rectangle
  [rectangle zoom]
  (Rectangle. (/ (.x rectangle) zoom)
              (/ (.y rectangle) zoom)
              (/ (.width rectangle) zoom)
              (/ (.height rectangle) zoom)))

(defn tiles-in-unzoomed-pixel-rectangle
  [rectangle [tile-width tile-height] zoom]
  (tiles-in-pixel-rectangle (unzoomed-rectangle rectangle zoom)
                            [tile-width tile-height]))

;; TILING

(defn add-tile [tile-map tile-zoom indices tile]
  (assoc-in tile-map [tile-zoom indices] tile))

(defn propagate-tiles [tile-map zoom {:keys [nx ny nz nt nc] :as indices}]
  (when-let [parent-layer (tile-map (* zoom 2))]
    (let [nx- (* 2 nx)
          ny- (* 2 ny)
          nx+ (inc nx-)
          ny+ (inc ny-)
          a (parent-layer (assoc indices :nx nx- :ny ny-))
          b (parent-layer (assoc indices :nx nx+ :ny ny-))
          c (parent-layer (assoc indices :nx nx- :ny ny+))
          d (parent-layer (assoc indices :nx nx+ :ny ny+))]
      (add-tile tile-map zoom
                (assoc indices :nx nx :ny ny)
                (merge-and-scale a b c d)))))

(defn child-index [n]
  (floor-int (/ n 2)))

(defn child-indices [indices]
  (-> indices
     (update-in [:nx] child-index)
     (update-in [:ny] child-index)))

(defn add-and-propagate-tiles [tile-map indices tile]
  (loop [tile-map (add-tile tile-map 1 indices tile)
         new-indices (child-indices indices)
         zoom 1/2]
    (if (<= MIN-ZOOM zoom)
      (recur (propagate-tiles tile-map zoom new-indices)
             (child-indices new-indices)
             (/ zoom 2))
      tile-map)))

(defn add-to-available-tiles [tile-map-agent indices tile]
  (send tile-map-agent add-and-propagate-tiles indices tile))

;; PAINTING

(defn multi-color-tile [available-tiles zoom tile-indices channels-map]
  (let [channel-names (keys channels-map)]
    (overlay-memo
      (for [chan channel-names]
        (get-in available-tiles [zoom (assoc tile-indices :nc chan)]))
      (for [chan channel-names]
        (get-in channels-map [chan :lut])))))

(defn paint-tiles [^Graphics2D g available-tiles screen-state [tile-width tile-height]]
  (let [pixel-rect (.getClipBounds g)]
    (doseq [[nx ny] (tiles-in-pixel-rectangle pixel-rect
                                              [tile-width tile-height])]
      (when-let [image (multi-color-tile available-tiles
                                         (screen-state :zoom)
                                         {:nx nx :ny ny :nt 0
                                          :nz (screen-state :z)}
                                         (:channels screen-state))]
        (let [[x y] (tile-to-pixels [nx ny] [tile-width tile-height] 1)]
          (.drawImage g image x y nil))))))

(defn paint-screen [graphics screen-state available-tiles]
  (let [original-transform (.getTransform graphics)
        zoom (:zoom screen-state)
        x-center (/ (screen-state :width) 2)
        y-center (/ (screen-state :height) 2)]
    (doto graphics
      (.setClip 0 0 (:width screen-state) (:height screen-state))
      (.translate (- x-center (int (* (:x screen-state) zoom)))
                  (- y-center (int (* (:y screen-state) zoom))))
      (paint-tiles available-tiles screen-state [512 512])
      enable-anti-aliasing
      (.setColor (Color. 0x0CB397))
      (.fillOval -5 -5
                 10 10)
      (.setTransform original-transform)
      (.setColor (Color. 0xECF2AA))
      (.drawString (str (select-keys screen-state [:x :y :z :zoom :keys]))
                   (int 0)
                   (int (- (screen-state :height) 12))))))

;; USER INPUT HANDLING

(defn display-follow [panel reference]
  (add-watch reference "display"
             (fn [_ _ _ _]
                (.post display-updater #(.repaint panel)))))

;; key binding

(defn bind-key
  "Maps an input-key on a swing component to an action,
  such that action-fn is executed when key is pressed."
  [component input-key action-fn global?]
  (let [im (.getInputMap component (if global?
                                     JComponent/WHEN_IN_FOCUSED_WINDOW
                                     JComponent/WHEN_FOCUSED))
        am (.getActionMap component)
        input-event (KeyStroke/getKeyStroke input-key)
        action
          (proxy [AbstractAction] []
            (actionPerformed [e]
                (action-fn)))
        uuid (.. UUID randomUUID toString)]
    (.put im input-event uuid)
    (.put am uuid action)))

(defn bind-keys
  [component input-keys action-fn global?]
  (dorun (map #(bind-key component % action-fn global?) input-keys)))

(defn bind-window-keys
  [window input-keys action-fn]
  (bind-keys (.getContentPane window) input-keys action-fn true))

;; full screen

(defn- default-screen-device [] ; borrowed from see-saw
  (->
    (java.awt.GraphicsEnvironment/getLocalGraphicsEnvironment)
    .getDefaultScreenDevice))

(defn full-screen!
  "Make the given window/frame full-screen. Pass nil to return all windows
to normal size."
  ([^java.awt.GraphicsDevice device window]
    (if window
      (when (not= (.getFullScreenWindow device) window)
        (.dispose window)
        (.setUndecorated window true)
        (.setFullScreenWindow device window)
        (.show window))
      (when-let [window (.getFullScreenWindow device)]
        (.dispose window)
        (.setFullScreenWindow device nil)
        (.setUndecorated window false)
        (.show window)))
    window)
  ([window]
    (full-screen! (default-screen-device) window)))

(defn setup-fullscreen [window]
  (bind-window-keys window ["F"] #(full-screen! window))
  (bind-window-keys window ["ESCAPE"] #(full-screen! nil)))

;; positional controls

(defn pan! [position-atom axis distance]
  (let [zoom (@position-atom :zoom)]
    (swap! position-atom update-in [axis]
           - (/ distance zoom))))

(defn handle-drags [component position-atom]
  (let [drag-origin (atom nil)
        mouse-adapter
        (proxy [MouseAdapter] []
          (mousePressed [e]
                        (reset! drag-origin {:x (.getX e) :y (.getY e)}))
          (mouseReleased [e]
                         (reset! drag-origin nil))
          (mouseDragged [e]
                        (let [x (.getX e) y (.getY e)]
                          (pan! position-atom :x (- x (:x @drag-origin)))
                          (pan! position-atom :y (- y (:y @drag-origin)))
                          (reset! drag-origin {:x x :y y}))))]
    (doto component
      (.addMouseListener mouse-adapter)
      (.addMouseMotionListener mouse-adapter))
    position-atom))

(defn handle-arrow-pan [component position-atom]
  (let [binder (fn [key axis step]
                 (bind-key component key
                           #(pan! position-atom axis step) true))]
    (binder "UP" :y 50)
    (binder "DOWN" :y -50)
    (binder "RIGHT" :x -50)
    (binder "LEFT" :x 50)))

(defn handle-wheel [component z-atom]
  (.addMouseWheelListener component
    (proxy [MouseAdapter] []
      (mouseWheelMoved [e]
                       (swap! z-atom update-in [:z]
                              + (.getWheelRotation e)))))
  z-atom)

(defn handle-resize [component size-atom]
  (let [update-size #(let [bounds (.getBounds component)]
                       (swap! size-atom merge
                              {:width (.getWidth bounds)
                               :height (.getHeight bounds)}))]
    (update-size)
    (.addComponentListener component
      (proxy [ComponentAdapter] []
        (componentResized [e]
                          (update-size)))))
  size-atom)

(defn handle-dive [window dive-atom]
  (bind-window-keys window ["COMMA"] #(swap! dive-atom update-in [:z] dec))
  (bind-window-keys window ["PERIOD"] #(swap! dive-atom update-in [:z] inc)))

(defn handle-zoom [window zoom-atom]
  (bind-window-keys window ["ADD" "CLOSE_BRACKET"]
                   (fn [] (swap! zoom-atom update-in [:zoom]
                                 #(min (* % 2) MAX-ZOOM))))
  (bind-window-keys window ["SUBTRACT" "OPEN_BRACKET"]
                   (fn [] (swap! zoom-atom update-in [:zoom]
                                 #(max (/ % 2) MIN-ZOOM)))))

(defn watch-keys [window key-atom]
  (let [key-adapter (proxy [KeyAdapter] []
                      (keyPressed [e]
                                  (swap! key-atom update-in [:keys] conj
                                         (KeyEvent/getKeyText (.getKeyCode e))))
                      (keyReleased [e]
                                   (swap! key-atom update-in [:keys] disj
                                          (KeyEvent/getKeyText (.getKeyCode e)))))]
    (doseq [component (window-descendants window)]
      (.addKeyListener component key-adapter))))

(defn handle-pointing [component pointing-atom]
  (.addMouseMotionListener component
                     (proxy [MouseAdapter] []
                       (mouseMoved [e]
                                   (swap! pointing-atom merge {:x (.getX e)
                                                               :y (.getY e)})))))

(defn add-channel [screen-state-atom name color min max gamma]
  (swap! update-in [:channels name] (lut-object color min max gamma)))

;; MAIN WINDOW AND PANEL

(defn main-panel [screen-state available-tiles]
  (doto
    (proxy [JPanel] []
      (paintComponent [^Graphics graphics]
        (proxy-super paintComponent graphics)
        (paint-screen graphics @screen-state @available-tiles)))
    (.setBackground Color/BLACK)))

(defn main-frame []
  (doto (JFrame. "Slide Explorer II")
    .show
    (.setBounds 10 10 500 500)))

(defn show [available-tiles]
  (let [screen-state (atom (sorted-map :x 0 :y 0 :z 0 :zoom 1
                                       :keys (sorted-set)
                                       :channels (sorted-map)))
        panel (main-panel screen-state available-tiles)
        frame (main-frame)
        mouse-position (atom nil)]
    (def at available-tiles)
    (def ss screen-state)
    (def mp mouse-position)
    (def f frame)
    (def pnl panel)
    (.add (.getContentPane frame) panel)
    (setup-fullscreen frame)
    (handle-drags panel screen-state)
    (handle-arrow-pan panel screen-state)
    (handle-wheel panel screen-state)
    (handle-resize panel screen-state)
    (handle-zoom frame screen-state)
    (handle-dive frame screen-state)
    (watch-keys frame screen-state)
    (display-follow panel screen-state)
    (display-follow panel available-tiles)
    (handle-pointing panel mouse-position)
    screen-state))

(ns slide-explorer.view
  (:import (javax.swing AbstractAction JComponent JFrame JPanel JLabel KeyStroke)
           (java.awt Color Graphics Graphics2D Rectangle RenderingHints Window)
           (java.util UUID)
           (java.awt.event ComponentAdapter KeyEvent KeyAdapter
                           MouseAdapter WindowAdapter)
           (org.micromanager.utils GUIUpdater))
  (:require [clojure.pprint :as pprint])
  (:use [org.micromanager.mm :only (edt)]
        [slide-explorer.paint :only (enable-anti-aliasing)]
        [slide-explorer.image :only (crop merge-and-scale overlay overlay-memo lut-object)]))

; Order of operations:
;  Stitch/crop
;  Flatten fields
;  Max intensity projection (z)
;  Rescale
;  Color Overlay

(def MIN-ZOOM 1/256)

(def MAX-ZOOM 1)

(def display-updater (GUIUpdater.))

;; TESTING UTILITIES

(defn reference-viewer [reference key]
  (let [frame (JFrame. key)
        label (JLabel.)
        update-fn #(edt (.setText label (.toString %)))]
    (.add (.getContentPane frame) label)
    (add-watch reference key
               (fn [_ _ _ new-state] (update-fn new-state)))
    (update-fn @reference)
    (doto frame
      (.addWindowListener
        (proxy [WindowAdapter] []
          (windowClosing [e]
                         (remove-watch reference key))))
      .show))
  reference)

(defmacro timer [expr]
  `(let [ret# ~expr] ; (time ~expr)]
    ; (print '~expr)
    ; (println " -->" (pr-str ret#))
     ret#))

;; GUI UTILITIES

(defn window-descendants
  "Returns a depth-first seq of all components contained by window."
  [window]
  (tree-seq (constantly true)
            #(.getComponents %)
            window))

;; TILE <--> PIXELS

(defn floor-int [x]
  (long (Math/floor x)))

(defn tile-to-pixels [[nx ny] [tile-width tile-height] tile-zoom]
  [(int (* tile-zoom nx tile-width))
   (int (* tile-zoom ny tile-height))])

(defn tiles-in-pixel-rectangle
  "Returns a list of tile indices found in a given pixel rectangle."
  [rectangle [tile-width tile-height]]
  (let [nl (floor-int (/ (.x rectangle) tile-width))
        nr (floor-int (/ (+ -1 (.getWidth rectangle) (.x rectangle)) tile-width))
        nt (floor-int (/ (.y rectangle) tile-height))
        nb (floor-int (/ (+ -1 (.getHeight rectangle) (.y rectangle)) tile-height))]
    (for [nx (range nl (inc nr))
          ny (range nt (inc nb))]
      [nx ny])))

(defn unzoomed-rectangle
  [rectangle zoom]
  (Rectangle. (/ (.x rectangle) zoom)
              (/ (.y rectangle) zoom)
              (/ (.width rectangle) zoom)
              (/ (.height rectangle) zoom)))

(defn tiles-in-unzoomed-pixel-rectangle
  [rectangle [tile-width tile-height] zoom]
  (tiles-in-pixel-rectangle (unzoomed-rectangle rectangle zoom)
                            [tile-width tile-height]))

;; TILING

(defn add-tile [tile-map tile-zoom indices tile]
  (assoc-in tile-map [tile-zoom indices] tile))

(defn propagate-tiles [tile-map zoom {:keys [nx ny nz nt nc] :as indices}]
  (when-let [parent-layer (tile-map (* zoom 2))]
    (let [nx- (* 2 nx)
          ny- (* 2 ny)
          nx+ (inc nx-)
          ny+ (inc ny-)
          a (parent-layer (assoc indices :nx nx- :ny ny-))
          b (parent-layer (assoc indices :nx nx+ :ny ny-))
          c (parent-layer (assoc indices :nx nx- :ny ny+))
          d (parent-layer (assoc indices :nx nx+ :ny ny+))]
      (add-tile tile-map zoom
                (assoc indices :nx nx :ny ny)
                (merge-and-scale a b c d)))))

(defn child-index [n]
  (floor-int (/ n 2)))

(defn child-indices [indices]
  (-> indices
     (update-in [:nx] child-index)
     (update-in [:ny] child-index)))

(defn add-and-propagate-tiles [tile-map indices tile]
  (loop [tile-map (add-tile tile-map 1 indices tile)
         new-indices (child-indices indices)
         zoom 1/2]
    (if (<= MIN-ZOOM zoom)
      (recur (propagate-tiles tile-map zoom new-indices)
             (child-indices new-indices)
             (/ zoom 2))
      tile-map)))

(defn add-to-available-tiles [tile-map-agent indices tile]
  (send tile-map-agent add-and-propagate-tiles indices tile))

;; PAINTING

(defn multi-color-tile [available-tiles zoom tile-indices channels-map]
  (let [channel-names (keys channels-map)]
    (overlay-memo
      (for [chan channel-names]
        (get-in available-tiles [zoom (assoc tile-indices :nc chan)]))
      (for [chan channel-names]
        (get-in channels-map [chan :lut])))))

(defn paint-tiles [^Graphics2D g available-tiles screen-state [tile-width tile-height]]
  (let [pixel-rect (.getClipBounds g)]
    (doseq [[nx ny] (tiles-in-pixel-rectangle pixel-rect
                                              [tile-width tile-height])]
      (when-let [image (multi-color-tile available-tiles
                                         (screen-state :zoom)
                                         {:nx nx :ny ny :nt 0
                                          :nz (screen-state :z)}
                                         (:channels screen-state))]
        (let [[x y] (tile-to-pixels [nx ny] [tile-width tile-height] 1)]
          (.drawImage g image x y nil))))))

(defn paint-screen [graphics screen-state available-tiles]
  (let [original-transform (.getTransform graphics)
        zoom (:zoom screen-state)
        x-center (/ (screen-state :width) 2)
        y-center (/ (screen-state :height) 2)]
    (doto graphics
      (.setClip 0 0 (:width screen-state) (:height screen-state))
      (.translate (- x-center (int (* (:x screen-state) zoom)))
                  (- y-center (int (* (:y screen-state) zoom))))
      (paint-tiles available-tiles screen-state [512 512])
      enable-anti-aliasing
      (.setColor (Color. 0x0CB397))
      (.fillOval -5 -5
                 10 10)
      (.setTransform original-transform)
      (.setColor (Color. 0xECF2AA))
      (.drawString (str (select-keys screen-state [:x :y :z :zoom :keys]))
                   (int 0)
                   (int (- (screen-state :height) 12))))))

;; USER INPUT HANDLING

(defn display-follow [panel reference]
  (add-watch reference "display"
             (fn [_ _ _ _]
                (.post display-updater #(.repaint panel)))))

;; key binding

(defn bind-key
  "Maps an input-key on a swing component to an action,
  such that action-fn is executed when key is pressed."
  [component input-key action-fn global?]
  (let [im (.getInputMap component (if global?
                                     JComponent/WHEN_IN_FOCUSED_WINDOW
                                     JComponent/WHEN_FOCUSED))
        am (.getActionMap component)
        input-event (KeyStroke/getKeyStroke input-key)
        action
          (proxy [AbstractAction] []
            (actionPerformed [e]
                (action-fn)))
        uuid (.. UUID randomUUID toString)]
    (.put im input-event uuid)
    (.put am uuid action)))

(defn bind-keys
  [component input-keys action-fn global?]
  (dorun (map #(bind-key component % action-fn global?) input-keys)))

(defn bind-window-keys
  [window input-keys action-fn]
  (bind-keys (.getContentPane window) input-keys action-fn true))

;; full screen

(defn- default-screen-device [] ; borrowed from see-saw
  (->
    (java.awt.GraphicsEnvironment/getLocalGraphicsEnvironment)
    .getDefaultScreenDevice))

(defn full-screen!
  "Make the given window/frame full-screen. Pass nil to return all windows
to normal size."
  ([^java.awt.GraphicsDevice device window]
    (if window
      (when (not= (.getFullScreenWindow device) window)
        (.dispose window)
        (.setUndecorated window true)
        (.setFullScreenWindow device window)
        (.show window))
      (when-let [window (.getFullScreenWindow device)]
        (.dispose window)
        (.setFullScreenWindow device nil)
        (.setUndecorated window false)
        (.show window)))
    window)
  ([window]
    (full-screen! (default-screen-device) window)))

(defn setup-fullscreen [window]
  (bind-window-keys window ["F"] #(full-screen! window))
  (bind-window-keys window ["ESCAPE"] #(full-screen! nil)))

;; positional controls

(defn pan! [position-atom axis distance]
  (let [zoom (@position-atom :zoom)]
    (swap! position-atom update-in [axis]
           - (/ distance zoom))))

(defn handle-drags [component position-atom]
  (let [drag-origin (atom nil)
        mouse-adapter
        (proxy [MouseAdapter] []
          (mousePressed [e]
                        (reset! drag-origin {:x (.getX e) :y (.getY e)}))
          (mouseReleased [e]
                         (reset! drag-origin nil))
          (mouseDragged [e]
                        (let [x (.getX e) y (.getY e)]
                          (pan! position-atom :x (- x (:x @drag-origin)))
                          (pan! position-atom :y (- y (:y @drag-origin)))
                          (reset! drag-origin {:x x :y y}))))]
    (doto component
      (.addMouseListener mouse-adapter)
      (.addMouseMotionListener mouse-adapter))
    position-atom))

(defn handle-arrow-pan [component position-atom]
  (let [binder (fn [key axis step]
                 (bind-key component key
                           #(pan! position-atom axis step) true))]
    (binder "UP" :y 50)
    (binder "DOWN" :y -50)
    (binder "RIGHT" :x -50)
    (binder "LEFT" :x 50)))

(defn handle-wheel [component z-atom]
  (.addMouseWheelListener component
    (proxy [MouseAdapter] []
      (mouseWheelMoved [e]
                       (swap! z-atom update-in [:z]
                              + (.getWheelRotation e)))))
  z-atom)

(defn handle-resize [component size-atom]
  (let [update-size #(let [bounds (.getBounds component)]
                       (swap! size-atom merge
                              {:width (.getWidth bounds)
                               :height (.getHeight bounds)}))]
    (update-size)
    (.addComponentListener component
      (proxy [ComponentAdapter] []
        (componentResized [e]
                          (update-size)))))
  size-atom)

(defn handle-dive [window dive-atom]
  (bind-window-keys window ["COMMA"] #(swap! dive-atom update-in [:z] dec))
  (bind-window-keys window ["PERIOD"] #(swap! dive-atom update-in [:z] inc)))

(defn handle-zoom [window zoom-atom]
  (bind-window-keys window ["ADD" "CLOSE_BRACKET"]
                   (fn [] (swap! zoom-atom update-in [:zoom]
                                 #(min (* % 2) MAX-ZOOM))))
  (bind-window-keys window ["SUBTRACT" "OPEN_BRACKET"]
                   (fn [] (swap! zoom-atom update-in [:zoom]
                                 #(max (/ % 2) MIN-ZOOM)))))

(defn watch-keys [window key-atom]
  (let [key-adapter (proxy [KeyAdapter] []
                      (keyPressed [e]
                                  (swap! key-atom update-in [:keys] conj
                                         (KeyEvent/getKeyText (.getKeyCode e))))
                      (keyReleased [e]
                                   (swap! key-atom update-in [:keys] disj
                                          (KeyEvent/getKeyText (.getKeyCode e)))))]
    (doseq [component (window-descendants window)]
      (.addKeyListener component key-adapter))))

(defn handle-pointing [component pointing-atom]
  (.addMouseMotionListener component
                     (proxy [MouseAdapter] []
                       (mouseMoved [e]
                                   (swap! pointing-atom merge {:x (.getX e)
                                                               :y (.getY e)})))))

(defn add-channel [screen-state-atom name color min max gamma]
  (swap! update-in [:channels name] (lut-object color min max gamma)))

;; MAIN WINDOW AND PANEL

(defn main-panel [screen-state available-tiles]
  (doto
    (proxy [JPanel] []
      (paintComponent [^Graphics graphics]
        (proxy-super paintComponent graphics)
        (paint-screen graphics @screen-state @available-tiles)))
    (.setBackground Color/BLACK)))

(defn main-frame []
  (doto (JFrame. "Slide Explorer II")
    .show
    (.setBounds 10 10 500 500)))

(defn show [available-tiles]
  (let [screen-state (atom (sorted-map :x 0 :y 0 :z 0 :zoom 1
                                       :keys (sorted-set)
                                       :channels (sorted-map)))
        panel (main-panel screen-state available-tiles)
        frame (main-frame)
        mouse-position (atom nil)]
    (def at available-tiles)
    (def ss screen-state)
    (def mp mouse-position)
    (def f frame)
    (def pnl panel)
    (.add (.getContentPane frame) panel)
    (setup-fullscreen frame)
    (handle-drags panel screen-state)
    (handle-arrow-pan panel screen-state)
    (handle-wheel panel screen-state)
    (handle-resize panel screen-state)
    (handle-zoom frame screen-state)
    (handle-dive frame screen-state)
    (watch-keys frame screen-state)
    (display-follow panel screen-state)
    (display-follow panel available-tiles)
    (handle-pointing panel mouse-position)
    screen-state))

remove typo

remove typo

git-svn-id: 03a8048b5ee8463be5048a3801110fb50f378627@9421 d0ab736e-dc22-4aeb-8dc9-08def0aa14fd


(ns braid.core.server.sync-helpers
  (:require
   [braid.core.hooks :as hooks]
   [braid.core.server.db.group :as group]
   [braid.core.server.db.tag :as tag]
   [braid.core.server.db.thread :as thread]
   [braid.core.server.db.user :as user]
   [braid.core.server.email-digest :as email]
   [braid.core.server.message-format :as message-format]
   [braid.core.server.notify-rules :as notify-rules]
   [braid.core.server.socket :refer [chsk-send! connected-uids]]
   [clojure.set :refer [difference intersection]]
   [taoensso.timbre :as timbre]))

(def anonymous-group-readers (atom {}))

(defn add-anonymous-reader
  [group-id client-id]
  (swap! anonymous-group-readers update group-id (fnil conj #{}) client-id))

(defn remove-anonymous-reader
  [client-id]
  (let [group (some (fn [[g ids]]
                      (and (contains? ids client-id)
                           g))
                    @anonymous-group-readers)]
    (swap! anonymous-group-readers update group disj client-id)))

(defn broadcast-thread
  "broadcasts thread to all users with the thread open, except those in ids-to-skip"
  [thread-id ids-to-skip]
  (let [user-ids (-> (difference
                       (intersection
                         (set (thread/users-with-thread-open thread-id))
                         (set (:any @connected-uids)))
                       (set ids-to-skip)))
        thread (thread/thread-by-id thread-id)]
    (doseq [uid user-ids]
      (let [user-tags (tag/tag-ids-for-user uid)
            filtered-thread (update-in thread [:tag-ids]
                                       (partial into #{} (filter user-tags)))
            thread-with-last-opens (thread/thread-add-last-open-at
                                     filtered-thread uid)]
        (chsk-send! uid [:braid.client/thread thread-with-last-opens])))
    (doseq [anon-id (@anonymous-group-readers (thread :group-id))]
      (chsk-send! anon-id [:braid.client/thread thread]))))

(defonce group-change-broadcast-hooks
  (hooks/register! (atom []) [fn?]))

(defn broadcast-group-change
  "Broadcast group change to clients that are in the group"
  [group-id info]
  (let [ids-to-send-to (intersection
                         (set (:any @connected-uids))
                         (into #{} (map :id)
                               (group/group-users group-id)))]
    (doseq [uid ids-to-send-to]
      (chsk-send! uid info)))
  (doseq [anon-id (@anonymous-group-readers group-id)]
    (chsk-send! anon-id info))
  (doseq [hook @group-change-broadcast-hooks]
    (hook group-id info)))

; TODO: when using clojure.spec, use spec to validate this
(defn user-can-message? [user-id ?data]
  ; TODO: also check that thread in group
  (every?
      true?
      (concat
        [(or (boolean (thread/user-can-see-thread? user-id (?data :thread-id)))
             (do (timbre/warnf
                   "User %s attempted to add message to disallowed thread %s"
                   user-id (?data :thread-id))
                 false))
         (or (boolean (if-let [cur-group (thread/thread-group-id (?data :thread-id))]
                        (= (?data :group-id) cur-group)
                        true)))]
        (map
          (fn [tag-id]
            (and
              (or (boolean (= (?data :group-id) (tag/tag-group-id tag-id)))
                  (do
                    (timbre/warnf
                      "User %s attempted to add a tag %s from a different group"
                      user-id tag-id)
                    false))
              (or (boolean (tag/user-in-tag-group? user-id tag-id))
                  (do
                    (timbre/warnf "User %s attempted to add a disallowed tag %s"
                                  user-id tag-id)
                    false))))
          (?data :mentioned-tag-ids))
        (map
          (fn [mentioned-id]
            (and
              (or (boolean (group/user-in-group? user-id (?data :group-id)))
                  (do (timbre/warnf
                        "User %s attempted to mention disallowed user %s"
                        user-id mentioned-id)
                      false))
              (or (boolean (user/user-visible-to-user? user-id mentioned-id))
                  (do (timbre/warnf
                        "User %s attempted to mention disallowed user %s"
                        user-id mentioned-id)
                    false))))
          (?data :mentioned-user-ids)))))

(defn notify-users [new-message]
  (let [thread-id (new-message :thread-id)
        subscribed-user-ids (->>
                              (thread/users-subscribed-to-thread thread-id)
                              (remove (partial = (:user-id new-message))))
        online? (intersection
                  (set subscribed-user-ids)
                  (set (:any @connected-uids)))
        parse-tags-and-mentions (message-format/make-tags-and-mentions-parser (new-message :group-id))]
    (doseq [uid subscribed-user-ids]
      (when-let [rules (user/user-get-preference uid :notification-rules)]
        (when (notify-rules/notify? uid rules new-message)
          (if (online? uid)
            (let [msg (update new-message :content
                              parse-tags-and-mentions)]
              (chsk-send! uid [:braid.client/notify-message msg]))
            (future
              (let [update-msgs
                    (partial
                      map
                      (fn [m] (update m :content
                                      parse-tags-and-mentions)))]
                (-> (email/create-message
                      [(-> (thread/thread-by-id thread-id)
                           (update :messages update-msgs))])
                    (assoc :subject "Notification from Braid")
                    (->> (email/send-message (user/user-email uid))))))))))))

(ns braid.core.server.sync-helpers
  (:require
   [braid.core.hooks :as hooks]
   [braid.core.server.db.group :as group]
   [braid.core.server.db.tag :as tag]
   [braid.core.server.db.thread :as thread]
   [braid.core.server.db.user :as user]
   [braid.core.server.email-digest :as email]
   [braid.core.server.message-format :as message-format]
   [braid.core.server.notify-rules :as notify-rules]
   [braid.core.server.socket :refer [chsk-send! connected-uids]]
   [clojure.set :refer [difference intersection]]
   [taoensso.timbre :as timbre]))

(def anonymous-group-readers (atom {}))

(defn add-anonymous-reader
  [group-id client-id]
  (swap! anonymous-group-readers update group-id (fnil conj #{}) client-id))

(defn remove-anonymous-reader
  [client-id]
  (let [group (some (fn [[g ids]]
                      (and (contains? ids client-id)
                           g))
                    @anonymous-group-readers)]
    (swap! anonymous-group-readers update group disj client-id)))

(defn broadcast-thread
  "broadcasts thread to all users with the thread open, except those in ids-to-skip"
  [thread-id ids-to-skip]
  (let [user-ids (-> (difference
                       (intersection
                         (set (thread/users-with-thread-open thread-id))
                         (set (:any @connected-uids)))
                       (set ids-to-skip)))
        thread (thread/thread-by-id thread-id)]
    (doseq [uid user-ids]
      (let [user-tags (tag/tag-ids-for-user uid)
            filtered-thread (update-in thread [:tag-ids]
                                       (partial into #{} (filter user-tags)))
            thread-with-last-opens (thread/thread-add-last-open-at
                                     filtered-thread uid)]
        (chsk-send! uid [:braid.client/thread thread-with-last-opens])))
    (doseq [anon-id (@anonymous-group-readers (thread :group-id))]
      (chsk-send! anon-id [:braid.client/thread thread]))))

(defonce group-change-broadcast-hooks
  (hooks/register! (atom []) [fn?]))

(defn broadcast-group-change
  "Broadcast group change to clients that are in the group"
  [group-id info]
  (let [ids-to-send-to (intersection
                         (set (:any @connected-uids))
                         (into #{} (map :id)
                               (group/group-users group-id)))]
    (doseq [uid ids-to-send-to]
      (chsk-send! uid info)))
  (doseq [anon-id (@anonymous-group-readers group-id)]
    (chsk-send! anon-id info))
  (doseq [hook @group-change-broadcast-hooks]
    (hook group-id info)))

; TODO: when using clojure.spec, use spec to validate this
(defn user-can-message? [user-id ?data]
  ; TODO: also check that thread in group
  (every?
      true?
      (concat
        [(or (boolean (thread/user-can-see-thread? user-id (?data :thread-id)))
             (do (timbre/warnf
                   "User %s attempted to add message to disallowed thread %s"
                   user-id (?data :thread-id))
                 false))
         (or (boolean (if-let [cur-group (thread/thread-group-id (?data :thread-id))]
                        (= (?data :group-id) cur-group)
                        true)))
         (group/user-in-group? user-id (?data :group-id))]
        (map
          (fn [tag-id]
            (and
              (or (boolean (= (?data :group-id) (tag/tag-group-id tag-id)))
                  (do
                    (timbre/warnf
                      "User %s attempted to add a tag %s from a different group"
                      user-id tag-id)
                    false))
              (or (boolean (tag/user-in-tag-group? user-id tag-id))
                  (do
                    (timbre/warnf "User %s attempted to add a disallowed tag %s"
                                  user-id tag-id)
                    false))))
          (?data :mentioned-tag-ids))
        (map
          (fn [mentioned-id]
            (and
              (or (boolean (group/user-in-group? user-id (?data :group-id)))
                  (do (timbre/warnf
                        "User %s attempted to mention disallowed user %s"
                        user-id mentioned-id)
                      false))
              (or (boolean (user/user-visible-to-user? user-id mentioned-id))
                  (do (timbre/warnf
                        "User %s attempted to mention disallowed user %s"
                        user-id mentioned-id)
                    false))))
          (?data :mentioned-user-ids)))))

(defn notify-users [new-message]
  (let [thread-id (new-message :thread-id)
        subscribed-user-ids (->>
                              (thread/users-subscribed-to-thread thread-id)
                              (remove (partial = (:user-id new-message))))
        online? (intersection
                  (set subscribed-user-ids)
                  (set (:any @connected-uids)))
        parse-tags-and-mentions (message-format/make-tags-and-mentions-parser (new-message :group-id))]
    (doseq [uid subscribed-user-ids]
      (when-let [rules (user/user-get-preference uid :notification-rules)]
        (when (notify-rules/notify? uid rules new-message)
          (if (online? uid)
            (let [msg (update new-message :content
                              parse-tags-and-mentions)]
              (chsk-send! uid [:braid.client/notify-message msg]))
            (future
              (let [update-msgs
                    (partial
                      map
                      (fn [m] (update m :content
                                      parse-tags-and-mentions)))]
                (-> (email/create-message
                      [(-> (thread/thread-by-id thread-id)
                           (update :messages update-msgs))])
                    (assoc :subject "Notification from Braid")
                    (->> (email/send-message (user/user-email uid))))))))))))

Fix checking permissions for starting a new thread in other group

Previously, a user could send a message to a group they aren't in.
That message couldn't tag or mention anyone, so it would always be
invisible, but anyway


(ns chat.client.views.new-message
  (:require [om.core :as om]
            [om.dom :as dom]
            [clojure.string :as string]
            [chat.client.views.helpers :as helpers]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.store :as store]
            [chat.client.emoji :as emoji])
  (:import [goog.events KeyCodes]))

(defn tee [x]
  (println x) x)

(defn fuzzy-matches?
  [s m]
  (letfn [(normalize [s]
            (-> (.toLowerCase s) (string/replace #"\s" "")))]
    (not= -1 (.indexOf (normalize s) (normalize m)))))

(defn simple-matches?
  [s m]
  (re-find (re-pattern m) s))

; fn that returns results that will be shown if pattern matches
;    inputs:
;       text - current text of user's message
;       thread-id - id of the thread
;    output:
;       if no pattern matched, return nil
;       if a trigger pattern was matched, an array of maps, each containing:
;         :html - fn that returns html to be displayed for the result
;             inputs:
;                 none
;             output:
;                 html (as returned by (dom/*) functions)
;         :action - fn to be triggered when result picked
;             inputs:
;                 thread-id
;             output:
;                 none expected
;         :message-transform - fn to apply to text of message
;             inputs:
;                text
;             output:
;                text to replace message with

(def engines
  [
   ; ... :emoji  -> autocomplete emoji
   (fn [text thread-id]
     (let [pattern #"\B:(\S{3,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> emoji/unicode
              (filter (fn [[k v]]
                        (simple-matches? k query)))
              (map (fn [[k v]]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str k " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "emoji-match"}
                          (emoji/shortcode->html k)
                          (dom/div #js {:className "name"}
                            k)
                          (dom/div #js {:className "extra"}
                            "...")))}))))))

   ; ... @<user>  -> autocompletes user name
   (fn [text thread-id]
     (let [pattern #"\B@(\S{1,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> (store/all-users)
              (filter (fn [u]
                        (fuzzy-matches? (u :nickname) query)))
              (map (fn [user]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str "@" (user :nickname) " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "user-match"}
                          (dom/img #js {:className "avatar"
                                        :src (user :avatar)})
                          (dom/div #js {:className "name"}
                            (user :nickname))
                          (dom/div #js {:className "extra"}
                            "...")))}))))))

   ; ... #<tag>   -> autocompletes tag
   (fn [text thread-id]
     (let [pattern #"\B#(\S{1,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> (store/all-tags)
              (filter (fn [t]
                        (fuzzy-matches? (t :name) query)))
              (map (fn [tag]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str "#" (tag :name) " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "tag-match"}
                          (dom/div #js {:className "color-block"
                                        :style #js {:backgroundColor (helpers/tag->color tag)}})
                          (dom/div #js {:className "name"}
                            (tag :name))
                          (dom/div #js {:className "extra"}
                            (:name (store/id->group (tag :group-id))))))}))))))
   ])

; TODO: autocomplete mentions
(defn new-message-view [config owner]
  (reify
    om/IInitState
    (init-state [_]
      {:text ""
       :force-close? false
       :highlighted-result-index -1})
    om/IRenderState
    (render-state [_ {:keys [text force-close? highlighted-result-index] :as state}]
      (let [constrain (fn [x a z]
                        (cond
                          (> x z) z
                          (< x a) a
                          :else x))
            results (let [engine-results (map (fn [e] (e text (config :thread-id))) engines)]
                      (if (every? nil? engine-results)
                         nil
                        (apply concat engine-results)))
            highlight-next!
            (fn []
              (om/update-state! owner :highlighted-result-index
                                #(constrain (inc %) 0 (dec (count results)))))
            highlight-prev!
            (fn []
              (om/update-state! owner :highlighted-result-index
                                #(constrain (dec %) 0 (dec (count results)))))
            highlight-clear!
            (fn []
              (om/set-state! owner :highlighted-result-index -1))
            close-autocomplete!
            (fn []
              (highlight-clear!))
            reset-state!
            (fn []
              (om/set-state! owner
                             {:text ""
                              :force-close? false
                              :highlighted-result-index -1}))
            send-message!
            (fn []
              (dispatch! :new-message {:thread-id (config :thread-id)
                                       :content text})
              (reset-state!))
            choose-result!
            (fn [result]
              ((result :action) (config :thread-id))
              (om/set-state! owner :text ((result :message-transform) text))
              (close-autocomplete!))
            autocomplete-open? (and (not force-close?) (not (nil? results)))]
          (dom/div #js {:className "message new"}
            (dom/textarea #js {:placeholder (config :placeholder)
                               :value (state :text)
                               :onChange (fn [e]
                                           (om/update-state! owner
                                                             (fn [s]
                                                               (assoc s
                                                                 :text (.. e -target -value)
                                                                 :force-close? false))))
                               :onKeyDown
                               (fn [e]
                                 (condp = e.keyCode
                                   KeyCodes.ENTER
                                   (cond
                                     ; ENTER when autocomplete -> trigger chosen result's action (or exit autocomplete if no result chosen)
                                     autocomplete-open?
                                     (do
                                       (.preventDefault e)
                                       (if-let [result (nth results highlighted-result-index nil)]
                                         (choose-result! result)
                                         (do
                                           (close-autocomplete!)
                                           (om/set-state! owner :force-close? true))))
                                     ; ENTER otherwise -> send message
                                     (not e.shiftKey)
                                     (do
                                       (.preventDefault e)
                                       (send-message!)))

                                   KeyCodes.ESC (do
                                                  (om/set-state! owner :force-close? true)
                                                  (close-autocomplete!))

                                   KeyCodes.UP (when autocomplete-open?
                                                 (.preventDefault e)
                                                 (highlight-prev!))

                                   KeyCodes.DOWN (when autocomplete-open?
                                                   (.preventDefault e)
                                                   (highlight-next!))
                                   (when (KeyCodes.isTextModifyingKeyEvent e)
                                     ; don't clear if a modifier key alone was pressed
                                     (highlight-clear!))))})

            (when autocomplete-open?
              (dom/div #js {:className "autocomplete"}
                (if (seq results)
                  (apply dom/div nil
                    (map-indexed
                      (fn [i result]
                        (dom/div #js {:className (str "result" " "
                                                      (when (= i highlighted-result-index) "highlight"))
                                      :style #js {:cursor "pointer"}
                                      :onClick (fn []
                                                 (choose-result! result))}
                          ((result :html))))
                      results))
                  (dom/div #js {:className "result"}
                    "No Results")))))))))

(ns chat.client.views.new-message
  (:require [om.core :as om]
            [om.dom :as dom]
            [clojure.string :as string]
            [chat.client.views.helpers :as helpers]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.store :as store]
            [chat.client.emoji :as emoji])
  (:import [goog.events KeyCodes]))

(defn tee [x]
  (println x) x)

(defn fuzzy-matches?
  [s m]
  (letfn [(normalize [s]
            (-> (.toLowerCase s) (string/replace #"\s" "")))]
    (not= -1 (.indexOf (normalize s) (normalize m)))))

(defn simple-matches?
  [m s]
  (re-find (re-pattern m) s))

; fn that returns results that will be shown if pattern matches
;    inputs:
;       text - current text of user's message
;       thread-id - id of the thread
;    output:
;       if no pattern matched, return nil
;       if a trigger pattern was matched, an array of maps, each containing:
;         :html - fn that returns html to be displayed for the result
;             inputs:
;                 none
;             output:
;                 html (as returned by (dom/*) functions)
;         :action - fn to be triggered when result picked
;             inputs:
;                 thread-id
;             output:
;                 none expected
;         :message-transform - fn to apply to text of message
;             inputs:
;                text
;             output:
;                text to replace message with

(def engines
  [
   ; ... :emoji  -> autocomplete emoji
   (fn [text thread-id]
     (let [pattern #"\B:(\S{3,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> emoji/unicode
              (filter (fn [[k v]]
                        (simple-matches? k query)))
              (map (fn [[k v]]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str k " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "emoji-match"}
                          (emoji/shortcode->html k)
                          (dom/div #js {:className "name"}
                            k)
                          (dom/div #js {:className "extra"}
                            "...")))}))))))

   ; ... @<user>  -> autocompletes user name
   (fn [text thread-id]
     (let [pattern #"\B@(\S{1,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> (store/all-users)
              (filter (fn [u]
                        (fuzzy-matches? (u :nickname) query)))
              (map (fn [user]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str "@" (user :nickname) " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "user-match"}
                          (dom/img #js {:className "avatar"
                                        :src (user :avatar)})
                          (dom/div #js {:className "name"}
                            (user :nickname))
                          (dom/div #js {:className "extra"}
                            "...")))}))))))

   ; ... #<tag>   -> autocompletes tag
   (fn [text thread-id]
     (let [pattern #"\B#(\S{1,})$"]
       (when-let [query (second (re-find pattern text))]
         (->> (store/all-tags)
              (filter (fn [t]
                        (fuzzy-matches? (t :name) query)))
              (map (fn [tag]
                     {:action
                      (fn [thread-id])
                      :message-transform
                      (fn [text]
                        (string/replace text pattern (str "#" (tag :name) " ")))
                      :html
                      (fn []
                        (dom/div #js {:className "tag-match"}
                          (dom/div #js {:className "color-block"
                                        :style #js {:backgroundColor (helpers/tag->color tag)}})
                          (dom/div #js {:className "name"}
                            (tag :name))
                          (dom/div #js {:className "extra"}
                            (:name (store/id->group (tag :group-id))))))}))))))
   ])

; TODO: autocomplete mentions
(defn new-message-view [config owner]
  (reify
    om/IInitState
    (init-state [_]
      {:text ""
       :force-close? false
       :highlighted-result-index -1})
    om/IRenderState
    (render-state [_ {:keys [text force-close? highlighted-result-index] :as state}]
      (let [constrain (fn [x a z]
                        (cond
                          (> x z) z
                          (< x a) a
                          :else x))
            results (let [engine-results (map (fn [e] (e text (config :thread-id))) engines)]
                      (if (every? nil? engine-results)
                         nil
                        (apply concat engine-results)))
            highlight-next!
            (fn []
              (om/update-state! owner :highlighted-result-index
                                #(constrain (inc %) 0 (dec (count results)))))
            highlight-prev!
            (fn []
              (om/update-state! owner :highlighted-result-index
                                #(constrain (dec %) 0 (dec (count results)))))
            highlight-clear!
            (fn []
              (om/set-state! owner :highlighted-result-index -1))
            close-autocomplete!
            (fn []
              (highlight-clear!))
            reset-state!
            (fn []
              (om/set-state! owner
                             {:text ""
                              :force-close? false
                              :highlighted-result-index -1}))
            send-message!
            (fn []
              (dispatch! :new-message {:thread-id (config :thread-id)
                                       :content text})
              (reset-state!))
            choose-result!
            (fn [result]
              ((result :action) (config :thread-id))
              (om/set-state! owner :text ((result :message-transform) text))
              (close-autocomplete!))
            autocomplete-open? (and (not force-close?) (not (nil? results)))]
          (dom/div #js {:className "message new"}
            (dom/textarea #js {:placeholder (config :placeholder)
                               :value (state :text)
                               :onChange (fn [e]
                                           (om/update-state! owner
                                                             (fn [s]
                                                               (assoc s
                                                                 :text (.. e -target -value)
                                                                 :force-close? false))))
                               :onKeyDown
                               (fn [e]
                                 (condp = e.keyCode
                                   KeyCodes.ENTER
                                   (cond
                                     ; ENTER when autocomplete -> trigger chosen result's action (or exit autocomplete if no result chosen)
                                     autocomplete-open?
                                     (do
                                       (.preventDefault e)
                                       (if-let [result (nth results highlighted-result-index nil)]
                                         (choose-result! result)
                                         (do
                                           (close-autocomplete!)
                                           (om/set-state! owner :force-close? true))))
                                     ; ENTER otherwise -> send message
                                     (not e.shiftKey)
                                     (do
                                       (.preventDefault e)
                                       (send-message!)))

                                   KeyCodes.ESC (do
                                                  (om/set-state! owner :force-close? true)
                                                  (close-autocomplete!))

                                   KeyCodes.UP (when autocomplete-open?
                                                 (.preventDefault e)
                                                 (highlight-prev!))

                                   KeyCodes.DOWN (when autocomplete-open?
                                                   (.preventDefault e)
                                                   (highlight-next!))
                                   (when (KeyCodes.isTextModifyingKeyEvent e)
                                     ; don't clear if a modifier key alone was pressed
                                     (highlight-clear!))))})

            (when autocomplete-open?
              (dom/div #js {:className "autocomplete"}
                (if (seq results)
                  (apply dom/div nil
                    (map-indexed
                      (fn [i result]
                        (dom/div #js {:className (str "result" " "
                                                      (when (= i highlighted-result-index) "highlight"))
                                      :style #js {:cursor "pointer"}
                                      :onClick (fn []
                                                 (choose-result! result))}
                          ((result :html))))
                      results))
                  (dom/div #js {:className "result"}
                    "No Results")))))))))

fix arguments to simple-matches?

fix arguments to simple-matches?


(ns desdemona.launcher.aeron-media-driver
  (:gen-class)
  (:require
   [clojure.core.async :refer [chan <!!]]
   [clojure.tools.cli :refer [parse-opts]])
  (:import
   [uk.co.real_logic.aeron Aeron$Context]
   [uk.co.real_logic.aeron.driver MediaDriver MediaDriver$Context]))

(def cli-options
  [["-d" "--delete-dirs"
    "Delete the media drivers directory on startup"
    :default false]
   ["-h" "--help"
    "Display a help message"]])

(def ^:private aeron-launch-error-message
  (str
   "Error starting media driver. This may be due to a media driver data "
   "incompatibility between versions. Check that no other media driver "
   "has been started and then use -d to delete the directory on startup"))

(defn ^:private run-media-driver!
  [opts]
  (let [ctx (doto (MediaDriver$Context.)
              (.dirsDeleteOnStart (-> opts :options :delete-dirs)))]
    (try (MediaDriver/launch ctx)
         (catch IllegalStateException ise
           (throw (Exception. aeron-launch-error-message ise))))))

(defn -main [& args]
  (let [opts (parse-opts args cli-options)]
    (if (-> opts :options :help)
      (do (run! (fn [opt]
                  (println (clojure.string/join " " (take 3 opt))))
                cli-options))
      (do (run-media-driver!)
          (println "Launched the Media Driver. Blocking forever...")
          (<!! (chan))))))

(ns desdemona.launcher.aeron-media-driver
  (:gen-class)
  (:require
   [clojure.core.async :refer [chan <!!]]
   [clojure.tools.cli :refer [parse-opts]])
  (:import
   [uk.co.real_logic.aeron.driver MediaDriver MediaDriver$Context]))

(def cli-options
  [["-d" "--delete-dirs"
    "Delete the media drivers directory on startup"
    :default false]
   ["-h" "--help"
    "Display a help message"]])

(def ^:private aeron-launch-error-message
  (str
   "Error starting media driver. This may be due to a media driver data "
   "incompatibility between versions. Check that no other media driver "
   "has been started and then use -d to delete the directory on startup"))

(defn ^:private run-media-driver!
  [opts]
  (let [ctx (doto (MediaDriver$Context.)
              (.dirsDeleteOnStart (-> opts :options :delete-dirs)))]
    (try (MediaDriver/launch ctx)
         (catch IllegalStateException ise
           (throw (Exception. aeron-launch-error-message ise))))))

(defn -main [& args]
  (let [opts (parse-opts args cli-options)]
    (if (-> opts :options :help)
      (do (run! (fn [opt]
                  (println (clojure.string/join " " (take 3 opt))))
                cli-options))
      (do (run-media-driver!)
          (println "Launched the Media Driver. Blocking forever...")
          (<!! (chan))))))

Remove unused import

Remove unused import


{:user {:dependencies [[clj-stacktrace "0.2.5"]
                       [spyscope "0.1.0"]
                       [limit-break "0.1.0-SNAPSHOT"]]
        :plugins [[lein-difftest "1.3.7"]
                  [lein-drip "0.1.1-SNAPSHOT"]
                  [lein-clojars "0.9.1"]
                  [lein-pprint "1.1.1"]
                  [lein-ring "0.8.0"]
                  [slamhound "1.3.1"]
                  [lein-cljsbuild "0.1.9"]
                  [lein-deps-tree "0.1.2"]
                  [lein-marginalia "0.7.1"]]
        :repl-options {:timeout 120000}
        :injections [(let [orig (ns-resolve (doto 'clojure.stacktrace require)
                                            'print-cause-trace)
                           new (ns-resolve (doto 'clj-stacktrace.repl require)
                                           'pst)]
                       (alter-var-root orig (constantly @new)))]
        :vimclojure-opts {:repl true}}}

{:user {:dependencies [[clj-stacktrace "0.2.5"]
                       [spyscope "0.1.2"]
                       [limit-break "0.1.0-SNAPSHOT"]]
        :plugins [[lein-difftest "1.3.7"]
                  [lein-drip "0.1.1-SNAPSHOT"]
                  [lein-clojars "0.9.1"]
                  [lein-pprint "1.1.1"]
                  [lein-ring "0.8.0"]
                  [slamhound "1.3.1"]
                  [lein-cljsbuild "0.1.9"]
                  [lein-deps-tree "0.1.2"]
                  [lein-marginalia "0.7.1"]]
        :repl-options {:timeout 120000}
        :injections [(require 'spyscope.core)
                     (let [orig (ns-resolve (doto 'clojure.stacktrace require)
                                            'print-cause-trace)
                           new (ns-resolve (doto 'clj-stacktrace.repl require)
                                           'pst)]
                       (alter-var-root orig (constantly @new)))]
        :vimclojure-opts {:repl true}}}

Fix spyscope dependency. Add its injection.


(ns matchmaker-sparql.evaluation.setup
  "Setup a whole evaluation run."
  (:require [matchmaker-sparql.config :refer [config]]
            [matchmaker-sparql.endpoint :refer [endpoint]]
            [matchmaker-sparql.util :as util :refer [setup-template]]
            [sparclj.core :as sparql]
            [taoensso.timbre :as timbre]
            [slingshot.slingshot :refer [throw+]]))

(defn- has-contracts-with-multiple-winners?
  "Test if there are contracts awarded to multiple bidders."
  []
  (let [{{:keys [graph]} :data} config
        query (setup-template "has_contracts_with_multiple_winners" {:graph graph})]
    (sparql/ask-query endpoint query)))

(defn- clear-evaluation-graph
  "CLEAR GRAPH `evaluation-graph`."
  [{:keys [evaluation-graph]}]
  (let [update-operation (setup-template "clear_evaluation_graph" {:evaluation-graph evaluation-graph})]
    (sparql/update-operation endpoint update-operation)))

(defn- delete-multiple-awards
  "Delete contracts awarded to multiple bidders."
  []
  (let [{{:keys [graph]} :data} config
        update-operation (setup-template "delete_multiple_awards" {:graph graph})]
    (sparql/update-operation endpoint update-operation)))

(defn split-to-ints
  "Split `sample-size` into `split-count` of integer-sized splits."
  [sample-size split-count]
  (let [to-increment (mod sample-size split-count)]
    (map-indexed (fn [index size] (if (< index to-increment) (inc size) size))
                 (repeat split-count (int (/ sample-size split-count))))))

(defn get-splits
  "Split `contract-count` into `split-count` splits, without which
  the `contract-count` = (* `contract-count` `data-reduction`)"
  [contract-count split-count data-reduction]
  (let [window-sizes (split-to-ints contract-count split-count)
        windows (map (fn [offset limit]
                       {:limit limit
                        :offset offset})
                     (reductions + 0 window-sizes)
                     window-sizes)
        reduction-size (->> contract-count
                            (* (- 1 data-reduction))
                            Math/ceil
                            int)
        split-sizes (split-to-ints reduction-size split-count)]
    (map (fn [{:keys [limit offset]} split-limit decrease]
           {:limit split-limit
            :offset (-> limit
                        (- split-limit)
                        rand-int
                        (+ offset)
                        (- decrease))})
         windows
         split-sizes
         (reductions + 0 split-sizes))))

(defn- reduce-data
  "Reduce the available contract awards (`contract-count`)
  by `data-reduction` ratio from (0, 1].
  Contract awards are moved temporarily from `graph` into the `withheld-graph`.
  Withheld contract awards are randomized by splitting their count
  into number of `windows`."
  [{:keys [contract-count data-reduction graph windows withheld-graph]
    :or {windows 25}}]
  (let [splits (get-splits contract-count windows data-reduction)]
    (doseq [{:keys [limit offset]} splits
            :let [update-operation (setup-template "reduce_data"
                                                   {:limit limit
                                                    :offset offset
                                                    :graph graph
                                                    :withheld-graph withheld-graph})]]
      (sparql/update-operation endpoint update-operation))))

(defn- count-query
  "Run a SPARQL query that produces a single ?count."
  [template]
  (let [{{:keys [graph]} :data} config]
    (-> endpoint
        (sparql/select-template template {:graph graph})
        first
        :count)))

(defn count-awarded-contracts
  []
  (count-query "templates/evaluation/setup/count_contracts"))

(defn count-bidders
  []
  (count-query "templates/evaluation/setup/count_bidders"))

(defn- fold-limits-and-offsets
  "Returns a sequence of limits and offsets delimiting the evaluation folds.
  Takes number of `folds` and `contract-count`."
  [folds contract-count]
  (let [; int rounds down sample sizes (limits)
        basic-limits (repeat folds (int (/ contract-count folds)))
        ; First samples will be incremented by 1 to cover the complete dataset.
        incremented-samples (mod contract-count folds)
        sample-limits (concat (map inc (take incremented-samples basic-limits))
                              (take-last (- folds incremented-samples) basic-limits))]
    (map (fn [limit offset] {:limit limit :offset offset})
         sample-limits
         (conj (butlast (reductions + sample-limits)) 0))))

(defn assert-query
  "Assert that the result of the SPARQL ASK query rendered from `template`
  must satisfy the `assertion` (false? by default)."
  [template
   exception
   & {:keys [assertion data] :or {assertion false?}}]
  (let [{{:keys [graph]} :data} config
        query (setup-template template (merge {:graph graph} data))]
    (when-not (assertion (sparql/ask-query endpoint query))
      (throw+ exception))))

(defn- are-blank-nodes-present?
  "Test if there are no blank nodes in the evaluated data."
  []
  (assert-query "are_blank_nodes_present" {:type ::util/blank-nodes-present}))

(defn- data-empty?
  "Test if the data is not empty."
  []
  (assert-query "data_empty" {:type ::util/data-empty} :assertion true?))

(defn- evaluation-data-empty?
  "Test if the evaluation graph is empty before loading it."
  [{:keys [evaluation-graph]}]
  (let [query (setup-template "evaluation_data_empty" {:evaluation-graph evaluation-graph})]
    (not (sparql/ask-query endpoint query))))

(defn- has-duplicate-tenders?
  "Test if there are duplicate tenders in the evaluated data."
  []
  (assert-query "has_duplicate_tenders" {:type ::util/duplicate-tenders}))

(defn- test-data-assumptions
  "Test assumptions about the evaluated data."
  []
  (data-empty?)
  (are-blank-nodes-present?)
  (has-duplicate-tenders?))

(defn bidders-short-head
  "Get a set of the most popular bidders accountable for 1/5 of `contract-count`."
  [contract-count]
  (let [short-head-count (/ contract-count 5)
        query-fn (fn [[limit offset]]
                   (setup-template "templates/evaluation/setup/bidders_short_head"
                                   {:limit limit :offset offset}))
        reduce-fn (fn [{a :count} {bidder :bidder b :count}]
                    {:bidder bidder :count (+ a b)})
        in-head? (comp (partial >= short-head-count) :count)]
    (->> (sparql/select-paged endpoint query-fn)
         (reductions reduce-fn)
         (take-while in-head?)
         (map :bidder)
         (into #{}))))

(defn setup-evaluation
  "Setup data for evaluation."
  [{:keys [data-reduction folds]
    :as args}]
  (let [{{:keys [graph]} :data} config
        withheld-graph (str graph "/withheld")
        evaluation-graph (str graph "/evaluation")
        contract-count (count-awarded-contracts)
        data-reduced? (and data-reduction (< data-reduction 1))
        evaluation (assoc args
                          :contract-count contract-count
                          :data-reduced? data-reduced?
                          :evaluation-graph evaluation-graph
                          :graph graph
                          :withheld-graph withheld-graph)]
    (test-data-assumptions)
    (when-not (evaluation-data-empty? evaluation)
      (timbre/info "Cleaning non-empty evaluation graph...")
      (clear-evaluation-graph evaluation))
    (when (has-contracts-with-multiple-winners?)
      (timbre/info "Deleting contracts with multiple awards...")
      (delete-multiple-awards))
    ; Reduce data when required.
    (when data-reduced?
      (timbre/info "Reducing data...")
      (reduce-data evaluation))
    ; Re-COUNT contracts if data was reduced.
    (let [contract-count' (if data-reduced? (count-awarded-contracts) contract-count)
          bidder-count (count-bidders)
          limits-and-offsets (fold-limits-and-offsets folds contract-count')
          short-head (bidders-short-head contract-count')]
      (assoc evaluation
             :bidder-count bidder-count
             :contract-count contract-count'
             :limits-and-offsets limits-and-offsets
             :long-tail? (complement short-head)))))

(ns matchmaker-sparql.evaluation.setup
  "Setup a whole evaluation run."
  (:require [matchmaker-sparql.config :refer [config]]
            [matchmaker-sparql.endpoint :refer [endpoint]]
            [matchmaker-sparql.util :as util :refer [setup-template]]
            [sparclj.core :as sparql]
            [taoensso.timbre :as timbre]
            [slingshot.slingshot :refer [throw+]]))

(defn- has-contracts-with-multiple-winners?
  "Test if there are contracts awarded to multiple bidders."
  []
  (let [{{:keys [graph]} :data} config
        query (setup-template "has_contracts_with_multiple_winners" {:graph graph})]
    (sparql/ask-query endpoint query)))

(defn- clear-evaluation-graph
  "CLEAR GRAPH `evaluation-graph`."
  [{:keys [evaluation-graph]}]
  (let [update-operation (setup-template "clear_evaluation_graph" {:evaluation-graph evaluation-graph})]
    (sparql/update-operation endpoint update-operation)))

(defn- delete-multiple-awards
  "Delete contracts awarded to multiple bidders."
  []
  (let [{{:keys [graph]} :data} config
        update-operation (setup-template "delete_multiple_awards" {:graph graph})]
    (sparql/update-operation endpoint update-operation)))

(defn split-to-ints
  "Split `sample-size` into `split-count` of integer-sized splits."
  [sample-size split-count]
  (let [to-increment (mod sample-size split-count)]
    (map-indexed (fn [index size] (if (< index to-increment) (inc size) size))
                 (repeat split-count (int (/ sample-size split-count))))))

(defn get-splits
  "Split `contract-count` into `split-count` splits, without which
  the `contract-count` = (* `contract-count` `data-reduction`)"
  [contract-count split-count data-reduction]
  (let [window-sizes (split-to-ints contract-count split-count)
        windows (map (fn [offset limit]
                       {:limit limit
                        :offset offset})
                     (reductions + 0 window-sizes)
                     window-sizes)
        reduction-size (->> contract-count
                            (* (- 1 data-reduction))
                            Math/ceil
                            int)
        split-sizes (split-to-ints reduction-size split-count)]
    (map (fn [{:keys [limit offset]} split-limit decrease]
           {:limit split-limit
            :offset (-> limit
                        (- split-limit)
                        rand-int
                        (+ offset)
                        (- decrease))})
         windows
         split-sizes
         (reductions + 0 split-sizes))))

(defn- reduce-data
  "Reduce the available contract awards (`contract-count`)
  by `data-reduction` ratio from (0, 1].
  Contract awards are moved temporarily from `graph` into the `withheld-graph`.
  Withheld contract awards are randomized by splitting their count
  into number of `windows`."
  [{:keys [contract-count data-reduction graph windows withheld-graph]
    :or {windows 25}}]
  (let [splits (get-splits contract-count windows data-reduction)]
    (doseq [{:keys [limit offset]} splits
            :let [update-operation (setup-template "reduce_data"
                                                   {:limit limit
                                                    :offset offset
                                                    :graph graph
                                                    :withheld-graph withheld-graph})]]
      (sparql/update-operation endpoint update-operation))))

(defn- count-query
  "Run a SPARQL query that produces a single ?count."
  [template]
  (let [{{:keys [graph]} :data} config]
    (-> endpoint
        (sparql/select-template template {:graph graph})
        first
        :count)))

(defn count-awarded-contracts
  []
  (count-query "templates/evaluation/setup/count_contracts"))

(defn count-bidders
  []
  (count-query "templates/evaluation/setup/count_bidders"))

(defn- fold-limits-and-offsets
  "Returns a sequence of limits and offsets delimiting the evaluation folds.
  Takes number of `folds` and `contract-count`."
  [folds contract-count]
  (let [; int rounds down sample sizes (limits)
        basic-limits (repeat folds (int (/ contract-count folds)))
        ; First samples will be incremented by 1 to cover the complete dataset.
        incremented-samples (mod contract-count folds)
        sample-limits (concat (map inc (take incremented-samples basic-limits))
                              (take-last (- folds incremented-samples) basic-limits))]
    (map (fn [limit offset] {:limit limit :offset offset})
         sample-limits
         (conj (butlast (reductions + sample-limits)) 0))))

(defn assert-query
  "Assert that the result of the SPARQL ASK query rendered from `template`
  must satisfy the `assertion` (false? by default)."
  [template
   exception
   & {:keys [assertion data] :or {assertion false?}}]
  (let [{{:keys [graph]} :data} config
        query (setup-template template (merge {:graph graph} data))]
    (when-not (assertion (sparql/ask-query endpoint query))
      (throw+ exception))))

(defn- are-blank-nodes-present?
  "Test if there are no blank nodes in the evaluated data."
  []
  (assert-query "are_blank_nodes_present" {:type ::util/blank-nodes-present}))

(defn- data-empty?
  "Test if the data is not empty."
  []
  (assert-query "data_empty" {:type ::util/data-empty} :assertion true?))

(defn- evaluation-data-empty?
  "Test if the evaluation graph is empty before loading it."
  [{:keys [evaluation-graph]}]
  (let [query (setup-template "evaluation_data_empty" {:evaluation-graph evaluation-graph})]
    (not (sparql/ask-query endpoint query))))

(defn- has-duplicate-tenders?
  "Test if there are duplicate tenders in the evaluated data."
  []
  (assert-query "has_duplicate_tenders" {:type ::util/duplicate-tenders}))

(defn- test-data-assumptions
  "Test assumptions about the evaluated data."
  []
  (data-empty?)
  (are-blank-nodes-present?)
  (has-duplicate-tenders?))

(defn bidders-short-head
  "Get a set of the most popular bidders accountable for 1/5 of `contract-count`."
  [contract-count]
  (let [short-head-count (/ contract-count 5)
        query-fn (fn [[limit offset]]
                   (setup-template "bidders_short_head" {:limit limit :offset offset}))
        reduce-fn (fn [{a :count} {bidder :bidder b :count}]
                    {:bidder bidder :count (+ a b)})
        in-head? (comp (partial >= short-head-count) :count)]
    (->> (sparql/select-paged endpoint query-fn)
         (reductions reduce-fn)
         (take-while in-head?)
         (map :bidder)
         (into #{}))))

(defn setup-evaluation
  "Setup data for evaluation."
  [{:keys [data-reduction folds]
    :as args}]
  (let [{{:keys [graph]} :data} config
        withheld-graph (str graph "/withheld")
        evaluation-graph (str graph "/evaluation")
        contract-count (count-awarded-contracts)
        data-reduced? (and data-reduction (< data-reduction 1))
        evaluation (assoc args
                          :contract-count contract-count
                          :data-reduced? data-reduced?
                          :evaluation-graph evaluation-graph
                          :graph graph
                          :withheld-graph withheld-graph)]
    (test-data-assumptions)
    (when-not (evaluation-data-empty? evaluation)
      (timbre/info "Cleaning non-empty evaluation graph...")
      (clear-evaluation-graph evaluation))
    (when (has-contracts-with-multiple-winners?)
      (timbre/info "Deleting contracts with multiple awards...")
      (delete-multiple-awards))
    ; Reduce data when required.
    (when data-reduced?
      (timbre/info "Reducing data...")
      (reduce-data evaluation))
    ; Re-COUNT contracts if data was reduced.
    (let [contract-count' (if data-reduced? (count-awarded-contracts) contract-count)
          bidder-count (count-bidders)
          limits-and-offsets (fold-limits-and-offsets folds contract-count')
          short-head (bidders-short-head contract-count')]
      (assoc evaluation
             :bidder-count bidder-count
             :contract-count contract-count'
             :limits-and-offsets limits-and-offsets
             :long-tail? (complement short-head)))))

Fix typo

Fix typo


; Licensed to the Apache Software Foundation (ASF) under one
; or more contributor license agreements. See the NOTICE file
; distributed with this work for additional information
; regarding copyright ownership. The ASF licenses this file
; to you under the Apache License, Version 2.0 (the
; "License"); you may not use this file except in compliance
; with the License. You may obtain a copy of the License at
;
; http://www.apache.org/licenses/LICENSE-2.0
;
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.

(ns dda.pallet.dda-managed-ide.infra.clojure
  (:require
    [clojure.tools.logging :as logging]
    [schema.core :as s]
    [pallet.actions :as actions]
    [selmer.parser :as selmer]
    [dda.pallet.crate.util :as util]
    [dda.config.commons.user-home :as user-env]))

(def RepoAuth
  {:repo s/Str
   :username s/Str
   :password s/Str})

(def Clojure
  {(s/optional-key :signing-gpg-key) s/Str
   (s/optional-key :lein-auth) [RepoAuth]})

(def Settings
   #{})

(defn install-leiningen
  [facility]
  (actions/as-action
    (logging/info (str facility "-install system: clojure")))
  "get and install lein at /opt/leiningen"
  (actions/directory
    "/opt/leiningen"
    :owner "root"
    :group "users"
    :mode "755")
  (actions/remote-file
    "/opt/leiningen/lein"
    :owner "root"
    :group "users"
    :mode "755"
    :url "https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein")
  (actions/remote-file
    "/etc/profile.d/lein.sh"
    :literal true
    :content
    (util/create-file-content
      ["PATH=$PATH:/opt/leiningen"])))

(defn install-mach
  [facility]
  (actions/as-action
    (logging/info (str facility "install system: install-mach")))
  (actions/packages
    :aptitude ["npm"])
  (actions/exec-checked-script
    "install mach"
    ("npm" "install" "-g" "@juxt/mach")
    ("cd" "/usr/local/bin")
    ("curl" "-fsSLo" "boot"
            "https://github.com/boot-clj/boot-bin/releases/download/latest/boot.sh")
    ("chmod" "755" "boot")))

(s/defn lein-user-profile
  [lein-config :- Clojure]
  (selmer/render-file "lein_profiles.template" lein-config))

(s/defn configure-user-leiningen
  "configure lein settings"
  [facility :- s/Keyword
   os-user-name :- s/Str
   lein-config :- Clojure]
  (let [path (str (user-env/user-home-dir os-user-name) "/.lein/")]
    (actions/as-action
      (logging/info (str facility "-configure user: clojure")))
    (actions/directory
      path
      :owner os-user-name
      :group os-user-name
      :mode "755")
    (actions/remote-file
      (str path "profiles.clj")
      :owner os-user-name
      :group os-user-name
      :literal true
      :content
      (lein-user-profile lein-config))))

(s/defn install-system
  [facility :- s/Keyword
   contains-clojure? :- s/Bool
   clojure :- Clojure]
  (when contains-clojure?
    (install-leiningen facility)))

(s/defn configure-user
  [facility :- s/Keyword
   os-user-name :- s/Str
   contains-clojure? :- s/Bool
   clojure :- Clojure]
  (when contains-clojure?
    (configure-user-leiningen facility os-user-name clojure)))

; Licensed to the Apache Software Foundation (ASF) under one
; or more contributor license agreements. See the NOTICE file
; distributed with this work for additional information
; regarding copyright ownership. The ASF licenses this file
; to you under the Apache License, Version 2.0 (the
; "License"); you may not use this file except in compliance
; with the License. You may obtain a copy of the License at
;
; http://www.apache.org/licenses/LICENSE-2.0
;
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.

(ns dda.pallet.dda-managed-ide.infra.clojure
  (:require
    [clojure.tools.logging :as logging]
    [schema.core :as s]
    [pallet.actions :as actions]
    [selmer.parser :as selmer]
    [dda.pallet.crate.util :as util]
    [dda.config.commons.user-home :as user-env]))

(def RepoAuth
  {:repo s/Str
   :username s/Str
   :password s/Str})

(def Clojure
  {(s/optional-key :signing-gpg-key) s/Str
   (s/optional-key :lein-auth) [RepoAuth]})

(def Settings
   #{})

(defn install-leiningen
  [facility]
  (actions/as-action
    (logging/info (str facility "-install system: clojure")))
  "get and install lein at /opt/leiningen"
  (actions/directory
    "/opt/leiningen"
    :owner "root"
    :group "users"
    :mode "755")
  (actions/remote-file
    "/opt/leiningen/lein"
    :owner "root"
    :group "users"
    :mode "755"
    :url "https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein")
  (actions/remote-file
    "/etc/profile.d/lein.sh"
    :literal true
    :content
    (util/create-file-content
      ["PATH=$PATH:/opt/leiningen"])))

(s/defn lein-user-profile
  [lein-config :- Clojure]
  (selmer/render-file "lein_profiles.template" lein-config))

(s/defn configure-user-leiningen
  "configure lein settings"
  [facility :- s/Keyword
   os-user-name :- s/Str
   lein-config :- Clojure]
  (let [path (str (user-env/user-home-dir os-user-name) "/.lein/")]
    (actions/as-action
      (logging/info (str facility "-configure user: clojure")))
    (actions/directory
      path
      :owner os-user-name
      :group os-user-name
      :mode "755")
    (actions/remote-file
      (str path "profiles.clj")
      :owner os-user-name
      :group os-user-name
      :literal true
      :content
      (lein-user-profile lein-config))))

(s/defn install-system
  [facility :- s/Keyword
   contains-clojure? :- s/Bool
   clojure :- Clojure]
  (when contains-clojure?
    (install-leiningen facility)))

(s/defn configure-user
  [facility :- s/Keyword
   os-user-name :- s/Str
   contains-clojure? :- s/Bool
   clojure :- Clojure]
  (when contains-clojure?
    (configure-user-leiningen facility os-user-name clojure)))

remove factored out function

remove factored out function


(ns akvo.lumen.lib.visualisation.maps
  (:require [akvo.lumen.http.client :as http.client]
            [akvo.lumen.lib :as lib]
            [akvo.lumen.postgres.filter :as filter]
            [akvo.lumen.lib.visualisation.map-config :as map-config]
            [akvo.lumen.lib.visualisation.map-metadata :as map-metadata]
            [akvo.lumen.lib.transformation.engine :as engine]
            [clojure.tools.logging :as log]
            [akvo.lumen.util :as util]
            [cheshire.core :as json]
            [clojure.core.match :refer [match]]
            [clojure.walk :as walk]
            [akvo.lumen.db.dataset :as db.dataset]
            [akvo.lumen.db.raster :as db.raster])
  (:import [com.zaxxer.hikari HikariDataSource]
           [java.net URI]))

(def http-client-req-defaults (http.client/req-opts 10000))

(defn- headers [tenant-conn]
  (let [db-uri (-> ^HikariDataSource (:datasource tenant-conn)
                   .getJdbcUrl
                   (subs 5)
                   URI.)
        {:keys [password user]} (util/query-map (.getQuery db-uri))
        port (let [p (.getPort db-uri)]
               (if (pos? p) p 5432))
        db-name (subs (.getPath db-uri) 1)]
    {"x-db-host" (.getHost db-uri)
     "x-db-last-update" (quot (System/currentTimeMillis) 1000)
     "x-db-password" password
     "x-db-port" port
     "X-db-name" db-name
     "x-db-user" user}))

(defn- check-columns
  "Make sure supplied columns are distinct and satisfy predicate."
  [p & columns]
  (and (= (count columns)
          (count (into #{} columns)))
       (every? p columns)))

(defn valid-location?
  "Validate map spec layer."
  [layer p]
  (let [m (into {} (remove (comp nil? val)
                           (select-keys layer [:geom :latitude :longitude])))]
    (match [m]
           [({:geom geom} :only [:geom])] (p geom)

           [({:geom geom :latitude latitude} :only [:geom :latitude])]
           (check-columns p geom latitude)

           [({:geom geom :longitude longitude} :only [:geom :longitude])]
           (check-columns p geom longitude)

           [({:latitude latitude :longitude longitude}
             :only [:latitude :longitude])]
           (check-columns p latitude longitude)

           [{:geom geom :latitude latitude :longitude longitude}]
           (check-columns p geom latitude longitude)

           :else false)))

(defn conform-create-args [layers]
  (let [dataset-id (->> layers
                        (filter (fn[layer] (util/valid-dataset-id? (:datasetId layer))))
                        first
                        :datasetId)
        raster-id (->> layers
                       (filter (fn[layer] (util/valid-dataset-id? (:rasterId layer))))
                       first
                       :rasterId)]
    (cond
      (and (not dataset-id) (not raster-id))
      (throw (ex-info "No valid datasetID"
                      {"reason" "No valid datasetID"}))

      (some (fn [layer] (not (valid-location? layer util/valid-column-name?)))
            (filter (fn [layer] (not (= (:layerType layer) "raster"))) layers))
      (throw (ex-info "Location spec not valid"
                      {"reason" "Location spec not valid"}))

      :else [(if (not dataset-id) raster-id dataset-id)])))

(defn create-raster [tenant-conn windshaft-url raster-id]
  (let [{:keys [raster_table metadata]} (db.raster/raster-by-id tenant-conn {:id raster-id})
        headers* (headers tenant-conn)
        url (format "%s/layergroup" windshaft-url)
        map-config (map-config/build-raster raster_table (:min metadata) (:max metadata))
        _ (log/debug :map-config map-config)
        layer-group-id (-> (http.client/post* url (merge http-client-req-defaults
                                                         {:body (json/encode map-config)
                                                          :headers headers*
                                                          :content-type :json}))
                           :body json/decode (get "layergroupid"))
        layer-meta (map-metadata/build tenant-conn raster_table {:layerType "raster"} nil nil)]
    (lib/ok {:layerGroupId layer-group-id
             :layerMetadata layer-meta})))

(defn metadata-layers [tenant-conn layers opts]
  (map (fn [current-layer]
         (let [current-layer-type (:layerType current-layer)
               current-dataset-id (if (= current-layer-type "raster")
                                    (:rasterId current-layer)
                                    (:datasetId current-layer))
               {:keys [table-name columns raster_table]} (if (= current-layer-type "raster")
                                                           (db.raster/raster-by-id tenant-conn {:id current-dataset-id})
                                                           (db.dataset/dataset-by-id tenant-conn {:id current-dataset-id}))
               current-where-clause (filter/sql-str (walk/keywordize-keys columns) (:filters current-layer))]
           (map-metadata/build tenant-conn
                               (or raster_table
                                   table-name
                                   (when (not= current-layer-type "raster")
                                     (throw
                                      (ex-info "no authorised to create a map visualisation with current dataset associated" {:datasetId current-dataset-id}))))
                               current-layer current-where-clause opts)))
       layers))

(defn create
  [tenant-conn windshaft-url layers opts]
  (try
    (conform-create-args layers)
    (let [metadata-array (metadata-layers tenant-conn layers opts)
          map-config (map-config/build tenant-conn "todo: remove this" layers metadata-array)
          headers* (headers tenant-conn)
          layer-group-id (-> (http.client/post* (format "%s/layergroup" windshaft-url)
                                                (merge http-client-req-defaults
                                                       {:body (json/encode map-config)
                                                        :headers headers*
                                                        :content-type :json}))
                             :body json/decode (get "layergroupid"))]
      (lib/ok {:layerGroupId layer-group-id
               :layerMetadata metadata-array}))
    (catch Exception e
      (println e)
      (lib/bad-request (ex-data e)))))

(ns akvo.lumen.lib.visualisation.maps
  (:require [akvo.lumen.http.client :as http.client]
            [akvo.lumen.lib :as lib]
            [akvo.lumen.postgres.filter :as filter]
            [akvo.lumen.lib.visualisation.map-config :as map-config]
            [akvo.lumen.lib.visualisation.map-metadata :as map-metadata]
            [akvo.lumen.lib.transformation.engine :as engine]
            [clojure.tools.logging :as log]
            [akvo.lumen.util :as util]
            [cheshire.core :as json]
            [clojure.core.match :refer [match]]
            [clojure.walk :as walk]
            [akvo.lumen.db.dataset :as db.dataset]
            [akvo.lumen.db.raster :as db.raster])
  (:import [com.zaxxer.hikari HikariDataSource]
           [java.net URI]))

(def http-client-req-defaults (http.client/req-opts 10000))

(defn- headers [tenant-conn]
  (let [db-uri (-> ^HikariDataSource (:datasource tenant-conn)
                   .getJdbcUrl
                   (subs 5)
                   URI.)
        {:keys [password user]} (util/query-map (.getQuery db-uri))
        port (let [p (.getPort db-uri)]
               (if (pos? p) p 5432))
        db-name (subs (.getPath db-uri) 1)]
    {"x-db-host" (.getHost db-uri)
     "x-db-last-update" (quot (System/currentTimeMillis) 1000)
     "x-db-password" password
     "x-db-port" port
     "X-db-name" db-name
     "x-db-user" user}))

(defn- check-columns
  "Make sure supplied columns are distinct and satisfy predicate."
  [p & columns]
  (and (= (count columns)
          (count (into #{} columns)))
       (every? p columns)))

(defn valid-location?
  "Validate map spec layer."
  [layer p]
  (let [m (into {} (remove (comp nil? val)
                           (select-keys layer [:geom :latitude :longitude])))]
    (match [m]
           [({:geom geom} :only [:geom])] (p geom)

           [({:geom geom :latitude latitude} :only [:geom :latitude])]
           (check-columns p geom latitude)

           [({:geom geom :longitude longitude} :only [:geom :longitude])]
           (check-columns p geom longitude)

           [({:latitude latitude :longitude longitude}
             :only [:latitude :longitude])]
           (check-columns p latitude longitude)

           [{:geom geom :latitude latitude :longitude longitude}]
           (check-columns p geom latitude longitude)

           :else false)))

(defn conform-create-args [layers]
  (let [dataset-id (->> layers
                        (filter (fn[layer] (util/valid-dataset-id? (:datasetId layer))))
                        first
                        :datasetId)
        raster-id (->> layers
                       (filter (fn[layer] (util/valid-dataset-id? (:rasterId layer))))
                       first
                       :rasterId)]
    (cond
      (and (not dataset-id) (not raster-id))
      (throw (ex-info "No valid datasetID"
                      {"reason" "No valid datasetID"}))

      (some (fn [layer] (not (valid-location? layer util/valid-column-name?)))
            (filter (fn [layer] (not (= (:layerType layer) "raster"))) layers))
      (throw (ex-info "Location spec not valid"
                      {"reason" "Location spec not valid"}))

      :else [(if (not dataset-id) raster-id dataset-id)])))

(defn create-raster [tenant-conn windshaft-url raster-id]
  (let [{:keys [raster_table metadata]} (db.raster/raster-by-id tenant-conn {:id raster-id})
        headers* (headers tenant-conn)
        url (format "%s/layergroup" windshaft-url)
        map-config (map-config/build-raster raster_table (:min metadata) (:max metadata))
        _ (log/debug :map-config map-config)
        layer-group-id (-> (http.client/post* url (merge http-client-req-defaults
                                                         {:body (json/encode map-config)
                                                          :headers headers*
                                                          :content-type :json}))
                           :body json/decode (get "layergroupid"))
        layer-meta (map-metadata/build tenant-conn raster_table {:layerType "raster"} nil nil)]
    (lib/ok {:layerGroupId layer-group-id
             :layerMetadata layer-meta})))

(defn metadata-layers [tenant-conn layers opts]
  (map (fn [current-layer]
         (let [current-layer-type (:layerType current-layer)
               current-dataset-id (if (= current-layer-type "raster")
                                    (:rasterId current-layer)
                                    (:datasetId current-layer))
               {:keys [table-name columns raster_table]} (if (= current-layer-type "raster")
                                                           (db.raster/raster-by-id tenant-conn {:id current-dataset-id})
                                                           (db.dataset/dataset-by-id tenant-conn {:id current-dataset-id}))
               current-where-clause (filter/sql-str (walk/keywordize-keys columns) (:filters current-layer))]
           (map-metadata/build tenant-conn
                               (or raster_table
                                   table-name
                                   (when (not= current-layer-type "raster")
                                     (throw
                                      (ex-info "no authorised to create a map visualisation with current dataset associated" {:datasetId current-dataset-id}))))
                               current-layer current-where-clause opts)))
       layers))

(defn create
  [tenant-conn windshaft-url layers opts]
  (try
    (conform-create-args layers)
    (let [metadata-array (metadata-layers tenant-conn layers opts)
          map-config (map-config/build tenant-conn layers metadata-array)
          headers* (headers tenant-conn)
          layer-group-id (-> (http.client/post* (format "%s/layergroup" windshaft-url)
                                                (merge http-client-req-defaults
                                                       {:body (json/encode map-config)
                                                        :headers headers*
                                                        :content-type :json}))
                             :body json/decode (get "layergroupid"))]
      (lib/ok {:layerGroupId layer-group-id
               :layerMetadata metadata-array}))
    (catch Exception e
      (println e)
      (lib/bad-request (ex-data e)))))

Remove table-name not used arg

[#2895] Remove table-name not used arg