(ns visibility-2d.core
  (:require [goog.dom :as dom]
            [goog.dom.ViewportSizeMonitor :as ViewportSizeMonitor]
            [goog.events :as events]
            [goog.events.EventType :as EventType]
            [goog.string :as string]
            [goog.string.format]
            [visibility-2d.ray :as ray]
            [visibility-2d.dali :as dali]
            [visibility-2d.vektor :as vektor]
            [visibility-2d.statistics :as statistics]))

;;; Global state

(defonce canvas (dom/getElement "c"))
(defonce polygons (atom))

(defn reset-polygons! [w h]
  (let [outline [{:x (dec 0) :y (dec 0)}
                 {:x (inc w) :y (dec 0)}
                 {:x (inc w) :y (inc h)}
                 {:x (dec 0) :y (inc h)}]]
    (reset! polygons
            (for [points [outline
                          [{:x  80 :y 100}
                           {:x 160 :y 120}
                           {:x 160 :y 180}
                           {:x 110 :y 200}]
                          [{:x 350 :y 250}
                           {:x 300 :y 200}
                           {:x 400 :y 100}
                           {:x 400 :y 170}]
                          [{:x 400 :y  20}
                           {:x 380 :y  40}
                           {:x 440 :y  60}]]]
              (vec (for [{:keys [x y]} points]
                     (vektor/point x y)))))))

;;; Visibility

(defn intersection [ray line]
  ;; ray = p + t * r
  ;; line-ray = q + u * s
  (let [[coordinate1 coordinate2] line
        line-ray (ray/ray coordinate1 coordinate2)
        {p :origin r :direction} ray
        {q :origin s :direction} line-ray
        q-p (vektor/subtract2d q p)
        rxs (vektor/det2d r s)]
    {:t (if (= 0 rxs) 0 (/ (vektor/det2d q-p s) rxs))
     :u (if (= 0 rxs) 0 (/ (vektor/det2d q-p r) rxs))}))

(defn sort-rays [rays]
  "Sorts rays based on their angles."
  (sort (comparator #(< (ray/angle2d %1) (ray/angle2d %2))) rays))

(defn all-lines [polygons]
  "Returns a list of lines (start and end points) that make up a polygon."
  (mapcat #(map list % (vektor/shift-vector %)) polygons))

(defn intersections [ray lines]
  "Returns a list of all intersections between ray and lines."
  (for [line lines
        :let [inter (intersection ray line)
              {:keys [t u]} inter]
        :when (and (> t 0) (> u 0) (<= u 1))]
    inter))

(defn all-rays [origin lines]
  (let [epsilon 0.00175]
    (for [line lines, point line, angle [0 (- epsilon) epsilon]]
      (ray/ray origin point angle))))

(defn visible-path [sorted-rays lines]
  (for [ray sorted-rays]
    (let [intersections (intersections ray lines)
          closest-t (reduce min (map #(:t %) intersections))]
      (ray/point2d ray closest-t))))

(defn visibility [origin polygons]
  (let [lines (all-lines polygons)
        all-rays (all-rays origin lines)
        sorted-rays (sort-rays all-rays)]
    (visible-path sorted-rays lines)))

;;; Benchmarking

(defn benchmark! [f]
  (let [html-element (dom/getElement "stats")
        number-of-samples 51
        samples (atom ())]
    (fn [event]
      (let [before (.now js/Date)
            result (f event)
            dt (- (.now js/Date) before)
            values (swap! samples #(take number-of-samples (cons dt %)))]
        (set! (.-hidden html-element) js/false)
        (dom/setTextContent
          html-element
          (str
            (string/format "samples: %02d\n" (count values))
            (string/format "mean: %.2f ms\n" (statistics/mean values))
            (string/format "median: %.2f ms" (statistics/median values))))
        result))))

;;; Drawing

(defn resize-canvas! [canvas]
  "Resizes the canvas to its parent's size and returns the context."
  (let [parent (.-parentElement canvas)
        width  (.-clientWidth parent)
        height (.-clientHeight parent)]
    (reset-polygons! width height)
    (dali/setup-canvas! canvas width height)))

(defn draw-scene! [ctx polygons]
  "Draws the polygons into the canvas' context."
  (let [canvas (.-canvas ctx)
        w (.-width canvas)
        h (.-height canvas)]
    (-> ctx
        (dali/fill-style! "#222")
        (dali/fill-rect! {:x 0 :y 0 :w w :h h})
        (dali/stroke-style! "white")
        (dali/stroke-paths! polygons)
        (dali/fill-style! "#ddd"))))

;;; Event Handling

(defn handle-mousemove! [event]
  (let [canvas (.-currentTarget event)
        ctx (dali/context-2d canvas)
        rect (.getBoundingClientRect canvas)
        x (- (.-clientX event) (.-left rect))
        y (- (.-clientY event) (.-top rect))
        visible-path (visibility (vektor/point x y) @polygons)]
    (-> ctx
        (draw-scene! @polygons)
        (dali/fill-path! visible-path)
        (dali/fill-style! "yellow")
        (dali/fill-circle! x y 4))))

(defn handle-mouseout! [event]
  (let [canvas (.-currentTarget event)
        ctx (dali/context-2d canvas)]
    (draw-scene! ctx @polygons)))

(defn handle-resize! [event]
  (draw-scene! (resize-canvas! canvas) @polygons))

; Set up event listeners
(events/listen (dom/ViewportSizeMonitor.) EventType/RESIZE handle-resize!)
(events/listen canvas EventType/MOUSEMOVE (benchmark! handle-mousemove!))
(events/listen canvas EventType/MOUSEOUT handle-mouseout!)

; Initial drawing
(draw-scene! (resize-canvas! canvas) @polygons)

(ns visibility-2d.core
  (:require [goog.dom :as dom]
            [goog.dom.ViewportSizeMonitor :as ViewportSizeMonitor]
            [goog.events :as events]
            [goog.events.EventType :as EventType]
            [goog.string :as string]
            [goog.string.format]
            [visibility-2d.ray :as ray]
            [visibility-2d.dali :as dali]
            [visibility-2d.vektor :as vektor]
            [visibility-2d.statistics :as statistics]))

;;; Global state

(defonce canvas (dom/getElement "c"))
(defonce polygons (atom))

(defn reset-polygons! [w h]
  (let [outline [{:x (dec 0) :y (dec 0)}
                 {:x (inc w) :y (dec 0)}
                 {:x (inc w) :y (inc h)}
                 {:x (dec 0) :y (inc h)}]]
    (reset! polygons
            (for [points [outline
                          [{:x  80 :y 100}
                           {:x 160 :y 120}
                           {:x 160 :y 180}
                           {:x 110 :y 200}]
                          [{:x 350 :y 250}
                           {:x 300 :y 200}
                           {:x 400 :y 100}
                           {:x 400 :y 170}]
                          [{:x 400 :y  20}
                           {:x 380 :y  40}
                           {:x 440 :y  60}]]]
              (vec (for [{:keys [x y]} points]
                     (vektor/point x y)))))))

;;; Visibility

(defn intersection [ray line]
  ;; ray = p + t * r
  ;; line-ray = q + u * s
  (let [[coordinate1 coordinate2] line
        line-ray (ray/ray coordinate1 coordinate2)
        {p :origin r :direction} ray
        {q :origin s :direction} line-ray
        q-p (vektor/subtract2d q p)
        rxs (vektor/det2d r s)]
    {:t (if (= 0 rxs) 0 (/ (vektor/det2d q-p s) rxs))
     :u (if (= 0 rxs) 0 (/ (vektor/det2d q-p r) rxs))}))

(defn sort-rays [rays]
  "Sorts rays based on their angles."
  (sort (comparator #(< (ray/angle2d %1) (ray/angle2d %2))) rays))

(defn all-lines [polygons]
  "Returns a list of lines (start and end points) that make up a polygon."
  (mapcat #(map list % (vektor/shift-vector %)) polygons))

(defn intersections [ray lines]
  "Returns a list of all intersections between ray and lines."
  (for [line lines
        :let [inter (intersection ray line)
              {:keys [t u]} inter]
        :when (and (> t 0) (> u 0) (<= u 1))]
    inter))

(defn all-rays [origin lines]
  (let [epsilon 0.00175]
    (for [line lines, point line, angle [0 (- epsilon) epsilon]]
      (ray/ray origin point angle))))

(defn visible-path [sorted-rays lines]
  (for [ray sorted-rays]
    (let [intersections (intersections ray lines)
          closest-t (reduce min (map #(:t %) intersections))]
      (ray/point2d ray closest-t))))

(defn visibility [origin polygons]
  (let [lines (all-lines polygons)
        all-rays (all-rays origin lines)
        sorted-rays (sort-rays all-rays)]
    (visible-path sorted-rays lines)))

;;; Benchmarking

(defn benchmark! [f]
  (let [html-element (dom/getElement "stats")
        number-of-samples 51
        samples (atom ())]
    (fn [event]
      (let [before (.now js/Date)
            result (f event)
            dt (- (.now js/Date) before)
            values (swap! samples #(take number-of-samples (cons dt %)))]
        (set! (.-hidden html-element) js/false)
        (dom/setTextContent
          html-element
          (str
            (string/format "samples: %02d\n" (count values))
            (string/format "mean: %.2f ms\n" (statistics/mean values))
            (string/format "median: %.2f ms" (statistics/median values))))
        result))))

;;; Drawing

(defn resize-canvas! [canvas]
  "Resizes the canvas to its parent's size and returns the context."
  (let [parent (.-parentElement canvas)
        width  (.-clientWidth parent)
        height (.-clientHeight parent)]
    (reset-polygons! width height)
    (dali/setup-canvas! canvas width height)))

(defn draw-scene! [ctx polygons]
  "Draws the polygons into the canvas' context."
  (let [canvas (.-canvas ctx)
        w (.-width canvas)
        h (.-height canvas)]
    (-> ctx
        (dali/fill-style! "#222")
        (dali/fill-rect! {:x 0 :y 0 :w w :h h})
        (dali/stroke-style! "white")
        (dali/stroke-paths! polygons)
        (dali/fill-style! "#ddd"))))

;;; Event Handling

(defn handle-mousemove! [event]
  (let [canvas (.-currentTarget event)
        ctx (dali/context-2d canvas)
        rect (.getBoundingClientRect canvas)
        x (- (.-clientX event) (.-left rect))
        y (- (.-clientY event) (.-top rect))
        visible-path (visibility (vektor/point x y) @polygons)]
    (-> ctx
        (draw-scene! @polygons)
        (dali/fill-path! visible-path)
        (dali/fill-style! "yellow")
        (dali/fill-circle! x y 4))))

(defn handle-mouseout! [event]
  (let [canvas (.-currentTarget event)
        ctx (dali/context-2d canvas)]
    (.preventDefault event)
    (draw-scene! ctx @polygons)))

(defn handle-resize! [event]
  (draw-scene! (resize-canvas! canvas) @polygons))

; Set up event listeners
(events/listen (dom/ViewportSizeMonitor.) EventType/RESIZE handle-resize!)
(events/listen canvas EventType/MOUSEMOVE (benchmark! handle-mousemove!))
(events/listen canvas EventType/MOUSEOUT handle-mouseout!)
(events/listen canvas EventType/TOUCHSTART handle-mousemove!)
(events/listen canvas EventType/TOUCHMOVE handle-mousemove!)
(events/listen canvas EventType/TOUCHEND handle-mouseout!)

; Initial drawing
(draw-scene! (resize-canvas! canvas) @polygons)

Handle touch events

Handle touch events


(ns babel.test.la
  (:refer-clojure :exclude [get-in])
  (:require
   [babel.directory :refer [models]]
   [babel.english :as source]
   [babel.latin.morphology :refer [analyze conjugate]]
   [babel.latin :as target :refer [morph read-one]]
   [clojure.repl :refer [doc]]
   [clojure.test :refer [deftest is]]
   [clojure.tools.logging :as log]
   [dag_unify.core :refer [get-in strip-refs unify]]))

(def source-language :en)

(defn latin-model [] (-> ((-> models :la)) deref))

(defn generate [spec]
  ((-> (latin-model) :generate-fn) spec))

;; https://en.wikipedia.org/wiki/Latin_conjugation#Present_indicative
(deftest analyze-ere
  (let [lexicon (-> ((-> models :la)) deref :lexicon)]
    (is (= :verb
           (-> (analyze "ardeo" lexicon)
               first
               (get-in [:synsem :cat]))))))

(deftest conjugate-ere
  (is (= "ardemus"
         (conjugate "ardēre"
                    {:synsem {:agr {:person :1st :number :plur}}}))))

(deftest generate-present
  (is (= "ardetis"
         (morph (generate
                 {:root "ardēre"
                  :synsem {:agr {:person :2nd :number :plur}
                           :sem {:tense :present}}})))))

(deftest generate-imperfect
  (is (= "ardebam"
         (morph (generate
                 {:root "ardēre"
                  :synsem {:agr {:person :1st :number :sing}
                           :sem {:tense :past
                              :aspect :progressive}}})))))
(deftest generate-future
  (is (= "ardebunt"
         (morph (generate
              {:root "ardēre"
               :synsem {:agr {:person :3rd :number :plur}
                        :sem {:tense :future}}})))))
(deftest reader1
  (let [spec (let [agreement (atom {:person :3rd :number :sing :gender :masc})]
               {:slash false ;; TODO: {:slash false, :synsem {:subcat '()}} should be part of default spec.
                :synsem {:subcat '()
                         :agr agreement
                         :sem {:obj :unspec
                               :tense :past
                               :subj {:pred :lui}
                               :aspect :progressive
                               :pred :answer}}
                :comp {:synsem {:agr agreement}}})
        source-format-fn (-> ((-> models source-language)) deref :morph)
        source-generate-fn (-> ((-> models source-language)) deref :generate-fn)
        target-format-fn (-> ((-> models :la)) deref :morph)

        source (->
                spec
                source-generate-fn
                source-format-fn)
        target (->
                spec
                generate
                target-format-fn)]
    (log/info (str "source: " source))
    (log/info (str "target: " target))
    (is (or (= source "he used to answer")
            (= source "he was answering")
            (= source "he used to respond")
            (= source "he was responding")))
    (is (or (= target "respondebat")))))

(deftest reader2
  (let [source-model (-> ((-> models :en)) deref)

        ;; use a specific :root and verb conjugation so that we can test
        ;; for specific literal strings in the result.
        results (take 10 (repeatedly #(read-one {:root "ardēre"
                                                 :synsem {:sem {:tense :past
                                                                :aspect :progressive}}}
                                                (latin-model) source-model)))]
    (doall
     (->> results
          (map (fn [result]
                 (let [possible-answer (first (shuffle (get result :targets)))]
                   (log/debug (str "reader2 possible-answer:" possible-answer))
                   (is
                    (or
                     (and
                      (= "ardebam"
                         possible-answer))
                     (and
                      (= "ardebas"
                         possible-answer))
                     (and
                      (= "ardebamus"
                         possible-answer))
                     (and
                      (= "ardebatis"
                         possible-answer))
                     (and
                      (= "ardebat"
                         possible-answer))
                     (and
                      (= "ardebant"
                         possible-answer))
                     (or
                      (log/info (str "failsafe: result:" result))
                      (log/info (str "failsafe: possible-answer:" possible-answer))
                      false))))))))))

(ns babel.test.la
  (:refer-clojure :exclude [get-in])
  (:require
   [babel.directory :refer [models]]
   [babel.english :as source]
   [babel.latin.morphology :refer [analyze conjugate]]
   [babel.latin :as target :refer [morph read-one]]
   [clojure.repl :refer [doc]]
   [clojure.test :refer [deftest is]]
   [clojure.tools.logging :as log]
   [dag_unify.core :refer [get-in strip-refs unify]]))

(def source-language :en)

(defn latin-model [] (-> ((-> models :la)) deref))

(defn generate [spec]
  ((-> (latin-model) :generate-fn) spec))

;; https://en.wikipedia.org/wiki/Latin_conjugation#Present_indicative
(deftest analyze-ere
  (let [lexicon (-> ((-> models :la)) deref :lexicon)]
    (is (= :verb
           (-> (analyze "ardeo" lexicon)
               first
               (get-in [:synsem :cat]))))))

(deftest conjugate-ere
  (is (= "ardemus"
         (conjugate "ardēre"
                    {:synsem {:agr {:person :1st :number :plur}}}))))

(deftest generate-present
  (is (= "ardetis"
         (morph (generate
                 {:root "ardēre"
                  :synsem {:agr {:person :2nd :number :plur}
                           :sem {:tense :present}}})))))

(deftest generate-imperfect
  (is (= "ardebam"
         (morph (generate
                 {:root "ardēre"
                  :synsem {:agr {:person :1st :number :sing}
                           :sem {:tense :past
                              :aspect :progressive}}})))))
(deftest generate-future
  (is (= "ardebunt"
         (morph (generate
              {:root "ardēre"
               :synsem {:agr {:person :3rd :number :plur}
                        :sem {:tense :future}}})))))
(deftest reader1
  (let [spec (let [agreement (atom {:person :3rd :number :sing :gender :masc})]
               {:synsem {:slash false
                         :agr agreement
                         :sem {:obj :unspec
                               :tense :past
                               :subj {:pred :lui}
                               :aspect :progressive
                               :pred :answer}}
                :comp {:synsem {:agr agreement}}})
        source-format-fn (-> ((-> models source-language)) deref :morph)
        source-generate-fn (-> ((-> models source-language)) deref :generate-fn)
        target-format-fn (-> ((-> models :la)) deref :morph)

        source (->
                spec
                source-generate-fn
                source-format-fn)
        target (->
                spec
                generate
                target-format-fn)]
    (log/info (str "source: " source))
    (log/info (str "target: " target))
    (is (or (= source "he used to answer")
            (= source "he was answering")
            (= source "he used to respond")
            (= source "he was responding")))
    (is (or (= target "respondebat")))))

(deftest reader2
  (let [source-model (-> ((-> models :en)) deref)

        ;; use a specific :root and verb conjugation so that we can test
        ;; for specific literal strings in the result.
        results (take 10 (repeatedly #(read-one {:root "ardēre"
                                                 :synsem {:sem {:tense :past
                                                                :aspect :progressive}}}
                                                (latin-model) source-model)))]
    (doall
     (->> results
          (map (fn [result]
                 (let [possible-answer (first (shuffle (get result :targets)))]
                   (log/debug (str "reader2 possible-answer:" possible-answer))
                   (is
                    (or
                     (and
                      (= "ardebam"
                         possible-answer))
                     (and
                      (= "ardebas"
                         possible-answer))
                     (and
                      (= "ardebamus"
                         possible-answer))
                     (and
                      (= "ardebatis"
                         possible-answer))
                     (and
                      (= "ardebat"
                         possible-answer))
                     (and
                      (= "ardebant"
                         possible-answer))
                     (or
                      (log/info (str "failsafe: result:" result))
                      (log/info (str "failsafe: possible-answer:" possible-answer))
                      false))))))))))

move {:slash false} into {:synsem}

move {:slash false} into {:synsem}


(ns runbld.main
  (:gen-class)
  (:require [clj-git.core :as git]
            [clojure.pprint :refer [pprint]]
            [environ.core :as environ]
            [runbld.build :as build]
            [runbld.notifications.email :as email]
            [runbld.notifications.slack :as slack]
            [runbld.java :as java]
            [runbld.opts :as opts]
            [runbld.process :as proc]
            [runbld.scheduler.middleware :as scheduler]
            [runbld.schema :refer :all]
            [runbld.store :as store]
            [runbld.system :as system]
            [runbld.tests :as tests]
            [runbld.io :as io]
            [runbld.util.date :as date]
            [runbld.vcs.git :refer [checkout-commit]]
            [runbld.vcs.middleware :as vcs]
            [runbld.version :as version]
            [schema.core :as s]
            [slingshot.slingshot :refer [try+ throw+]]))

(defn really-die
  ([code]
   (really-die nil))
  ([code strmsg]
   (when strmsg
     (println strmsg))
   (shutdown-agents)
   ;; Give stdout a chance to finish.  Jenkins can wait.
   (Thread/sleep 5000)
   (System/exit code)))

(defn die
  ([code]
   (die code nil))
  ([code msg]
   (let [msg* (if msg
                (.trim (with-out-str (println msg))))]
     (really-die code msg*)
     ;; for tests when #'really-die is redefed
     msg*)))

(defn wipe-workspace [workspace]
  (io/log "wiping workspace" workspace)
  (io/rmdir-contents workspace))

(s/defn bootstrap-workspace
  ([raw-opts :- OptsWithLogger]
   (let [clone? (boolean (-> raw-opts :scm :clone))
         wipe-workspace? (boolean (-> raw-opts :scm :wipe-workspace))
         workspace (System/getenv "WORKSPACE")
         local (-> raw-opts :process :cwd)
         remote (-> raw-opts :scm :url)
         reference (-> raw-opts :scm :reference-repo)
         branch (-> raw-opts :scm :branch)
         depth (-> raw-opts :scm :depth)]
     (when clone?
       (let [clone-args (->> [(when reference ["--reference" reference])
                              (when branch ["--branch" branch])
                              (when depth ["--depth" (str depth)])]
                             (filter identity)
                             (apply concat))]
         (when wipe-workspace?
           (wipe-workspace workspace))
         (io/log "cloning" remote)
         (git/git-clone local remote clone-args)
         (io/log "done cloning"))))))

(def make-opts
  (-> #'identity
      vcs/wrap-vcs-info
      build/wrap-build-meta
      scheduler/wrap-scheduler
      java/wrap-java
      system/wrap-system))

(defn maybe-log-last-success [opts]
  (when (-> opts :build :last-success :checked-out)
    (let [b (build/find-build opts (-> opts :build :last-success :id))
          commit (-> b :vcs :commit-short)]
      (io/log "using last successful commit"
              commit
              "from"
              (-> b :build :job-name) (-> b :id)
              (-> b :process :time-start)
              (date/human-duration
               (date/iso-diff-secs
                (date/from-iso
                 ;; notify on time-end because it makes more
                 ;; logical sense to report on the last
                 ;; completed build's end time, I think
                 (-> b :process :time-end))
                (date/now)))
              "ago"))))

;; -main :: IO ()
(defn -main [& args]
  (try+
   (let [raw-opts (assoc
                   (opts/parse-args args)
                   :logger io/log)
         _ (io/log (version/string))
         _ (bootstrap-workspace raw-opts)
         opts (make-opts raw-opts)
         _ (maybe-log-last-success opts)
         _ (io/log ">>>>>>>>>>>> SCRIPT EXECUTION BEGIN >>>>>>>>>>>>")
         {:keys [opts process-result]} (proc/run opts)
         _ (io/log "<<<<<<<<<<<< SCRIPT EXECUTION END <<<<<<<<<<<<")
         {:keys [took status exit-code out-bytes err-bytes]} process-result
         _ (io/log (format "DURATION: %sms" took))
         _ (io/log (format "STDOUT: %d bytes" out-bytes))
         _ (io/log (format "STDERR: %d bytes" err-bytes))
         _ (io/log (format "WRAPPED PROCESS: %s (%d)" status exit-code))
         test-report (tests/report (-> opts :process :cwd))
         store-result (store/save! opts process-result test-report)
         slack-result (io/try-log (slack/maybe-send! opts (:addr store-result)))
         email-result (io/try-log (email/maybe-send! opts (:addr store-result)))]

     (if (environ/env :dev)
       (assoc process-result
              :store-result store-result
              :email-result email-result
              :slack-result slack-result)
       (if (-> opts :process :inherit-exit-code)
         (die (-> store-result :build-doc :process :exit-code))
         (die 0))))

   (catch [:error :runbld.main/errors] {:keys [errors msg]}
     (die 3 msg))

   (catch [:error :runbld.opts/parse-error] {:keys [msg]}
     (die 2 msg))

   (catch [:error :runbld.opts/file-not-found] {:keys [msg]}
     (die 2 msg))

   (catch [:help :runbld.opts/version] {:keys [msg]}
     (die 0 msg))

   (catch [:help :runbld.opts/usage] {:keys [msg]}
     (die 0 msg))

   (catch [:help :runbld.opts/system] {:keys [msg]}
     (die 0 (with-out-str
              (clojure.pprint/pprint
               (into (sorted-map)
                     (system/inspect-system "."))))))

   (catch [:error :runbld.vcs.middleware/unknown-repo] {:keys [msg opts]}
     (io/log msg)
     (when (environ/env :dev)
       (io/log "DUMPING CONFIG for DEV=true")
       (io/log
        (with-out-str
          (clojure.pprint/pprint opts))))
     (die 1))

   (catch Exception e
     (die 1 e))))

(ns runbld.main
  (:gen-class)
  (:require [clj-git.core :as git]
            [clojure.pprint :refer [pprint]]
            [environ.core :as environ]
            [runbld.build :as build]
            [runbld.notifications.email :as email]
            [runbld.notifications.slack :as slack]
            [runbld.java :as java]
            [runbld.opts :as opts]
            [runbld.process :as proc]
            [runbld.scheduler.middleware :as scheduler]
            [runbld.schema :refer :all]
            [runbld.store :as store]
            [runbld.system :as system]
            [runbld.tests :as tests]
            [runbld.io :as io]
            [runbld.util.date :as date]
            [runbld.vcs.git :refer [checkout-commit]]
            [runbld.vcs.middleware :as vcs]
            [runbld.version :as version]
            [schema.core :as s]
            [slingshot.slingshot :refer [try+ throw+]]))

(defn really-die
  ([code]
   (really-die nil))
  ([code strmsg]
   (when strmsg
     (println strmsg))
   (shutdown-agents)
   ;; Give stdout a chance to finish.  Jenkins can wait.
   (Thread/sleep 5000)
   (System/exit code)))

(defn die
  ([code]
   (die code nil))
  ([code msg]
   (let [msg* (if msg
                (.trim (with-out-str (println msg))))]
     (really-die code msg*)
     ;; for tests when #'really-die is redefed
     msg*)))

(defn wipe-workspace [workspace]
  (io/log "wiping workspace" workspace)
  (io/rmdir-contents workspace))

(s/defn bootstrap-workspace
  ([raw-opts :- OptsWithLogger]
   (let [clone? (boolean (-> raw-opts :scm :clone))
         wipe-workspace? (boolean (-> raw-opts :scm :wipe-workspace))
         workspace (System/getenv "WORKSPACE")
         local (-> raw-opts :process :cwd)
         remote (-> raw-opts :scm :url)
         reference (-> raw-opts :scm :reference-repo)
         branch (-> raw-opts :scm :branch)
         depth (-> raw-opts :scm :depth)]
     (when clone?
       (let [clone-args (->> [(when reference ["--reference" reference])
                              (when branch ["--branch" (str branch)])
                              (when depth ["--depth" (str depth)])]
                             (filter identity)
                             (apply concat))]
         (when wipe-workspace?
           (wipe-workspace workspace))
         (io/log "cloning" remote)
         (git/git-clone local remote clone-args)
         (io/log "done cloning"))))))

(def make-opts
  (-> #'identity
      vcs/wrap-vcs-info
      build/wrap-build-meta
      scheduler/wrap-scheduler
      java/wrap-java
      system/wrap-system))

(defn maybe-log-last-success [opts]
  (when (-> opts :build :last-success :checked-out)
    (let [b (build/find-build opts (-> opts :build :last-success :id))
          commit (-> b :vcs :commit-short)]
      (io/log "using last successful commit"
              commit
              "from"
              (-> b :build :job-name) (-> b :id)
              (-> b :process :time-start)
              (date/human-duration
               (date/iso-diff-secs
                (date/from-iso
                 ;; notify on time-end because it makes more
                 ;; logical sense to report on the last
                 ;; completed build's end time, I think
                 (-> b :process :time-end))
                (date/now)))
              "ago"))))

;; -main :: IO ()
(defn -main [& args]
  (try+
   (let [raw-opts (assoc
                   (opts/parse-args args)
                   :logger io/log)
         _ (io/log (version/string))
         _ (bootstrap-workspace raw-opts)
         opts (make-opts raw-opts)
         _ (maybe-log-last-success opts)
         _ (io/log ">>>>>>>>>>>> SCRIPT EXECUTION BEGIN >>>>>>>>>>>>")
         {:keys [opts process-result]} (proc/run opts)
         _ (io/log "<<<<<<<<<<<< SCRIPT EXECUTION END <<<<<<<<<<<<")
         {:keys [took status exit-code out-bytes err-bytes]} process-result
         _ (io/log (format "DURATION: %sms" took))
         _ (io/log (format "STDOUT: %d bytes" out-bytes))
         _ (io/log (format "STDERR: %d bytes" err-bytes))
         _ (io/log (format "WRAPPED PROCESS: %s (%d)" status exit-code))
         test-report (tests/report (-> opts :process :cwd))
         store-result (store/save! opts process-result test-report)
         slack-result (io/try-log (slack/maybe-send! opts (:addr store-result)))
         email-result (io/try-log (email/maybe-send! opts (:addr store-result)))]

     (if (environ/env :dev)
       (assoc process-result
              :store-result store-result
              :email-result email-result
              :slack-result slack-result)
       (if (-> opts :process :inherit-exit-code)
         (die (-> store-result :build-doc :process :exit-code))
         (die 0))))

   (catch [:error :runbld.main/errors] {:keys [errors msg]}
     (die 3 msg))

   (catch [:error :runbld.opts/parse-error] {:keys [msg]}
     (die 2 msg))

   (catch [:error :runbld.opts/file-not-found] {:keys [msg]}
     (die 2 msg))

   (catch [:help :runbld.opts/version] {:keys [msg]}
     (die 0 msg))

   (catch [:help :runbld.opts/usage] {:keys [msg]}
     (die 0 msg))

   (catch [:help :runbld.opts/system] {:keys [msg]}
     (die 0 (with-out-str
              (clojure.pprint/pprint
               (into (sorted-map)
                     (system/inspect-system "."))))))

   (catch [:error :runbld.vcs.middleware/unknown-repo] {:keys [msg opts]}
     (io/log msg)
     (when (environ/env :dev)
       (io/log "DUMPING CONFIG for DEV=true")
       (io/log
        (with-out-str
          (clojure.pprint/pprint opts))))
     (die 1))

   (catch Exception e
     (die 1 e))))

Make sure the branch is a string.

Make sure the branch is a string.


(ns shale.nodes
  (:require [clojure.set :refer [difference]]
            [clojure.core.match :refer [match]]
            [taoensso.carmine :as car :refer (wcar)]
            [schema.core :as s]
            [clojure.walk :refer :all]
            [com.stuartsierra.component :as component]
            [shale.logging :as logging]
            [shale.node-providers :as node-providers]
            [shale.redis :as redis]
            [shale.utils :refer :all])
  (:import java.util.UUID))

(deftype ConfigNodeProvider [])

(defn node-pool-impl-from-config [{:keys [get-node add-node remove-node can-add-node can-remove-node] :as impl}]
  (reify node-providers/INodeProvider
    (get-nodes [this]
      ((:get-nodes impl) this))
    (add-node [this url]
      ((:add-node impl) this url))
    (remove-node [this url]
      ((:remove-node impl) this url))
    (can-add-node [this]
      ((:can-add-node impl) this))
    (can-remove-node [this]
      ((:can-remove-node impl) this))))

(defn node-provider-from-config [config]
  (match config
    {:node-pool-cloud-config cloud-config} (match cloud-config
                                             {:provider :aws} (node-providers/new-aws-node-provider cloud-config)
                                             {:provider :kube} (node-providers/new-kube-node-provider cloud-config))
    {:node-pool-impl impl} (node-pool-impl-from-config impl)
    {:node-list nodes} (node-providers/new-default-node-provider nodes)
    _ (node-providers/new-default-node-provider ["http://localhost:5555/wd/hub"])))

(s/defrecord NodePool
  [redis-conn
   logger
   node-provider
   default-session-limit
   config]
  component/Lifecycle
  (start [cmp]
    (logging/info "Starting the node pool...")
    (let [node-provider (node-provider-from-config config)
          default-session-limit (or (:node-max-sessions config) 3)]
      (logging/infof "Found nodes: %s" (vec (node-providers/get-nodes node-provider)))
      (assoc cmp
             :node-provider node-provider
             :default-session-limit default-session-limit)))
  (stop [cmp]
    (logging/info "Stopping the node pool...")
    (assoc cmp :node-provider nil)))

(defn new-node-pool [config]
  (map->NodePool {:config config}))

(s/defn node-ids :- [s/Str] [pool :- NodePool]
  (car/wcar (:redis-conn pool)
    (car/smembers (redis/model-ids-key redis/NodeInRedis))))

(s/defschema NodeView
  "A node, as presented to library users."
  {:id           s/Str
   :url          s/Str
   :tags         #{s/Str}
   :max-sessions s/Int})

(s/defn ->NodeView :- NodeView
  [id :- s/Str
   from-redis :- redis/NodeInRedis]
  (->> from-redis
       (merge {:id id})
       keywordize-keys))

(s/defn view-model :- (s/maybe NodeView)
  "Given a node pool, get a view model from Redis."
  [pool :- NodePool
   id   :- s/Str]
  (when-let [m (redis/model (:redis-conn pool) redis/NodeInRedis id)]
    (->NodeView id m)))

(s/defn view-models :- [NodeView]
  "Get all view models from a node pool."
  [pool :- NodePool]
  (map #(view-model pool %) (node-ids pool)))

(s/defn view-model-from-url :- NodeView
  [pool :- NodePool
   url  :- s/Str]
  (first (filter #(= (% :url) url) (view-models pool))))

(s/defn ^:always-validate view-model-exists? :- s/Bool
  [pool :- NodePool
   id   :- s/Str]
  (redis/model-exists? (:redis-conn pool) redis/NodeInRedis id))

(s/defn modify-node :- NodeView
  "Modify a node's url or tags in Redis."
  [pool :- NodePool
   id   :- s/Str
   {:keys [url tags max-sessions]
    :or {url nil
         tags nil
         max-sessions nil}
    :as node}]
  (last
    (car/wcar (:redis-conn pool)
      (let [node-key (redis/model-key redis/NodeInRedis id)
            node-tags-key (redis/node-tags-key id)]
        (redis/hset-all node-key
                        (merge {}
                               (if url {:url (str url)})
                               (if max-sessions {:max-sessions max-sessions})))
        (when tags (redis/sset-all node-tags-key tags))
        (car/return (view-model pool id))))))

(s/defn ^:always-validate create-node :- NodeView
  "Create a node in a given pool."
  [pool :- NodePool
   {:keys [url tags max-sessions]
    :or {tags #{}
         max-sessions (:default-session-limit pool)}}]
  (last
    (car/wcar (:redis-conn pool)
      (let [id (gen-uuid)
            node-key (redis/model-key redis/NodeInRedis id)]
        (car/sadd (redis/model-ids-key redis/NodeInRedis) id)
        (car/return (modify-node pool id {:url url
                                          :tags tags
                                          :max-sessions max-sessions}))))))

(s/defn ^:always-validate destroy-node
  [pool :- NodePool
   id   :- s/Str]
  (car/wcar (:redis-conn pool)
    (car/watch (redis/model-ids-key redis/NodeInRedis))
    (try
      (let [url (:url (view-model pool id))]
        (if (some #{url} (node-providers/get-nodes (:node-provider pool)))
          (node-providers/remove-node (:node-provider pool) url)))
      (finally
        (redis/delete-model! (:redis-conn pool) redis/NodeInRedis id)
        (car/del (redis/node-tags-key id)))))
  true)

(defn ^:private to-set [s]
  (into #{} s))

(def ^:private refresh-nodes-lock {})

(s/defn refresh-nodes
  "Syncs the node list with the backing node provider."
  [pool :- NodePool]
  (locking refresh-nodes-lock
    (logging/debug "Refreshing nodes...")
    (let [nodes (->> (:node-provider pool)
                     node-providers/get-nodes
                     to-set)
          registered-nodes (->> (view-models pool)
                                (map :url)
                                to-set)]
      (logging/debug "Live nodes:")
      (logging/debug nodes)
      (logging/debug "Nodes in Redis:")
      (logging/debug registered-nodes)
      (doall
        (concat
          (map #(create-node pool {:url %})
               (filter identity
                       (difference nodes registered-nodes)))
          (map #(destroy-node pool (:id (view-model-from-url pool %)))
               (filter identity
                       (difference registered-nodes nodes))))))
    true))

(s/defschema NodeRequirement
  "A schema for a node requirement."
  (any-pair
    :id  s/Str
    :tag s/Str
    :url s/Str
    :not (s/recursive #'NodeRequirement)
    :and [(s/recursive #'NodeRequirement)]
    :or  [(s/recursive #'NodeRequirement)]))

(s/defn ^:always-validate raw-sessions-with-node [pool    :- NodePool
                                                  node-id :- s/Str]
  (let [redis-conn (:redis-conn pool)]
    (->> (redis/models redis-conn
                       redis/SessionInRedis
                       :include-soft-deleted? true)
         (filter #(= node-id (:node-id %))))))

(s/defn ^:always-validate raw-session-count [pool    :- NodePool
                                             node-id :- s/Str]
  (count (raw-sessions-with-node pool node-id)))

(s/defn ^:always-validate nodes-under-capacity
  "Nodes with available capacity."
  [pool :- NodePool]
  (let [session-limit (:default-session-limit pool)]
    (filter #(< (raw-session-count pool (:id %)) session-limit)
            (view-models pool))))

(s/defn ^:always-validate matches-requirement :- s/Bool
  [model       :- NodeView
   requirement :- (s/maybe NodeRequirement)]
  (logging/debug
    (format "Testing node %s against requirement %s."
            model
            requirement))
  (if requirement
    (let [[req-type arg] requirement
          n model]
      (-> (match req-type
                 :tag (some #{arg} (:tags n))
                 :id  (= arg (:id n))
                 :url (= arg (:url n))
                 :not (not     (matches-requirement n arg))
                 :and (every? #(matches-requirement n %) arg)
                 :or  (some   #(matches-requirement n %) arg))
          boolean))
    true))

(s/defn ^:always-validate get-node :- (s/maybe NodeView)
  [pool        :- NodePool
   requirement :- (s/maybe NodeRequirement)]
  (try
    (rand-nth
      (filter #(matches-requirement % requirement)
              (nodes-under-capacity pool)))
    (catch IndexOutOfBoundsException e)))

(ns shale.nodes
  (:require [clojure.set :refer [difference]]
            [clojure.core.match :refer [match]]
            [taoensso.carmine :as car :refer (wcar)]
            [schema.core :as s]
            [clojure.walk :refer :all]
            [com.stuartsierra.component :as component]
            [shale.logging :as logging]
            [shale.node-providers :as node-providers]
            [shale.redis :as redis]
            [shale.utils :refer :all])
  (:import java.util.UUID))

(deftype ConfigNodeProvider [])

(defn node-pool-impl-from-config [{:keys [get-node add-node remove-node can-add-node can-remove-node] :as impl}]
  (reify node-providers/INodeProvider
    (get-nodes [this]
      ((:get-nodes impl) this))
    (add-node [this url]
      ((:add-node impl) this url))
    (remove-node [this url]
      ((:remove-node impl) this url))
    (can-add-node [this]
      ((:can-add-node impl) this))
    (can-remove-node [this]
      ((:can-remove-node impl) this))))

(defn node-provider-from-config [config]
  (match config
    {:node-pool-cloud-config cloud-config} (match cloud-config
                                             {:provider :aws} (node-providers/new-aws-node-provider cloud-config)
                                             {:provider :kube} (node-providers/new-kube-node-provider cloud-config))
    {:node-pool-impl impl} (node-pool-impl-from-config impl)
    {:node-list nodes} (node-providers/new-default-node-provider nodes)
    _ (node-providers/new-default-node-provider ["http://localhost:5555/wd/hub"])))

(s/defrecord NodePool
  [redis-conn
   logger
   node-provider
   default-session-limit
   config]
  component/Lifecycle
  (start [cmp]
    (logging/info "Starting the node pool...")
    (let [node-provider (node-provider-from-config config)
          default-session-limit (or (:node-max-sessions config) 3)]
      (logging/infof "Found nodes: %s" (vec (node-providers/get-nodes node-provider)))
      (assoc cmp
             :node-provider node-provider
             :default-session-limit default-session-limit)))
  (stop [cmp]
    (logging/info "Stopping the node pool...")
    (assoc cmp :node-provider nil)))

(defn new-node-pool [config]
  (map->NodePool {:config config}))

(s/defn node-ids :- [s/Str] [pool :- NodePool]
  (car/wcar (:redis-conn pool)
    (car/smembers (redis/model-ids-key redis/NodeInRedis))))

(s/defschema NodeView
  "A node, as presented to library users."
  {:id           s/Str
   :url          s/Str
   :tags         #{s/Str}
   :max-sessions s/Int})

(s/defn ->NodeView :- NodeView
  [id :- s/Str
   from-redis :- redis/NodeInRedis]
  (->> from-redis
       (merge {:id id})
       keywordize-keys))

(s/defn view-model :- (s/maybe NodeView)
  "Given a node pool, get a view model from Redis."
  [pool :- NodePool
   id   :- s/Str]
  (when-let [m (redis/model (:redis-conn pool) redis/NodeInRedis id)]
    (->NodeView id m)))

(s/defn view-models :- [NodeView]
  "Get all view models from a node pool."
  [pool :- NodePool]
  (map #(view-model pool %) (node-ids pool)))

(s/defn view-model-from-url :- NodeView
  [pool :- NodePool
   url  :- s/Str]
  (first (filter #(= (% :url) url) (view-models pool))))

(s/defn ^:always-validate view-model-exists? :- s/Bool
  [pool :- NodePool
   id   :- s/Str]
  (redis/model-exists? (:redis-conn pool) redis/NodeInRedis id))

(s/defn modify-node :- NodeView
  "Modify a node's url or tags in Redis."
  [pool :- NodePool
   id   :- s/Str
   {:keys [url tags max-sessions]
    :or {url nil
         tags nil
         max-sessions nil}
    :as node}]
  (last
    (car/wcar (:redis-conn pool)
      (let [node-key (redis/model-key redis/NodeInRedis id)
            node-tags-key (redis/node-tags-key id)]
        (redis/hset-all node-key
                        (merge {}
                               (if url {:url (str url)})
                               (if max-sessions {:max-sessions max-sessions})))
        (when tags (redis/sset-all node-tags-key tags))
        (car/return (view-model pool id))))))

(s/defn ^:always-validate create-node :- NodeView
  "Create a node in a given pool."
  [pool :- NodePool
   {:keys [url tags max-sessions]
    :or {tags #{}
         max-sessions (:default-session-limit pool)}}]
  (last
    (car/wcar (:redis-conn pool)
      (let [id (gen-uuid)
            node-key (redis/model-key redis/NodeInRedis id)]
        (car/sadd (redis/model-ids-key redis/NodeInRedis) id)
        (car/return (modify-node pool id {:url url
                                          :tags tags
                                          :max-sessions max-sessions}))))))

(s/defn ^:always-validate destroy-node
  [pool :- NodePool
   id   :- s/Str]
  (car/wcar (:redis-conn pool)
    (car/watch (redis/model-ids-key redis/NodeInRedis))
    (try
      (let [url (:url (view-model pool id))]
        (if (some #{url} (node-providers/get-nodes (:node-provider pool)))
          (node-providers/remove-node (:node-provider pool) url)))
      (finally
        (doseq [session (raw-sessions-with-node pool id)]
          (redis/delete-model! (:redis-conn pool) redis/SessionInRedis (:id session)))
        (redis/delete-model! (:redis-conn pool) redis/NodeInRedis id)
        (car/del (redis/node-tags-key id)))))
  true)

(defn ^:private to-set [s]
  (into #{} s))

(def ^:private refresh-nodes-lock {})

(s/defn refresh-nodes
  "Syncs the node list with the backing node provider."
  [pool :- NodePool]
  (locking refresh-nodes-lock
    (logging/debug "Refreshing nodes...")
    (let [nodes (->> (:node-provider pool)
                     node-providers/get-nodes
                     to-set)
          registered-nodes (->> (view-models pool)
                                (map :url)
                                to-set)]
      (logging/debug "Live nodes:")
      (logging/debug nodes)
      (logging/debug "Nodes in Redis:")
      (logging/debug registered-nodes)
      (doall
        (concat
          (map #(create-node pool {:url %})
               (filter identity
                       (difference nodes registered-nodes)))
          (map #(destroy-node pool (:id (view-model-from-url pool %)))
               (filter identity
                       (difference registered-nodes nodes))))))
    true))

(s/defschema NodeRequirement
  "A schema for a node requirement."
  (any-pair
    :id  s/Str
    :tag s/Str
    :url s/Str
    :not (s/recursive #'NodeRequirement)
    :and [(s/recursive #'NodeRequirement)]
    :or  [(s/recursive #'NodeRequirement)]))

(s/defn ^:always-validate raw-sessions-with-node [pool    :- NodePool
                                                  node-id :- s/Str]
  (let [redis-conn (:redis-conn pool)]
    (->> (redis/models redis-conn
                       redis/SessionInRedis
                       :include-soft-deleted? true)
         (filter #(= node-id (:node-id %))))))

(s/defn ^:always-validate raw-session-count [pool    :- NodePool
                                             node-id :- s/Str]
  (count (raw-sessions-with-node pool node-id)))

(s/defn ^:always-validate nodes-under-capacity
  "Nodes with available capacity."
  [pool :- NodePool]
  (let [session-limit (:default-session-limit pool)]
    (filter #(< (raw-session-count pool (:id %)) session-limit)
            (view-models pool))))

(s/defn ^:always-validate matches-requirement :- s/Bool
  [model       :- NodeView
   requirement :- (s/maybe NodeRequirement)]
  (logging/debug
    (format "Testing node %s against requirement %s."
            model
            requirement))
  (if requirement
    (let [[req-type arg] requirement
          n model]
      (-> (match req-type
                 :tag (some #{arg} (:tags n))
                 :id  (= arg (:id n))
                 :url (= arg (:url n))
                 :not (not     (matches-requirement n arg))
                 :and (every? #(matches-requirement n %) arg)
                 :or  (some   #(matches-requirement n %) arg))
          boolean))
    true))

(s/defn ^:always-validate get-node :- (s/maybe NodeView)
  [pool        :- NodePool
   requirement :- (s/maybe NodeRequirement)]
  (try
    (rand-nth
      (filter #(matches-requirement % requirement)
              (nodes-under-capacity pool)))
    (catch IndexOutOfBoundsException e)))

Delete associated sessions when deleting the node


(ns ombs.validate
  (:require
    [noir.validation :as vld]
    [ombs.db.old :as db]
    [ombs.db.payment :as dbp]
    [noir.session :as sess]
    [noir.response :refer [redirect]]
    ))

(def errors
  {
   :event {
           :empty-name      "Event name should not be empty"
           :zero-price      "Event price should be greater than 0"
           :empty-date      "Event should have date"
           :duplicate-event "Event with same name today was created. Use another name"
           :no-participants "Participants should be checked"
           :unexist         "Event %s does not exist"
           :finished        "Event is history"
           :parts-count     "Event have less parts that given"
           }
   :register {
              :short-pass      "Password should be longer than 7 chars"
              :notmatch-pass   "Password doesn't match"
              }
   :user {
          :empty-name "Username can't be empty"
          :not-found "User not found"
          :unexist "Username %s doesn't exists"
          :low-balance "User %s doesn't have enough money"
          }
   :login {
           :invalid "Incorrect Login or password"
           }
   :fee {
         :unexist "Unexists fee"
         }
   :pay {
         :wrong-parts "Parts count %s is greater that we have."
         :wrong-money "Money should be > 0"
         }

   }
  )

(defn- message
  "Giving message text form mesage-map, using tags. If spend some `data` to
  this, format string if possible. Can spend only 0-1 data-string."
  ([tags] (message tags ""))
  ([ tags & data ]
   (apply format (get-in errors tags "Internal: Wrong message link") data)) )

(defn errors-string
  ([] (reduce str (map #(str "|" % "|") (vld/get-errors))))
  ([tags] (reduce str (map #(str "|" % "|") (vld/get-errors tags)))))

(defn errors? [] (vld/errors?))

(defmacro create-rule [tag data]
  `(vld/rule ~@(list (first data)) [~tag ~(last data)] )
  )

(defmacro create-validator
  "Create validation block, start with clearing errors, followed by create-rule
  calls for each ve-pairs.  ve-pairs is validator-error-pairs(vector) where
  first is function(rule that returns boolean), and second is error message,
  that was appends in vld errors vector, when rule fails."
  [tag ve-pairs]
  `(do
     ;(vld/clear-errors!)
     ~@(map #(list 'create-rule tag %) ve-pairs)
     (not (vld/errors? ~tag)))
  )

(defn add-error [tag text] (vld/set-error! tag text))

(defn new-event? [eventname price date]
  (create-validator :event
                    [
                     [ (vld/has-value? eventname)              (message [:event :empty-name])      ]
                     [ (vld/greater-than? price 0)             (message [:event :zero-price])      ]
                     [ (vld/has-value? date)                   (message [:event :empty-date])      ]
                     [ (empty? (db/get-event eventname date))  (message [:event :duplicate-event]) ]
                     ]))

(defn new-user? [username pass1 pass2]
  (create-validator :register
                    [
                     [(vld/has-value? username) (message [:user :empty-name])]
                     [(>= (count pass1) 8) (message [:register :short-pass])]
                     [(= pass1 pass2) (message [:register :notmatch-pass])]
                     [(empty? (db/get-user username)) (message [:user :unexist]) ]
                     ]))

(defn login? [username password]
  (create-validator :login
                    [[ (vld/has-value? username) (message [:user :empty-name])]
                     [ (vld/has-value? (db/get-user username)) (message [:user :invalid])]
                     [ (= password (:password (db/get-user username))) (message [:login :invalid])]
                     ])
  )

(defn participation? [eid]
  (create-validator :participation
                    [
                     [(not= (db/get-status eid) (db/statuses :finished))
                      (message [:event :finished])]
                     [(not= "" (:name (db/get-event eid)))
                      (message [:event :unexist])]
                     ]))

(defn payment? [eid uid parts]
  "Check, if id's is correct. Used with (db/get-*id)"
  (create-validator :pay
                    [
                     [(not= nil uid)
                      (message [:user :empty-name])]
                     [(not= nil eid)
                      (message [:event :unexist])]
                     [(<= parts (+ (dbp/free-parts eid) parts))
                      (message [:pay :wrong-parts])]
                     ]))
(defn fee? [id]
 (create-validator :pay
                   [
                    [(not= nil id)
                     (message [:fee :unexist])]
                    [(not (nil? (db/event-from-fee id)))
                     (message [:event :unexist])]
                    [(vld/has-value? (sess/get :username))
                     (message [:user :unexist])]
                    ]))

(defn parts? [ename date parts]
  (create-validator :pay
                    [ ; FIXME: free-parts include parts from currect fee
                     [(<= parts (+ (dbp/free-parts ename date) parts))
                      (message [:event :parts-count])]
                     ]))

(defn moneyout? [username money]
  (create-validator :admin
                    [
                     [(nil? (db/get-user username)) (message [:user :unexist])]
                     [(< 0 money) (message [:pay :wrong-money])]
                     [(<= money (:balance (db/get-user username))) (message [:user :low-balance] username)]
                     ]
                    )
  )

(ns ombs.validate
  (:require
    [noir.validation :as vld]
    [ombs.db.old :as db]
    [ombs.db.payment :as dbp]
    [noir.session :as sess]
    [noir.response :refer [redirect]]
    ))

(def errors
  {
   :event {
           :empty-name      "Event name should not be empty"
           :zero-price      "Event price should be greater than 0"
           :empty-date      "Event should have date"
           :duplicate-event "Event with same name today was created. Use another name"
           :no-participants "Participants should be checked"
           :unexist         "Event %s does not exist"
           :finished        "Event is history"
           :parts-count     "Event have less parts that given"
           }
   :register {
              :short-pass      "Password should be longer than 7 chars"
              :notmatch-pass   "Password doesn't match"
              }
   :user {
          :empty-name "Username can't be empty"
          :not-found "User not found"
          :unexist "Username %s doesn't exists"
          :low-balance "User %s doesn't have enough money"
          }
   :login {
           :invalid "Incorrect Login or password"
           }
   :fee {
         :unexist "Unexists fee"
         }
   :pay {
         :wrong-parts "Parts count %s is greater that we have."
         :wrong-money "Money should be > 0"
         }

   }
  )

(defn- message
  "Giving message text form mesage-map, using tags. If spend some `data` to
  this, format string if possible. Can spend only 0-1 data-string."
  ([tags] (message tags ""))
  ([ tags & data ]
   (apply format (get-in errors tags "Internal: Wrong message link") data)) )

(defn errors-string
  ([] (reduce str (map #(str "|" % "|") (vld/get-errors))))
  ([tags] (reduce str (map #(str "|" % "|") (vld/get-errors tags)))))

(defn errors? [] (vld/errors?))

(defmacro create-rule [tag [validator msg]]
  `(vld/rule ~@(list validator) [~tag ~msg] )
  )

(defmacro create-validator
  "Create validation block, start with clearing errors, followed by create-rule
  calls for each ve-pairs.  ve-pairs is validator-error-pairs(vector) where
  first is function(rule that returns boolean), and second is error message,
  that was appends in vld errors vector, when rule fails."
  [tag ve-pairs]
  `(do
     ;(vld/clear-errors!)
     ~@(map #(list 'create-rule tag %) ve-pairs)
     (not (vld/errors? ~tag)))
  )

(defn add-error [tag text] (vld/set-error! tag text))

(defn new-event? [eventname price date]
  (create-validator :event
                    [
                     [ (vld/has-value? eventname)              (message [:event :empty-name])      ]
                     [ (vld/greater-than? price 0)             (message [:event :zero-price])      ]
                     [ (vld/has-value? date)                   (message [:event :empty-date])      ]
                     [ (empty? (db/get-event eventname date))  (message [:event :duplicate-event]) ]
                     ]))

(defn new-user? [username pass1 pass2]
  (create-validator :register
                    [
                     [(vld/has-value? username) (message [:user :empty-name])]
                     [(>= (count pass1) 8) (message [:register :short-pass])]
                     [(= pass1 pass2) (message [:register :notmatch-pass])]
                     [(empty? (db/get-user username)) (message [:user :unexist]) ]
                     ]))

(defn login? [username password]
  (create-validator :login
                    [[ (vld/has-value? username) (message [:user :empty-name])]
                     [ (vld/has-value? (db/get-user username)) (message [:user :invalid])]
                     [ (= password (:password (db/get-user username))) (message [:login :invalid])]
                     ])
  )

(defn participation? [eid]
  (create-validator :participation
                    [
                     [(not= (db/get-status eid) (db/statuses :finished))
                      (message [:event :finished])]
                     [(not= "" (:name (db/get-event eid)))
                      (message [:event :unexist])]
                     ]))

(defn payment? [eid uid parts]
  "Check, if id's is correct. Used with (db/get-*id)"
  (create-validator :pay
                    [
                     [(not= nil uid)
                      (message [:user :empty-name])]
                     [(not= nil eid)
                      (message [:event :unexist])]
                     [(<= parts (+ (dbp/free-parts eid) parts))
                      (message [:pay :wrong-parts])]
                     ]))
(defn fee? [id]
 (create-validator :pay
                   [
                    [(not= nil id)
                     (message [:fee :unexist])]
                    [(not (nil? (db/event-from-fee id)))
                     (message [:event :unexist])]
                    [(vld/has-value? (sess/get :username))
                     (message [:user :unexist])]
                    ]))

(defn parts? [ename date parts]
  (create-validator :pay
                    [ ; FIXME: free-parts include parts from currect fee
                     [(<= parts (+ (dbp/free-parts ename date) parts))
                      (message [:event :parts-count])]
                     ]))

(defn moneyout? [username money]
  (create-validator :admin
                    [
                     [(nil? (db/get-user username)) (message [:user :unexist])]
                     [(< 0 money) (message [:pay :wrong-money])]
                     [(<= money (:balance (db/get-user username))) (message [:user :low-balance] username)]
                     ]
                    )
  )

Simplify validation rule creation.

[ref] Simplify validation rule creation.


(ns vip.data-processor.validation.v5.hours-open
  (:require [vip.data-processor.validation.v5.util :as util]))

(defn valid-time-with-zone? [time]
  (re-matches
   #"(?:(?:[01][0-9]|2[0-3]):[0-5][0-9]:[0-5][0-9]|(?:24:00:00))(?:Z|[+-](?:(?:0[0-9]|1[0-3]):[0-5][0-9]|14:00))"
   time))

(defn validate-times [{:keys [import-id] :as ctx}]
  (let [hours-open-path "VipObject.0.HoursOpen.*{1}.Schedule.*{1}.Hours.*{1}"
        times (util/select-lquery
               import-id
               (str hours-open-path ".StartTime|EndTime.*{1}"))
        invalid-times (remove (comp valid-time-with-zone? :value) times)]
    (reduce (fn [ctx row]
              (update-in ctx
                         [:errors :hours-open (-> row :path .getValue) :format]
                         conj (:value row)))
            ctx invalid-times)))

(ns vip.data-processor.validation.v5.hours-open
  (:require [vip.data-processor.validation.v5.util :as util]))

(defn valid-time-with-zone? [time]
  (re-matches
   #"\A(?:(?:[01][0-9]|2[0-3]):[0-5][0-9]:[0-5][0-9]|(?:24:00:00))(?:Z|[+-](?:(?:0[0-9]|1[0-3]):[0-5][0-9]|14:00))\z"
   time))

(defn validate-times [{:keys [import-id] :as ctx}]
  (let [hours-open-path "VipObject.0.HoursOpen.*{1}.Schedule.*{1}.Hours.*{1}"
        times (util/select-lquery
               import-id
               (str hours-open-path ".StartTime|EndTime.*{1}"))
        invalid-times (remove (comp valid-time-with-zone? :value) times)]
    (reduce (fn [ctx row]
              (update-in ctx
                         [:errors :hours-open (-> row :path .getValue) :format]
                         conj (:value row)))
            ctx invalid-times)))

Add regex anchors to time format regex

Add regex anchors to time format regex

So we will only match full strings, not substrings.


(ns cljs.quil.core
  (:require [cljs.quil.applet :as applet]
            [clojure.browser.dom  :as dom])
  (:use-macros [cljs.quil.helpers.tools :only [defapplet]])
  (:use [cljs.quil.applet :only [current-graphics]]))

(defn int-like? [val] (integer? val))

(defn get-sketch-by-id [id]
  id)

(defn width []
  (.-width (current-graphics)))

(defn height []
  (.-height (current-graphics)))

(defn size [width height]
  (.size (current-graphics) (int width) (int height)))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background-float
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts args to floats."
  ([gray] (.background (current-graphics) (float gray)))
  ([gray alpha] (.background (current-graphics) (float gray) (float alpha)))
  ([r g b] (.background (current-graphics) (float r) (float g) (float b)))
  ([r g b a] (.background (current-graphics) (float r) (float g) (float b) (float a))))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background-int
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts rgb to an int and alpha to a float."
  ([rgb] (.background (current-graphics) (int rgb)))
  ([rgb alpha] (.background (current-graphics) (int rgb) (float alpha))))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts args to floats."
  ([rgb] (if (int-like? rgb) (background-int rgb) (background-float rgb)))
  ([rgb alpha] (if (int-like? rgb) (background-int rgb alpha) (background-float rgb alpha)))
  ([r g b] (background-float r g b))
  ([r g b a] (background-float r g b a)))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke-float
  "Sets the color used to draw lines and borders around
  shapes. Converts all args to floats"
  ([gray] (.stroke (current-graphics) (float gray)))
  ([gray alpha] (.stroke (current-graphics) (float gray) (float alpha)))
  ([x y z] (.stroke (current-graphics) (float x) (float y) (float z)))
  ([x y z a] (.stroke (current-graphics) (float x) (float y) (float z) (float a))))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke-int
  "Sets the color used to draw lines and borders around
  shapes. Converts rgb to int and alpha to a float."
  ([rgb] (.stroke (current-graphics) (int rgb)))
  ([rgb alpha] (.stroke (current-graphics) (int rgb) (float alpha))))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke
  "Sets the color used to draw lines and borders around shapes. This
  color is either specified in terms of the RGB or HSB color depending
  on the current color-mode (the default color space is RGB, with
  each value in the range from 0 to 255)."
  ([rgb] (if (int-like? rgb) (stroke-int rgb) (stroke-float rgb)))
  ([rgb alpha] (if (int-like? rgb) (stroke-int rgb alpha) (stroke-float rgb alpha)))
  ([x y z] (stroke-float x y z))
  ([x y z a] (stroke-float x y z a)))

(defn
  ^{:requires-bindings true
    :processing-name "curve()"
    :category "Shape"
    :subcategory "Curves"
    :added "1.0"}
  curve
  "Draws a curved line on the screen. The first and second parameters
  specify the beginning control point and the last two parameters
  specify the ending control point. The middle parameters specify the
  start and stop of the curve. Longer curves can be created by putting
  a series of curve fns together or using curve-vertex. An additional
  fn called curve-tightness provides control for the visual quality of
  the curve. The curve fn is an implementation of Catmull-Rom
  splines."
  ([x1 y1 x2 y2 x3 y3 x4 y4]
     (.curve (current-graphics)
             (float x1) (float y1)
             (float x2) (float y2)
             (float x3) (float y3)
             (float x4) (float y4)))
  ([x1 y1 z1 x2 y2 z2 x3 y3 z3 x4 y4 z4]
     (.curve (current-graphics)
             (float x1) (float y1) (float z1)
             (float x2) (float y2) (float z2)
             (float x3) (float y3) (float z3)
             (float x4) (float y4) (float z4))))

(defn
  ^{:requires-bindings true
    :processing-name "line()"
    :category "Shape"
    :subcategory "2D Primitives"
    :added "1.0"}
  line
  "Draws a line (a direct path between two points) to the screen. The
  version of line with four parameters draws the line in 2D. To color
  a line, use the stroke function. A line cannot be filled, therefore
  the fill method will not affect the color of a line. 2D lines are
  drawn with a width of one pixel by default, but this can be changed
  with the stroke-weight function. The version with six parameters
  allows the line to be placed anywhere within XYZ space. "
  ([p1 p2] (apply line (concat p1 p2)))
  ([x1 y1 x2 y2] (.line (current-graphics) (float x1) (float y1) (float x2) (float y2)))
  ([x1 y1 z1 x2 y2 z2]
     (.line (current-graphics) (float x1) (float y1) (float z1)
            (float x2) (float y2) (float z2))))

(ns cljs.quil.core
  (:require [cljs.quil.applet :as applet]
            [clojure.browser.dom  :as dom])
  (:use-macros [cljs.quil.helpers.tools :only [defapplet]])
  (:use [cljs.quil.applet :only [current-graphics]]))

(defn int-like? [val] (integer? val))

(defn get-sketch-by-id [id]
  (.getInstanceById js/Processing id))

(defn width []
  (.-width (current-graphics)))

(defn height []
  (.-height (current-graphics)))

(defn size [width height]
  (.size (current-graphics) (int width) (int height)))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background-float
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts args to floats."
  ([gray] (.background (current-graphics) (float gray)))
  ([gray alpha] (.background (current-graphics) (float gray) (float alpha)))
  ([r g b] (.background (current-graphics) (float r) (float g) (float b)))
  ([r g b a] (.background (current-graphics) (float r) (float g) (float b) (float a))))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background-int
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts rgb to an int and alpha to a float."
  ([rgb] (.background (current-graphics) (int rgb)))
  ([rgb alpha] (.background (current-graphics) (int rgb) (float alpha))))

(defn
  ^{:requires-bindings true
    :processing-name "background()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  background
  "Sets the color used for the background of the Processing
  window. The default background is light gray. In the draw function,
  the background color is used to clear the display window at the
  beginning of each frame.

  It is not possible to use transparency (alpha) in background colors
  with the main drawing surface, however they will work properly with
  create-graphics. Converts args to floats."
  ([rgb] (if (int-like? rgb) (background-int rgb) (background-float rgb)))
  ([rgb alpha] (if (int-like? rgb) (background-int rgb alpha) (background-float rgb alpha)))
  ([r g b] (background-float r g b))
  ([r g b a] (background-float r g b a)))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke-float
  "Sets the color used to draw lines and borders around
  shapes. Converts all args to floats"
  ([gray] (.stroke (current-graphics) (float gray)))
  ([gray alpha] (.stroke (current-graphics) (float gray) (float alpha)))
  ([x y z] (.stroke (current-graphics) (float x) (float y) (float z)))
  ([x y z a] (.stroke (current-graphics) (float x) (float y) (float z) (float a))))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke-int
  "Sets the color used to draw lines and borders around
  shapes. Converts rgb to int and alpha to a float."
  ([rgb] (.stroke (current-graphics) (int rgb)))
  ([rgb alpha] (.stroke (current-graphics) (int rgb) (float alpha))))

(defn
  ^{:requires-bindings true
    :processing-name "stroke()"
    :category "Color"
    :subcategory "Setting"
    :added "1.0"}
  stroke
  "Sets the color used to draw lines and borders around shapes. This
  color is either specified in terms of the RGB or HSB color depending
  on the current color-mode (the default color space is RGB, with
  each value in the range from 0 to 255)."
  ([rgb] (if (int-like? rgb) (stroke-int rgb) (stroke-float rgb)))
  ([rgb alpha] (if (int-like? rgb) (stroke-int rgb alpha) (stroke-float rgb alpha)))
  ([x y z] (stroke-float x y z))
  ([x y z a] (stroke-float x y z a)))

(defn
  ^{:requires-bindings true
    :processing-name "curve()"
    :category "Shape"
    :subcategory "Curves"
    :added "1.0"}
  curve
  "Draws a curved line on the screen. The first and second parameters
  specify the beginning control point and the last two parameters
  specify the ending control point. The middle parameters specify the
  start and stop of the curve. Longer curves can be created by putting
  a series of curve fns together or using curve-vertex. An additional
  fn called curve-tightness provides control for the visual quality of
  the curve. The curve fn is an implementation of Catmull-Rom
  splines."
  ([x1 y1 x2 y2 x3 y3 x4 y4]
     (.curve (current-graphics)
             (float x1) (float y1)
             (float x2) (float y2)
             (float x3) (float y3)
             (float x4) (float y4)))
  ([x1 y1 z1 x2 y2 z2 x3 y3 z3 x4 y4 z4]
     (.curve (current-graphics)
             (float x1) (float y1) (float z1)
             (float x2) (float y2) (float z2)
             (float x3) (float y3) (float z3)
             (float x4) (float y4) (float z4))))

(defn
  ^{:requires-bindings true
    :processing-name "line()"
    :category "Shape"
    :subcategory "2D Primitives"
    :added "1.0"}
  line
  "Draws a line (a direct path between two points) to the screen. The
  version of line with four parameters draws the line in 2D. To color
  a line, use the stroke function. A line cannot be filled, therefore
  the fill method will not affect the color of a line. 2D lines are
  drawn with a width of one pixel by default, but this can be changed
  with the stroke-weight function. The version with six parameters
  allows the line to be placed anywhere within XYZ space. "
  ([p1 p2] (apply line (concat p1 p2)))
  ([x1 y1 x2 y2] (.line (current-graphics) (float x1) (float y1) (float x2) (float y2)))
  ([x1 y1 z1 x2 y2 z2]
     (.line (current-graphics) (float x1) (float y1) (float z1)
            (float x2) (float y2) (float z2))))

Add function for searching sketch from JS by id.