(ns puppeteer.infra.repository.deploy
  (:require [clojure.java.io :as io]
            [clj-yaml.core :as yaml]
            [com.stuartsierra.component :as component]
            [puppeteer.infra.client.github :as github]))

(defn get-ingress
  [{:keys [k8s-client ingress-name] :as comp}]
  (-> k8s-client
      :client
      .extensions
      .ingresses
      (.withName ingress-name)
      .list
      .getItems
      first))

(defn apply-ingress
  [{:keys [k8s-client ingress-name] :as comp}
   resource]
  (-> k8s-client
      :client
      (.resource resource)
      .apply))

(defn get-resource
  [{:keys [github-client] :as comp}
   {:keys [user repo ref path]}]
  (some-> (github/get-file
            github-client
            {:user user
             :repo repo
             :ref ref
             :path path})
          slurp
          (yaml/parse-string :keywords true)))

(defn apply-resource
  [{:keys [k8s-client] :as comp}
   {:keys [k8s]}]
  (-> k8s-client
      :client
      (.load (-> k8s
                 yaml/generate-string
                 .getBytes
                 io/input-stream))
      .apply))

(defn delete-resource
  [{:keys [k8s-client] :as comp}
   {:keys [resource]}]
  (-> k8s-client
      :client
      (.load (-> resource
                 yaml/generate-string
                 .getBytes
                 io/input-stream))
      .delete))

(defn delete-service
  [{:keys [k8s-client] :as comp}
   {:keys [app]}]
  (-> k8s-client
      :client
      .services
      (.withName "eure-atnd")))

(defrecord DeployRepositoryComponent [k8s-client github-client domain ingress-name]
  component/Lifecycle
  (start [this]
    (println ";; Starting BuildRepositoryComponent")
    this)
  (stop [this]
    (println ";; Stopping BuildRepositoryComponent")
    this))

(defn deploy-repository-component
  [domain ingress-name]
  (map->DeployRepositoryComponent {:domain domain
                                   :ingress-name ingress-name}))

(ns puppeteer.infra.repository.deploy
  (:require [clojure.java.io :as io]
            [clj-yaml.core :as yaml]
            [com.stuartsierra.component :as component]
            [puppeteer.infra.client.github :as github]))

(defn get-ingress
  [{:keys [k8s-client ingress-name] :as comp}]
  (-> k8s-client
      :client
      .extensions
      .ingresses
      (.withName ingress-name)
      .list
      .getItems
      first))

(defn apply-ingress
  [{:keys [k8s-client ingress-name] :as comp}
   resource]
  (-> k8s-client
      :client
      (.resource resource)
      .apply))

(defn get-resource
  [{:keys [github-client] :as comp}
   {:keys [user repo ref path]}]
  (some-> (github/get-file
            github-client
            {:user user
             :repo repo
             :ref ref
             :path path})
          slurp
          (yaml/parse-string :keywords true)))

(defn apply-resource
  [{:keys [k8s-client] :as comp}
   {:keys [k8s]}]
  (-> k8s-client
      :client
      (.load (-> k8s
                 yaml/generate-string
                 .getBytes
                 io/input-stream))
      .createOrReplace))

(defn delete-resource
  [{:keys [k8s-client] :as comp}
   {:keys [resource]}]
  (-> k8s-client
      :client
      (.load (-> resource
                 yaml/generate-string
                 .getBytes
                 io/input-stream))
      .delete))

(defn delete-service
  [{:keys [k8s-client] :as comp}
   {:keys [app]}]
  (-> k8s-client
      :client
      .services
      (.withName "eure-atnd")))

(defrecord DeployRepositoryComponent [k8s-client github-client domain ingress-name]
  component/Lifecycle
  (start [this]
    (println ";; Starting BuildRepositoryComponent")
    this)
  (stop [this]
    (println ";; Stopping BuildRepositoryComponent")
    this))

(defn deploy-repository-component
  [domain ingress-name]
  (map->DeployRepositoryComponent {:domain domain
                                   :ingress-name ingress-name}))

apply -> createOrReplace

apply -> createOrReplace


(ns beicon.core-spec
  (:require [cljs.test :as t]
            [cats.core :as m]
            [promesa.core :as prom]
            [beicon.core :as s]))

;; --- helpers for testing

(def no-op (fn [& args]))

(defmacro with-timeout
  [ms & body]
  `(js/setTimeout
    (fn []
      (do
        ~@body))
    ~ms))

(defn drain!
  ([obs cb]
   (drain! obs cb #(println "Error: " %)))
  ([obs cb errb]
   (let [values (volatile! [])]
     (s/subscribe obs
                  #(vswap! values conj %)
                  #(errb %)
                  #(cb @values)))))

(defn tick
  [interval]
  (s/from-poll interval #(.getTime (js/Date.))))

;; event stream

(t/deftest observable-from-vector
  (t/async done
    (let [coll [1 2 3]
          s (s/from-coll coll)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

(t/deftest observable-from-vector-with-take
  (t/async done
    (let [coll [1 2 3 4 5 6]
          s (->> (s/from-coll coll)
                 (s/take 2))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 2])))
      (s/on-end s done))))

(t/deftest observable-from-atom
  (t/async done
    (let [a (atom 0)
          s (->> (s/from-atom a)
                 (s/take 4))]
      (t/is (s/observable? s))
      (drain! s #(do
                   (t/is (= % [1 2 3 4]))
                   (done)))
      (swap! a inc)
      (swap! a inc)
      (swap! a inc)
      (swap! a inc))))

(t/deftest observable-from-set
  (t/async done
    (let [coll #{1 2 3}
          s (s/from-coll coll)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= (set %) coll)))
      (s/on-end s done))))

(t/deftest observable-from-callback
  (t/async done
    (let [s (s/from-callback (fn [sink]
                               (with-timeout 10
                                 (sink 1)
                                 nil)))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1])))
      (s/on-end s done))))

(t/deftest observable-from-create
  (t/async done
    (let [s (s/create (fn [sink]
                        (with-timeout 10
                          (sink 1)
                          (sink 2)
                          (sink 3)
                          (sink nil))))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 2 3])))
      (s/on-end s done))))

(t/deftest observable-from-timeout
  (t/async done
    (let [s (s/timeout 1000 :timeout)]
      (t/is (s/observable? s))
      (drain! s #(do
                   (t/is (= % [:timeout]))
                   (done))))))

(t/deftest observable-from-timeout-and-choice
  (t/async done
    (let [s (s/choice
             (s/timeout 1000 :timeout)
             (s/timeout 900 :value))]
      (t/is (s/observable? s))
      (drain! s #(do
                   (t/is (= % [:value]))
                   (done))))))

(t/deftest observable-errors-from-binder
  (t/async done
    (let [s (s/create (fn [sink]
                        (with-timeout 10
                          (sink 1)
                          (sink (ex-info "oh noes" {})))))]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % [1]))
              #(t/is (= (ex-message %) "oh noes")))
      (s/on-error s done))))

(t/deftest observable-from-promise
  (t/async done
    (let [p (prom/resolved 42)
          s (s/from-promise p)]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % [42])))
      (s/on-end s done))))

(t/deftest observable-from-rejected-promise
  (t/async done
    (let [p (prom/rejected (ex-info "oh noes" {}))
          s (s/from-promise p)]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % []))
              #(t/is (= (ex-message %) "oh noes")))
      (s/on-error s done))))

(t/deftest observable-repeat
  (t/async done
    (let [s (s/repeat 1 2)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 1])))
      (s/on-end s done))))

(t/deftest observable-once
  (t/async done
    (let [s (s/once 1)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1])))
      (s/on-end s done))))

;; (t/deftest observable-never
;;   (t/async done
;;     (let [n (s/never)]
;;       (s/on-end n done))))

;; (t/deftest observable-on-value
;;   (t/async done
;;     (let [s (s/from-coll [1 2 3])
;;           vacc (volatile! [])]
;;       (s/on-value s #(vswap! vacc conj %))
;;       (s/on-end s #(do (t/is (= @vacc [1 2 3]))
;;                        (done))))))

(t/deftest observable-concat
  (t/async done
    (let [s1 (s/bus)
          s2 (s/bus)
          cs (s/concat s1 s2)]
      (drain! cs #(t/is (= % [1 2 3 4])))
      (s/on-end cs done)
      (s/push! s1 1)
      (s/push! s1 2)
      (s/push! s2 :discarded)
      (s/push! s2 :discarded)
      (s/end! s1)
      (s/push! s2 3)
      (s/push! s2 4)
      (s/end! s2))))

(t/deftest observable-merge
  (t/async done
    (let [s1 (s/from-coll [1 2 3])
          s2 (s/from-coll [:1 :2 :3])
          ms (s/merge s1 s2)]
      (drain! ms #(t/is (= % [1 :1 2 :2 3 :3])))
      (s/on-end ms done))))

(t/deftest observable-skip-while
  (t/async done
    (let [nums (s/from-coll [1 1 1 2 3 4 5])
          sample (s/skip-while odd? nums)]
      (drain! sample #(t/is (= % [2 3 4 5])))
      (s/on-end sample done))))

(t/deftest observable-skip-until
  (t/async done
    (let [s (s/bus)
          sv (s/bus)
          sample (s/skip-until sv s)]
      (drain! sample #(t/is (= % [3 4 5])))
      (s/on-end sample done)
      ;; push values onto stream
      (s/push! s 1)
      (s/push! s 2)
      ;; open switch
      (s/push! sv :value)
      ;; push some more
      (s/push! s 3)
      (s/push! s 4)
      (s/push! s 5)
      ;; end
      (s/end! s)
      (s/end! sv))))

(t/deftest bus-push
  (t/async done
    (let [b (s/bus)]
      (t/is (s/bus? b))
      (drain! b #(t/is (= % [1 2 3])))
      (s/push! b 1)
      (s/push! b 2)
      (s/push! b 3)
      (s/end! b)
      (s/on-end b done))))

(t/deftest observable-filter-with-predicate
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5])
          fs (s/filter #{3 5} s)]
      (drain! fs #(t/is (= % [3 5])))
      (s/on-end fs done))))

(t/deftest observable-map-with-ifn
  (t/async done
    (let [s (s/from-coll [{:foo 1} {:foo 2}])
          fs (s/map :foo s)]
      (drain! fs #(do
                    (t/is (= % [1 2]))
                    (done))))))

(t/deftest observable-slice
  (t/async done
    (let [s (s/from-coll [1 2 3 4])
          fs (s/slice 1 3 s)]
      (drain! fs #(do
                    (t/is (= % [2 3]))
                    (done))))))

(t/deftest observable-retry
  (t/async done
    (let [errored? (volatile! false)
          s (s/create (fn [sink]
                        (if @errored?
                          (do
                            (sink 2)
                            (sink 3)
                            (sink nil))
                           (do
                             (vreset! errored? true)
                                   (sink (js/Error.))))))
                 rs (s/retry 2 s)]
      (t/is (s/observable? rs))
      (drain! rs #(t/is (= % [2 3])))
      (s/on-end rs done))))

(t/deftest observable-with-latest-from
  (t/async done
    (let [s1 (s/from-coll [0])
          s2 (s/from-coll [1 2 3])
          s3 (s/with-latest-from s1 s2)]
      (t/is (s/observable? s3))
      (drain! s3 #(t/is (= % [[1 0] [2 0] [3 0]])))
      (s/on-end s3 done))))

(t/deftest observable-catch
  (t/async done
    (let [s1 (s/from-exception (ex-info "error" {:foo :bar}))
          s2 (s/catch (fn [error]
                        (s/once (ex-data error)))
                 s1)]
      (t/is (s/observable? s2))
      (drain! s2 #(t/is (= % [{:foo :bar}])))
      (s/on-end s2 done))))

(t/deftest observable-as-functor
 (t/async done
   (let [s (s/from-coll [0 1 2])
         s2 (m/fmap inc s)]
     (t/is (s/observable? s))
     (t/is (s/observable? s2))
     (drain! s2 #(do (t/is (= % [1 2 3]))
                      (done))))))

(t/deftest observable-as-applicative
 (t/async done
   (let [pinc (m/pure s/observable-context inc)
         pval (m/pure s/observable-context 41)
         life (m/fapply pinc pval)]
     (t/is (s/observable? life))
     (drain! life #(do (t/is (= % [42]))
                       (done))))))

(t/deftest observable-as-monad
  (t/async done
    (let [sn (s/from-coll [1 2 3])
          snks (m/mlet [n sn
                        k (s/from-coll (map (comp keyword str) (range 1 (inc n))))]
                 (m/return [n k]))
          sample (s/take 6 snks)]
      (t/is (s/observable? snks))
      (drain! sample #(t/is (= % [[1 :1]
                                  [2 :1]
                                  [2 :2]
                                  [3 :1]
                                  [3 :2]
                                  [3 :3]])))
      (s/on-end sample done))))

(t/deftest observable-to-atom
  (t/async done
    (let [st (s/from-coll [1 2 3])
          a (s/to-atom st)]
      (s/on-end st #(do (t/is (= @a 3))
                        (done))))))

(t/deftest observable-to-atom-with-atom
  (t/async done
    (let [st (s/from-coll [1 2 3])
          vacc (volatile! [])
          a (atom 0)]
      (add-watch a
                 :acc
                 (fn [_ _ _ v]
                   (vswap! vacc conj v)))
      (s/to-atom st a)
      (s/on-end st #(do (t/is (= @a 3))
                        (t/is (= @vacc [1 2 3]))
                        (done))))))

(t/deftest observable-to-atom-with-atom-and-function
  (t/async done
    (let [st (s/from-coll [1 2 3])
          a (atom [])]
      (s/to-atom st a conj)
      (s/on-end st #(do (t/is (= @a [1 2 3]))
                        (done))))))

(t/deftest transform-with-stateless-transducers
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5 6])
          ts (s/transform (comp
                           (map inc)
                           (filter odd?))
                          s)]
      (drain! ts #(t/is (= % [3 5 7])))
      (s/on-end ts done))))

(t/deftest transform-with-stateful-transducers
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5 6])
          ts (s/transform (comp
                           (partition-all 2)
                           (take 2))
                          s)]
      (drain! ts #(t/is (= % [[1 2] [3 4]])))
      (s/on-end ts done))))

(t/deftest schedulers
  (t/is (s/scheduler? s/asap))
  (t/is (s/scheduler? s/immediate))
  (t/is (s/scheduler? s/queue)))

(t/deftest observe-on
  (t/async done
    (let [coll [1 2 3]
          s (s/observe-on s/immediate (s/from-coll coll))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

(t/deftest subscribe-on
  (t/async done
    (let [coll [1 2 3]
          s (s/subscribe-on s/queue (s/from-coll coll))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

(ns beicon.core-spec
  (:require [cljs.test :as t]
            [cats.core :as m]
            [promesa.core :as prom]
            [beicon.monad :as bc]
            [beicon.core :as s]))

;; --- helpers for testing

(def no-op (fn [& args]))

(defmacro with-timeout
  [ms & body]
  `(js/setTimeout
    (fn []
      (do
        ~@body))
    ~ms))

(defn drain!
  ([obs cb]
   (drain! obs cb #(println "Error: " %)))
  ([obs cb errb]
   (let [values (volatile! [])]
     (s/subscribe obs
                  #(vswap! values conj %)
                  #(errb %)
                  #(cb @values)))))

(defn tick
  [interval]
  (s/from-poll interval #(.getTime (js/Date.))))

;; event stream

(t/deftest observable-from-vector
  (t/async done
    (let [coll [1 2 3]
          s (s/from-coll coll)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

(t/deftest observable-from-vector-with-take
  (t/async done
    (let [coll [1 2 3 4 5 6]
          s (->> (s/from-coll coll)
                 (s/take 2))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 2])))
      (s/on-end s done))))

(t/deftest observable-from-atom
  (t/async done
    (let [a (atom 0)
          s (->> (s/from-atom a)
                 (s/take 4))]
      (t/is (s/observable? s))
      (drain! s #(do
                   (t/is (= % [1 2 3 4]))
                   (done)))
      (swap! a inc)
      (swap! a inc)
      (swap! a inc)
      (swap! a inc))))

(t/deftest observable-from-set
  (t/async done
    (let [coll #{1 2 3}
          s (s/from-coll coll)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= (set %) coll)))
      (s/on-end s done))))

(t/deftest observable-from-callback
  (t/async done
    (let [s (s/from-callback (fn [sink]
                               (with-timeout 10
                                 (sink 1)
                                 nil)))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1])))
      (s/on-end s done))))

(t/deftest observable-from-create
  (t/async done
    (let [s (s/create (fn [sink]
                        (with-timeout 10
                          (sink 1)
                          (sink 2)
                          (sink 3)
                          (sink nil))))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 2 3])))
      (s/on-end s done))))

(t/deftest observable-with-timeout
  (t/async done
    (let [s (->> (s/timer 200)
                 (s/timeout 100 (s/just :timeout)))]
      (t/is (s/observable? s))
      (drain! s #(do
                   (t/is (= % [:timeout]))
                   (done))))))

(t/deftest observable-errors-from-binder
  (t/async done
    (let [s (s/create (fn [sink]
                        (with-timeout 10
                          (sink 1)
                          (sink (ex-info "oh noes" {})))))]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % [1]))
              #(t/is (= (ex-message %) "oh noes")))
      (s/on-error s done))))

(t/deftest observable-from-promise
  (t/async done
    (let [p (prom/resolved 42)
          s (s/from-promise p)]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % [42])))
      (s/on-end s done))))

(t/deftest observable-from-rejected-promise
  (t/async done
    (let [p (prom/rejected (ex-info "oh noes" {}))
          s (s/from-promise p)]
      (t/is (s/observable? s))
      (drain! s
              #(t/is (= % []))
              #(t/is (= (ex-message %) "oh noes")))
      (s/on-error s done))))

(t/deftest observable-repeat
  (t/async done
    (let [s (s/repeat 1 2)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1 1])))
      (s/on-end s done))))

(t/deftest observable-once
  (t/async done
    (let [s (s/once 1)]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % [1])))
      (s/on-end s done))))

(t/deftest observable-never
  (t/async done
    (let [n (s/never)]
      (s/on-end n done))))

;; (t/deftest observable-on-value
;;   (t/async done
;;     (let [s (s/from-coll [1 2 3])
;;           vacc (volatile! [])]
;;       (s/on-value s #(vswap! vacc conj %))
;;       (s/on-end s #(do (t/is (= @vacc [1 2 3]))
;;                        (done))))))

(t/deftest observable-concat
  (t/async done
    (let [s1 (s/bus)
          s2 (s/bus)
          cs (s/concat s2 s1)]
      (drain! cs #(t/is (= % [1 2 3 4])))
      (s/on-end cs done)
      (s/push! s1 1)
      (s/push! s1 2)
      (s/push! s2 :discarded)
      (s/push! s2 :discarded)
      (s/end! s1)
      (s/push! s2 3)
      (s/push! s2 4)
      (s/end! s2))))

(t/deftest observable-merge
  (t/async done
    (let [s1 (s/from-coll [1 2 3])
          s2 (s/from-coll [:1 :2 :3])
          ms (s/merge s1 s2)]
      (drain! ms #(t/is (= % [:1 1 :2 2 :3 3])))
      (s/on-end ms done))))

(t/deftest observable-skip-while
  (t/async done
    (let [nums (s/from-coll [1 1 1 2 3 4 5])
          sample (s/skip-while odd? nums)]
      (drain! sample #(t/is (= % [2 3 4 5])))
      (s/on-end sample done))))

(t/deftest observable-skip-until
  (t/async done
    (let [s (s/bus)
          sv (s/bus)
          sample (s/skip-until sv s)]
      (drain! sample #(t/is (= % [3 4 5])))
      (s/on-end sample done)
      ;; push values onto stream
      (s/push! s 1)
      (s/push! s 2)
      ;; open switch
      (s/push! sv :value)
      ;; push some more
      (s/push! s 3)
      (s/push! s 4)
      (s/push! s 5)
      ;; end
      (s/end! s)
      (s/end! sv))))

(t/deftest bus-push
  (t/async done
    (let [b (s/bus)]
      (t/is (s/bus? b))
      (drain! b #(t/is (= % [1 2 3])))
      (s/push! b 1)
      (s/push! b 2)
      (s/push! b 3)
      (s/end! b)
      (s/on-end b done))))

(t/deftest observable-filter-with-predicate
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5])
          fs (s/filter #{3 5} s)]
      (drain! fs #(t/is (= % [3 5])))
      (s/on-end fs done))))

(t/deftest observable-map-with-ifn
  (t/async done
    (let [s (s/from-coll [{:foo 1} {:foo 2}])
          fs (s/map :foo s)]
      (drain! fs #(do
                    (t/is (= % [1 2]))
                    (done))))))

(t/deftest observable-slice
  (t/async done
    (let [s (s/from-coll [1 2 3 4])
          fs (s/slice 1 3 s)]
      (drain! fs #(do
                    (t/is (= % [2 3]))
                    (done))))))

(t/deftest observable-retry
  (t/async done
    (let [errored? (volatile! false)
          s (s/create (fn [sink]
                        (if @errored?
                          (do
                            (sink 2)
                            (sink 3)
                            (sink nil))
                           (do
                             (vreset! errored? true)
                                   (sink (js/Error.))))))
                 rs (s/retry 2 s)]
      (t/is (s/observable? rs))
      (drain! rs #(t/is (= % [2 3])))
      (s/on-end rs done))))

(t/deftest observable-with-latest-from
  (t/async done
    (let [s1 (s/from-coll [0])
          s2 (s/from-coll [1 2 3])
          s3 (s/with-latest-from s1 s2)]
      (t/is (s/observable? s3))
      (drain! s3 #(t/is (= % [[1 0] [2 0] [3 0]])))
      (s/on-end s3 done))))

(t/deftest observable-catch
  (t/async done
    (let [s1 (s/from-exception (ex-info "error" {:foo :bar}))
          s2 (s/catch (fn [error]
                        (s/once (ex-data error)))
                 s1)]
      (t/is (s/observable? s2))
      (drain! s2 #(t/is (= % [{:foo :bar}])))
      (s/on-end s2 done))))

(t/deftest observable-as-functor
 (t/async done
   (let [s (s/from-coll [0 1 2])
         s2 (m/fmap inc s)]
     (t/is (s/observable? s))
     (t/is (s/observable? s2))
     (drain! s2 #(do (t/is (= % [1 2 3]))
                      (done))))))

(t/deftest observable-as-applicative
 (t/async done
   (let [pinc (m/pure bc/observable-context inc)
         pval (m/pure bc/observable-context 41)
         life (m/fapply pinc pval)]
     (t/is (s/observable? life))
     (drain! life #(do (t/is (= % [42]))
                       (done))))))

(t/deftest observable-as-monad
  (t/async done
    (let [sn (s/from-coll [1 2 3])
          snks (m/mlet [n sn
                        k (s/from-coll (map (comp keyword str) (range 1 (inc n))))]
                 (m/return [n k]))
          sample (s/take 6 snks)]
      (t/is (s/observable? snks))
      (drain! sample #(t/is (= % [[1 :1]
                                  [2 :1]
                                  [2 :2]
                                  [3 :1]
                                  [3 :2]
                                  [3 :3]])))
      (s/on-end sample done))))

(t/deftest observable-to-atom
  (t/async done
    (let [st (s/from-coll [1 2 3])
          a (s/to-atom st)]
      (s/on-end st #(do (t/is (= @a 3))
                        (done))))))

(t/deftest observable-to-atom-with-atom
  (t/async done
    (let [st (s/from-coll [1 2 3])
          vacc (volatile! [])
          a (atom 0)]
      (add-watch a
                 :acc
                 (fn [_ _ _ v]
                   (vswap! vacc conj v)))
      (s/to-atom st a)
      (s/on-end st #(do (t/is (= @a 3))
                        (t/is (= @vacc [1 2 3]))
                        (done))))))

(t/deftest observable-to-atom-with-atom-and-function
  (t/async done
    (let [st (s/from-coll [1 2 3])
          a (atom [])]
      (s/to-atom st a conj)
      (s/on-end st #(do (t/is (= @a [1 2 3]))
                        (done))))))

(t/deftest transform-with-stateless-transducers
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5 6])
          ts (s/transform (comp
                           (map inc)
                           (filter odd?))
                          s)]
      (drain! ts #(t/is (= % [3 5 7])))
      (s/on-end ts done))))

(t/deftest transform-with-stateful-transducers
  (t/async done
    (let [s (s/from-coll [1 2 3 4 5 6])
          ts (s/transform (comp
                           (partition-all 2)
                           (take 2))
                          s)]
      (drain! ts #(t/is (= % [[1 2] [3 4]])))
      (s/on-end ts done))))

;; (t/deftest schedulers
;;   ;; (t/is (s/scheduler? s/asap))
;;   (t/is (s/scheduler? s/immediate))
;;   (t/is (s/scheduler? s/queue)))

(t/deftest observe-on
  (t/async done
    (let [coll [1 2 3]
          s (s/observe-on s/immediate (s/from-coll coll))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

(t/deftest subscribe-on
  (t/async done
    (let [coll [1 2 3]
          s (s/subscribe-on s/queue (s/from-coll coll))]
      (t/is (s/observable? s))
      (drain! s #(t/is (= % coll)))
      (s/on-end s done))))

Fix tests.

Fix tests.


;; Copyright 2008-2011 Red Hat, Inc, and individual contributors.
;;
;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU Lesser General Public License as
;; published by the Free Software Foundation; either version 2.1 of
;; the License, or (at your option) any later version.
;;
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
;; 02110-1301 USA, or see the FSF site: http://www.fsf.org.

(ns immutant.web.core
  (:require [immutant.registry :as reg]))

(def filters (ref {}))

(defn filter-name [path]
  (str "immutant.ring." (reg/fetch "app-name") "." path))

(defn normalize-subcontext-path [path]
  "normalize subcontext path so it matches Servlet Spec v2.3, section 11.2"
  (loop [p path]
    (println p)
    (condp re-matches p
      #"^(/[^*]+)*/\*$" p                 ;; /foo/* || /*
      #"^(|[^/].*)" (recur (str "/" p))   ;; prefix with /
      #".*?[^/]$" (recur (str p "/"))     ;; add final /
      #"^(/[^*]+)*/$" (recur (str p "*")) ;; postfix with *
      (throw (IllegalArgumentException.
              (str "The context path \"" path "\" is invalid. It should be \"/\", \"/foo\", \"/foo/\", \"foo/\", or \"foo\""))))))

;; Copyright 2008-2011 Red Hat, Inc, and individual contributors.
;;
;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU Lesser General Public License as
;; published by the Free Software Foundation; either version 2.1 of
;; the License, or (at your option) any later version.
;;
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
;; 02110-1301 USA, or see the FSF site: http://www.fsf.org.

(ns immutant.web.core
  (:require [immutant.registry :as reg]))

(def filters (ref {}))

(defn filter-name [path]
  (str "immutant.ring." (reg/fetch "app-name") "." path))

(defn normalize-subcontext-path [path]
  "normalize subcontext path so it matches Servlet Spec v2.3, section 11.2"
  (loop [p path]
    (condp re-matches p
      #"^(/[^*]+)*/\*$" p                 ;; /foo/* || /*
      #"^(|[^/].*)" (recur (str "/" p))   ;; prefix with /
      #".*?[^/]$" (recur (str p "/"))     ;; add final /
      #"^(/[^*]+)*/$" (recur (str p "*")) ;; postfix with *
      (throw (IllegalArgumentException.
              (str "The context path \"" path "\" is invalid. It should be \"/\", \"/foo\", \"/foo/\", \"foo/\", or \"foo\""))))))

Remove debugging.

Remove debugging.


(ns overseer.api-test
 (:require [clojure.test :refer :all]
           [datomic.api :as d]
           (overseer
             [api :as api]
             [worker :as w])))

(deftest test-harness
  (let [state (atom 0)
        job {:foo "bar"}
        wrapper
        (fn [f]
          (fn [job]
            (swap! state inc)
            (f job)))]
    (testing "function handler"
      (let [handler (fn [job]
                      (swap! state inc)
                      :quux)
            harnessed (api/harness handler wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))
        (is (map? harnessed))))

    (testing "mapping function handler"
      (let [handler (fn [job]
                      (swap! state inc)
                      :quux)
            harnessed (api/harness handler :pre-process wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))
        (is (= #{:pre-process :process} (set (keys harnessed))))))

    (testing "map handler - :process"
      (let [handler {:process (fn [job] (swap! state inc))}
            harnessed (api/harness handler wrapper)]
        (reset! state 0)
        (w/invoke-handler harnessed job)
        (is (= 2 @state))))

    (testing "map handler - :pre-process"
      (let [handler {:pre-process (fn [job] (swap! state inc))
                     :process (fn [job] job)}
            harnessed (api/harness handler :pre-process wrapper)]
        (reset! state 0)
        (w/invoke-handler harnessed job)
        (is (= 2 @state))))

    (testing "map handler - :post-process"
      (let [post-wrapper
            (fn [f]
              (fn [job res]
                (swap! state inc)
                (f job res)))
            handler {:process (fn [job] :quux)
                     :post-process (fn [job res]
                                     (swap! state inc)
                                     res)}
            harnessed (api/harness handler :post-process post-wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))))

    (testing "harnessing missing keys"
      (let [handler {:process (fn [job] (:foo job))}
            pre-wrapper (fn [f]
                          (fn [job]
                            (f (assoc job :foo :bar))))
            post-wrapper (fn [f]
                           (fn [job res]
                             (f (assoc job :foo :quux) res)))
            pre-harnessed (api/harness handler :pre-process pre-wrapper)
            post-harnessed (api/harness handler :post-process post-wrapper)]
        (is (= :bar (w/invoke-handler pre-harnessed job)))
        (is (= {:foo :quux} (w/invoke-handler post-harnessed job)))))))

(ns overseer.api-test
 (:require [clojure.test :refer :all]
           [datomic.api :as d]
           (overseer
             [api :as api]
             [worker :as w])))

(deftest test-harness
  (let [state (atom 0)
        job {:foo "bar"}
        wrapper
        (fn [f]
          (fn [job]
            (swap! state inc)
            (f job)))]
    (testing "function handler"
      (let [handler (fn [job]
                      (swap! state inc)
                      :quux)
            harnessed (api/harness handler wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))
        (is (map? harnessed))))

    (testing "mapping function handler"
      (let [handler (fn [job]
                      (swap! state inc)
                      :quux)
            harnessed (api/harness handler :pre-process wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))
        (is (= #{:pre-process :process} (set (keys harnessed))))))

    (testing "map handler - :process"
      (let [handler {:process (fn [job] (swap! state inc))}
            harnessed (api/harness handler wrapper)]
        (reset! state 0)
        (w/invoke-handler harnessed job)
        (is (= 2 @state))))

    (testing "map handler - :pre-process"
      (let [handler {:pre-process (fn [job] (swap! state inc))
                     :process (fn [job] job)}
            harnessed (api/harness handler :pre-process wrapper)]
        (reset! state 0)
        (w/invoke-handler harnessed job)
        (is (= 2 @state))))

    (testing "map handler - :post-process"
      (let [post-wrapper
            (fn [f]
              (fn [job res]
                (swap! state inc)
                (f job res)))
            handler {:process (fn [job] :quux)
                     :post-process (fn [job res]
                                     (swap! state inc)
                                     res)}
            harnessed (api/harness handler :post-process post-wrapper)]
        (reset! state 0)
        (is (= :quux (w/invoke-handler harnessed job)))
        (is (= 2 @state))))

    (testing "harnessing missing keys"
      (let [handler {:process (fn [job] (:foo job))}
            pre-wrapper (fn [f]
                          (fn [job]
                            (f (assoc job :foo :bar))))
            post-wrapper (fn [f]
                           (fn [job res]
                             (swap! state inc)))
            pre-harnessed (api/harness handler :pre-process pre-wrapper)
            post-harnessed (api/harness handler :post-process post-wrapper)]
        (reset! state 0)
        (is (= :bar (w/invoke-handler pre-harnessed job)))
        (is (= 0 @state))
        (w/invoke-handler post-harnessed job)
        (is (= 1 @state))))))

Update state atom in post-processor test


(ns tobias.core
  (:require [compojure.core :refer :all]
            [compojure.route :as route]
            [ring.middleware.defaults :refer [wrap-defaults api-defaults]]
            [ring.middleware.multipart-params :refer [wrap-multipart-params]]
            [ring.middleware.json :refer [wrap-json-body wrap-json-response]]
            [ring.middleware.cors :refer [wrap-cors]]
            [ring.util.response :refer [response resource-response content-type]]
            [ring.adapter.jetty :refer [run-jetty]]
            [tobias.cv :refer [get-features]]
            [tobias.util :refer [timed]])
  (:gen-class))

(def ads->features (atom {}))

(def features
  "A map that holds features and their possible values"
  {:ethnicity [:asian :black :hispanic :white]
   :location  [:prime :average]
   :gender    [:male :female]
   :age       [:young :mid :old]
   :weather   [:sunny :rainy]})

(def ads->features-example
  "An example of a map that holds each ad and its preferred features"
  [{:id :one
    :ethnicity :asian
    :weather   :rainy
    :location  :prime
    :age       :mid
    :gender    :male
    :url       "http://example.com/1.jpg"}
   {:id        :two
    :age       :mid
    :gender    :female
    :location  :average
    :url       "http://example.com/2.jpg"}
   {:id        :three
    :weather   :sunny
    :gender    :male
    :url       "http://example.com/3.jpg"}
   {:id        :four
    :gender    :male
    :age       :old
    :location  :prime
    :url       "http://example.com/4.jpg"}])

(def result-features-example
  "An example of a resulting map obtained from Tobiaz' UI and CV"
  {:location  :prime
   :ethnicity :asian
   :weather   :sunny
   :gender    :male})

; Maybe we can add this information to the resulting response
(def advertisers->ads
  "A map that holds ads per advertiser"
  {:advertiser1 #{:ad1 :ad2}
   :advertiser2 #{:ad3}
   :advertiser3 #{:ad4}})

(defn score-feature-set [feature-set result-set]
  "Returns an ad's feature set scored"
  ; do a set intersection between the result set and this ad's feature set to get matches
  (let [matching-features (->> (clojure.set/intersection result-set feature-set)
                               (into {}))]
    (assoc (into {} feature-set)
      :matches matching-features
      :score (count matching-features))))

(defn get-scored-ads [current-ad->features resulting-features]
  "Given a map of resulting features, computes the score for each ad feature"
  (let [result-set (set resulting-features)] ; convert to set for easy operation
    (map #(score-feature-set (set %) result-set)
         current-ad->features)))

(defn get-winning-ad [current-features resulting-features]
  (let [results (get-scored-ads current-features resulting-features)]
    (->> results
         (sort-by :score)
         (last)
         (assoc {} :winner)
         (merge {:features resulting-features}))))

(defn run-auction [image env-features]
  (->> image
       (get-features)
       (first) ; select only one feature (possibly the one with highest confidence), should be more clever
       (merge env-features)
       (get-winning-ad ads->features-example)))

(defn run-auction2 [image env-features]
  (let [res {:foo :bar
            :gender "M"
            :url "http://cdn.playbuzz.com/cdn/0079c830-3406-4c05-a5c1-bc43e8f01479/7dd84d70-768b-492b-88f7-a6c70f2db2e9.jpg"}] res))

(defroutes app-routes
  (GET "/" [] (content-type (resource-response "index.html" {:root "public"}) "text/html"))
  (POST "/auction/new"
        {{{image :tempfile} :file} :params} (response (run-auction2 image {:location :prime :weather :sunny})))
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  (-> app-routes
      (wrap-defaults api-defaults)
      (wrap-json-body {:keywords? true})
      (wrap-json-response)
      (wrap-multipart-params)
      (wrap-cors :access-control-allow-origin [#".*"]
                 :access-control-allow-methods [:post])))

(defn -main [& args]
  (run-jetty app {:port 3000}))

(ns tobias.core
  (:require [compojure.core :refer :all]
            [compojure.route :as route]
            [ring.middleware.defaults :refer [wrap-defaults api-defaults]]
            [ring.middleware.multipart-params :refer [wrap-multipart-params]]
            [ring.middleware.json :refer [wrap-json-body wrap-json-response]]
            [ring.middleware.cors :refer [wrap-cors]]
            [ring.util.response :refer [response resource-response content-type]]
            [ring.adapter.jetty :refer [run-jetty]]
            [tobias.cv :refer [get-features]]
            [tobias.util :refer [timed]])
  (:gen-class))

(def ads->features (atom {}))

(def features
  "A map that holds features and their possible values"
  {:ethnicity [:asian :black :hispanic :white]
   :location  [:prime :average]
   :gender    [:male :female]
   :age       [:young :mid :old]
   :weather   [:sunny :rainy]})

(def ads->features-example
  "An example of a map that holds each ad and its preferred features"
  [{:id :one
    :ethnicity :asian
    :weather   :rainy
    :location  :prime
    :age       :mid
    :gender    :male
    :url       "http://www.zillowstatic.com/static/images/ad_gallery/chevy-300x250.jpg"}
   {:id        :two
    :age       :mid
    :gender    :female
    :location  :average
    :url       "http://www.fashionadexplorer.com/l-yE0JkxpIlKdLO9ot.jpg"}
   {:id        :three
    :weather   :sunny
    :gender    :male
    :age       :mid
    :url       "https://webtoolfeed.files.wordpress.com/2012/04/4bd863d620bf61.jpg"}
   {:id        :four
    :gender    :male
    :age       :old
    :location  :prime
    :url       "http://files2.coloribus.com/files/adsarchive/part_944/9449805/file/life-insurance-deck-chair-small-69163.jpg"}])

(def result-features-example
  "An example of a resulting map obtained from Tobiaz' UI and CV"
  {:location  :prime
   :ethnicity :asian
   :weather   :sunny
   :gender    :male})

(defn score-feature-set [feature-set result-set]
  "Returns an ad's feature set scored"
  ; do a set intersection between the result set and this ad's feature set to get matches
  (let [matching-features (->> (clojure.set/intersection result-set feature-set)
                               (into {}))]
    (assoc (into {} feature-set)
      :matches matching-features
      :score (count matching-features))))

(defn get-scored-ads [current-ad->features resulting-features]
  "Given a map of resulting features, computes the score for each ad feature"
  (let [result-set (set resulting-features)] ; convert to set for easy operation
    (map #(score-feature-set (set %) result-set)
         current-ad->features)))

(defn get-winning-ad [current-features resulting-features]
  (let [results (get-scored-ads current-features resulting-features)]
    (->> results
         (sort-by :score)
         (last)
         (assoc {} :winner)
         (merge {:features resulting-features}))))

(defn run-auction [image env-features]
  (->> image
       (get-features)
       (first) ; select only one feature (possibly the one with highest confidence), should be more clever
       (merge env-features)
       (get-winning-ad ads->features-example)))

(def simulated-response
  "An example of a map that holds each ad and its preferred features"
  [{:id :one
    :age       :mid
    :gender    :male
    :url       "http://marketing-mojo.com/wp-content/uploads/2013/11/2308906108657132479-copy.png"}
   {:id        :two
    :age       :mid
    :gender    :female
    :url       "http://assets.ilounge.com/images/uploads/b2_62.gif"}
   {:id        :three
    :gender    :male
    :age       :mid
    :url       "https://mir-s3-cdn-cf.behance.net/project_modules/disp/05cd6a12328509.56266a8c003f1.jpg"}
   {:id        :four
    :age       :old
    :gender    :male
    :url       "http://realreachmarketing.com/wp-content/uploads/2015/08/Pool_Ad_family1.jpg"}
   {:id        :four
    :age       :old
    :gender    :male
    :url       "http://www.terrymehilos.com/images/banner-336x280.jpg"}
   {:id        :four
    :age       :old
    :gender    :male
    :url       "https://mkbydesign.files.wordpress.com/2014/01/amanda-myers-multimedia-campaign-coke-website-banner.gif?w=620"}
   ])

(defn run-simulation [image env-features]
  {:url (:url (rand-nth simulated-response))})

(defroutes app-routes
  (GET "/" [] (content-type (resource-response "index.html" {:root "public"}) "text/html"))
  (POST "/auction/new"
        {{{image :tempfile} :file} :params} (response (run-auction image {:location :prime :weather :sunny})))
  (POST "/simulation/new"
        {{{image :tempfile} :file} :params} (response (run-simulation image {:location :prime :weather :sunny})))
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  (-> app-routes
      (wrap-defaults api-defaults)
      (wrap-json-body {:keywords? true})
      (wrap-json-response)
      (wrap-multipart-params)
      (wrap-cors :access-control-allow-origin [#".*"]
                 :access-control-allow-methods [:post])))

(defn -main [& args]
  (run-jetty app {:port 3000}))

Add a simulation endpoint

Add a simulation endpoint


Add another interesting transit example

Add another interesting transit example


(ns frontend.utils.ajax
  (:require [ajax.core :as clj-ajax]
            [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [cljs-time.core :as time]
            [clojure.string :as str]
            [frontend.async :refer [put!]]
            [frontend.utils :as utils :include-macros true]))

;; https://github.com/JulianBirch/cljs-ajax/blob/master/src/ajax/core.cljs
;; copy of the default json formatter, but returns a map with json body
;; in :resp and extra request metadata: :response-headers, :url, :method, and :request-time
(defn json-response-format
  "Returns a JSON response format.  Options include
   :keywords? Returns the keys as keywords
   :prefix A prefix that needs to be stripped off.  This is to
   combat JSON hijacking.  If you're using JSON with GET request,
   you should use this.
   http://stackoverflow.com/questions/2669690/why-does-google-prepend-while1-to-their-json-responses
   http://haacked.com/archive/2009/06/24/json-hijacking.aspx"
  ([{:keys [prefix keywords? url method start-time]
     :or {start-time (time/now)}}]
     {:read (fn read-json [xhrio]
              (let [json (js/JSON.parse (.getResponseText xhrio))
                    headers (js->clj (.getResponseHeaders xhrio))
                    request-time (try
                                   (time/in-millis (time/interval start-time (time/now)))
                                   (catch :default e
                                     (utils/merror e)
                                     0))]
                {:resp (js->clj json :keywordize-keys keywords?)
                 :response-headers headers
                 :url url
                 :method method
                 :request-time request-time}))
      :description (str "JSON"
                        (if prefix (str " prefix '" prefix "'"))
                        (if keywords? " keywordize"))}))

(defn xml-request-response []
  {:read (fn read-xml [xhrio]
           (set! js/window.testx (.getResponseXml xhrio))
           {:resp (.getResponseXml xhrio)})
   :description "XML"
   :content-type "application/xml"
   :write identity})

(defn scopes-from-response [api-resp]
  (if-let [scope-str (get-in api-resp [:response-headers "X-Circleci-Scopes"])]
    (->> (str/split scope-str #"[,\s]+")
         (map #(str/replace % #"^:" ""))
         (map keyword)
         (set))))

(defn normalize-error-response [default-response props]
  (-> default-response
      (merge props)
      (assoc :status-code (:status default-response))
      (assoc :resp (get-in default-response [:response :resp]))
      (assoc :status :failed)))

;; TODO only implementing JSON/RAW format and not implementing prefixes for now since we don't anything else
(defn ajax [method url message channel & {:keys [params keywords? context headers format]
                                          :or {keywords? true format :json}}]
  (let [uuid frontend.async/*uuid*
        common-opts {:finally #(binding [frontend.async/*uuid* uuid]
                                 (put! channel [message :finished context]))}
        format-opts (case format
                      :json {:format (merge (clj-ajax/json-request-format)
                                            (json-response-format {:keywords? keywords? :url url :method method}))
                             :response-format :json
                             :keywords? keywords?
                             :params params
                             :headers (merge {:Accept "application/json"}
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(binding [frontend.async/*uuid* uuid]
                                         (put! channel [message :success (assoc % :context context :scopes (scopes-from-response %))]))
                             :error-handler #(binding [frontend.async/*uuid* uuid]
                                       (put! channel [message :failed (normalize-error-response % {:url url :context context})]))}
                      ;; TODO: use a custom reader or similar for raw to handle more like json
                      :raw {:format (clj-ajax/raw-format)
                            :handler #(binding [frontend.async/*uuid* uuid]
                                        (put! channel [message :success {:resp % :context context}]))
                            :error-handler #(binding [frontend.async/*uuid* uuid]
                                       (put! channel [message :failed {:resp % :url url :context context :status :failed}]))})
        opts (merge common-opts format-opts)]
    (put! channel [message :started context])
    (clj-ajax/ajax-request url method
                           (clj-ajax/transform-opts opts))))

;; This is all very mess, it should be cleaned up at some point
(defn managed-ajax [method url & {:keys [params keywords? headers format response-format]
                                  :or {keywords? true
                                       response-format :json
                                       format :json}}]
  (let [channel (chan)
        format (get {:xml (xml-request-response)
                     :json (merge (clj-ajax/json-request-format)
                                  (json-response-format {:keywords? keywords? :url url :method method}))}
                    format)
        accept-header (get {:xml "application/xml"
                            :json "application/json"}
                           response-format)]
    (clj-ajax/ajax-request url method
                           (clj-ajax/transform-opts
                            {:format format
                             :response-format response-format
                             :keywords? keywords?
                             :params params
                             :headers (merge (when accept-header
                                               {:Accept accept-header})
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(put! channel (assoc % :status :success :scopes (scopes-from-response %)))
                             ;; TODO: clean this up
                             :error-handler #(put! channel (normalize-error-response % {:url url}))
                             :finally #(close! channel)}))
    channel))

;; TODO this should be possible to do with the normal ajax function, but punting for now
(defn managed-form-post [url & {:keys [params headers keywords?]
                                :or {keywords? true}}]
  (let [channel (chan)]
    (clj-ajax/ajax-request url :post
                           (clj-ajax/transform-opts
                            {:format (merge (clj-ajax/url-request-format)
                                            (json-response-format {:keywords? keywords? :url url :method :post}))
                             :response-format :json
                             :params params
                             :headers (merge {:Accept "application/json"}
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(put! channel (assoc % :status :success))
                             :error-handler #(put! channel %)
                             :finally #(close! channel)}))
    channel))

(ns frontend.utils.ajax
  (:require [ajax.core :as clj-ajax]
            [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [cljs-time.core :as time]
            [clojure.string :as str]
            [frontend.async :refer [put!]]
            [frontend.utils :as utils :include-macros true]))

;; https://github.com/JulianBirch/cljs-ajax/blob/master/src/ajax/core.cljs
;; copy of the default json formatter, but returns a map with json body
;; in :resp and extra request metadata: :response-headers, :url, :method, and :request-time
(defn json-response-format
  "Returns a JSON response format.  Options include
   :keywords? Returns the keys as keywords
   :prefix A prefix that needs to be stripped off.  This is to
   combat JSON hijacking.  If you're using JSON with GET request,
   you should use this.
   http://stackoverflow.com/questions/2669690/why-does-google-prepend-while1-to-their-json-responses
   http://haacked.com/archive/2009/06/24/json-hijacking.aspx"
  ([{:keys [prefix keywords? url method start-time]
     :or {start-time (time/now)}}]
     {:read (fn read-json [xhrio]
              (let [json (js/JSON.parse (.getResponseText xhrio))
                    headers (js->clj (.getResponseHeaders xhrio))
                    request-time (try
                                   (time/in-millis (time/interval start-time (time/now)))
                                   (catch :default e
                                     (utils/merror e)
                                     0))]
                {:resp (js->clj json :keywordize-keys keywords?)
                 :response-headers headers
                 :url url
                 :method method
                 :request-time request-time}))
      :description (str "JSON"
                        (if prefix (str " prefix '" prefix "'"))
                        (if keywords? " keywordize"))}))

(defn xml-request-response []
  {:read (fn read-xml [xhrio]
           (set! js/window.testx (.getResponseXml xhrio))
           {:resp (.getResponseXml xhrio)})
   :description "XML"
   :content-type "application/xml"
   :write identity})

(defn normalize-error-response [default-response props]
  (-> default-response
      (merge props)
      (assoc :status-code (:status default-response))
      (assoc :resp (get-in default-response [:response :resp]))
      (assoc :status :failed)))

;; TODO only implementing JSON/RAW format and not implementing prefixes for now since we don't anything else
(defn ajax [method url message channel & {:keys [params keywords? context headers format body]
                                          :or {keywords? true format :edn}}]
  (let [uuid frontend.async/*uuid*
        format-opts (case format
                      :json {:format (merge (clj-ajax/json-request-format)
                                            (json-response-format {:keywords? keywords? :url url :method method}))
                             :response-format :json
                             :keywords? keywords?
                             :params params
                             :headers (merge {:Accept "application/json"}
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(binding [frontend.async/*uuid* uuid]
                                         (put! channel [message :success (assoc % :context context)]))
                             :error-handler #(binding [frontend.async/*uuid* uuid]
                                               (put! channel [message :failed (normalize-error-response % {:url url :context context})]))}
                      :edn {:format (clj-ajax/edn-format)
                            :params params
                            :handler #(binding [frontend.async/*uuid* uuid]
                                        (put! channel [message :success {:resp % :context context}]))
                            :error-handler #(binding [frontend.async/*uuid* uuid]
                                              (put! channel [message :failed (normalize-error-response % {:url url :context context})]))}

                      ;; TODO: use a custom reader or similar for raw to handle more like json
                      :raw {:format (clj-ajax/raw-format)
                            :handler #(binding [frontend.async/*uuid* uuid]
                                        (put! channel [message :success {:resp (utils/inspect %) :context context}]))
                            :error-handler #(binding [frontend.async/*uuid* uuid]
                                       (put! channel [message :failed {:resp % :url url :context context :status :failed}]))})]
    (clj-ajax/ajax-request url method
                           (clj-ajax/transform-opts format-opts))))

;; This is all very mess, it should be cleaned up at some point
(defn managed-ajax [method url & {:keys [params keywords? headers format response-format]
                                  :or {keywords? true
                                       response-format :json
                                       format :json}}]
  (let [channel (chan)
        format (get {:xml (xml-request-response)
                     :json (merge (clj-ajax/json-request-format)
                                  (json-response-format {:keywords? keywords? :url url :method method}))}
                    format)
        accept-header (get {:xml "application/xml"
                            :json "application/json"}
                           response-format)]
    (clj-ajax/ajax-request url method
                           (clj-ajax/transform-opts
                            {:format format
                             :response-format response-format
                             :keywords? keywords?
                             :params params
                             :headers (merge (when accept-header
                                               {:Accept accept-header})
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(put! channel (assoc % :status :success))
                             ;; TODO: clean this up
                             :error-handler #(put! channel (normalize-error-response % {:url url}))
                             :finally #(close! channel)}))
    channel))

;; TODO this should be possible to do with the normal ajax function, but punting for now
(defn managed-form-post [url & {:keys [params headers keywords?]
                                :or {keywords? true}}]
  (let [channel (chan)]
    (clj-ajax/ajax-request url :post
                           (clj-ajax/transform-opts
                            {:format (merge (clj-ajax/url-request-format)
                                            (json-response-format {:keywords? keywords? :url url :method :post}))
                             :response-format :json
                             :params params
                             :headers (merge {:Accept "application/json"}
                                             (when (re-find #"^/" url)
                                               {:X-CSRFToken (utils/csrf-token)})
                                             headers)
                             :handler #(put! channel (assoc % :status :success))
                             :error-handler #(put! channel %)
                             :finally #(close! channel)}))
    channel))

patch up ajax/ajax to use edn

patch up ajax/ajax to use edn


(ns shadow.remote.runtime.cljs.websocket
  (:require
    ;; this will eventually replace shadow.cljs.devtools.client completely
    [shadow.cljs.devtools.client.env :as env]
    [shadow.cljs.devtools.client.browser :as browser]
    [shadow.remote.runtime.shared :as shared]
    [shadow.remote.runtime.cljs.env :as renv]
    [shadow.remote.runtime.cljs.common :as common]
    [shadow.remote.runtime.cljs.js-builtins]))

(extend-type common/Runtime
  renv/IEvalJS
  (-eval-js [this code]
    (js* "(0,eval)(~{})" code))

  common/IHostSpecific
  (do-repl-invoke [this {:keys [js] :as msg}]
    (js* "(0,eval)(~{});" js))

  (do-repl-require [runtime {:keys [sources reload-namespaces js-requires] :as msg} done error]
    (let [sources-to-load
          (->> sources
               (remove (fn [{:keys [provides] :as src}]
                         (and (env/src-is-loaded? src)
                              (not (some reload-namespaces provides)))))
               (into []))]

      (if-not (seq sources-to-load)
        (done [])
        (shared/call runtime
          {:op :cljs-load-sources
           :rid env/worker-rid
           :sources (into [] (map :resource-id) sources-to-load)}

          {:cljs-sources
           (fn [{:keys [sources] :as msg}]
             (try
               (browser/do-js-load sources)
               (when (seq js-requires)
                 (browser/do-js-requires js-requires))
               (done sources-to-load)
               (catch :default ex
                 (error ex))))})))))

(defn start []
  (if-some [{:keys [stop]} @renv/runtime-ref]
    ;; if already connected. cleanup and call restart async
    ;; need to give the websocket a chance to close
    ;; only need this to support hot-reload this code
    ;; can't use :dev/before-load-async hooks since they always run
    (do (stop)
        (reset! renv/runtime-ref nil)
        (js/setTimeout start 10))

    (let [ws-url
          (str (env/get-ws-url-base) "/api/runtime"
               (if (exists? js/document)
                 "?type=browser"
                 "?type=browser-worker")
               "&build-id=" (js/encodeURIComponent env/build-id))

          socket
          (js/WebSocket. ws-url)

          send-fn
          (fn [msg]
            (.send socket msg))

          state-ref
          (atom (shared/init-state))

          runtime
          (common/Runtime. state-ref send-fn)]

      (common/init-runtime! runtime #(.close socket))

      (.addEventListener socket "message"
        (fn [e]
          (shared/process runtime (common/transit-read (.-data e)))
          ))

      (.addEventListener socket "open"
        (fn [e]
          ;; allow shared/process to send messages directly to relay
          ;; without being coupled to the implementation of exactly how
          ))

      (.addEventListener socket "close"
        (fn [e]
          (common/stop-runtime!)))

      (.addEventListener socket "error"
        (fn [e]
          (js/console.warn "tap-socket error" e)
          (common/stop-runtime!))))))

;; want things to start when this ns is in :preloads
(when (pos? env/worker-rid)
  (start))

add back autostart

add back autostart


(
  "number (0..19)"
  #"(?i)(zero|nulla|niente|uno|due|tre|quattro|cinque|sei|sette|otto|nove|dieci|undici|dodici|tredici|quattordici|quindici|sedici|diciassette|diciotto|diciannove)"
  {:dim :number
   :integer true
   :value (get {"zero" 0 "nulla" 0 "niente" 0 "uno" 1 "due" 2 "tre" 3 "quattro" 4 "cinque" 5 "sei" 6 "sette" 7 "otto" 8 "nove" 9 "dieci" 10 "undici" 11 "dodici" 12 "tredici" 13 "quattordici" 14 "quindici" 15 "sedici" 16 "diciassette" 17 "diciotto" 18 "diciannove" 19}
              (-> %1 :groups first .toLowerCase))}

  "number (20..90)"
  #"(?i)(venti|trenta|quaranta|cinquanta|sessanta|settanta|ottanta|novanta)"
  {:dim :number
   :integer true
   :value (get {"venti" 20 "trenta" 30 "quaranta" 40 "cinquanta" 50 "sessanta" 60 "settanta" 70 "ottanta" 80 "novanta" 90}
             (-> %1 :groups first .toLowerCase))}

  "number (21..29 31..39 41..49 51..59 61..69 71..79 81..89 91..99)"
  [(integer 20 90 #(#{20 30 40 50 60 70 80 90} (:value %))) #"(?i)e" (integer 1 9)]
  {:dim :number
   :integer true
   :value (+ (:value %1) (:value %3))}

  "number (21..29 31..39 41..49 51..59 61..69 71..79 81..89 91..99)"
  #"(?i)((venti|trenta|quaranta|cinquanta|sessanta|settanta|ottanta|novanta)(due|tre|tré|quattro|cinque|sei|sette|nove))|((vent|trent|quarant|cinquant|sessant|settant|ottant|novant)(uno|otto))"
  {:dim :number
   :integer true
   :value (get {"ventuno" 21 "ventidue" 22 "ventitre" 23 "ventitré" 23 "ventiquattro" 24 "venticinque" 25 "ventisei" 26 "ventisette" 27 "ventotto" 28 "ventinove" 29 "trentuno" 31 "trentadue" 32 "trentatre" 33 "trentatré" 33 "trentaquattro" 34 "trentacinque" 35 "trentasei" 36 "trentasette" 37 "trentotto" 38 "trentanove" 39 "quarantuno" 41 "quarantadue" 42 "quarantatre" 43 "quarantatré" 43 "quarantaquattro" 44 "quarantacinque" 45 "quarantasei" 46 "quarantasette" 47 "quarantotto" 48 "quarantanove" 49 "cinquantuno" 51 "cinquantadue" 52 "cinquantatre" 53  "cinquantatré" 53"cinquantaquattro" 54 "cinquantacinque" 55 "cinquantasei" 56 "cinquantasette" 57 "cinquantotto" 58 "cinquantanove" 59 "sessantuno" 61 "sessantadue" 62 "sessantatre" 63 "sessantatré" 63 "sessantaquattro" 64 "sessantacinque" 65 "sessantasei" 66 "sessantasette" 67 "sessantotto" 68 "sessantanove" 69 "settantuno" 71 "settantadue" 72 "settantatre" 73 "settantatré" 73 "settantaquattro" 74 "settantacinque" 75 "settantasei" 76 "settantasette" 77 "settantotto" 78 "settantanove" 79 "ottantuno" 81 "ottantadue" 82 "ottantatre" 83 "ottantatré" 83 "ottantaquattro" 84 "ottantacinque" 85 "ottantasei" 86 "ottantasette" 87 "ottantotto" 88 "ottantanove" 89 "novantuno" 91 "novantadue" 92 "novantatre" 93 "novantatré" 93 "novantaquattro" 94 "novantacinque" 95 "novantasei" 96 "novantasette" 97 "novantotto" 98 "novantanove" 99}
              (-> %1 :groups first .toLowerCase))}

  "number 100..1000 "
  #"(?i)(due|tre|quattro|cinque|sei|sette|otto|nove)?cento|mil(a|le)"
  {:dim :number
   :integer true
   :value (get {"cento" 100 "duecento" 200 "trecento" 300 "quattrocento" 400 "cinquecento" 500 "seicento" 600 "settecento" 700 "ottocento" 800 "novecento" 900 "mille" 1000" mila" 1000}
              (-> %1 :groups first .toLowerCase))}

  "numbers 200..999"
  [(integer 2 9) (integer 100 100) (integer 0 99)]
  {:dim :number
   :integer true
   :value (+ (* (:value %1) (:value %2)) (:value %3))}

  ;; numeric

  "integer (numeric)"
  #"(\d{1,18})"
  {:dim :number
   :integer true
   :value (Long/parseLong (first (:groups %1)))}

  "integer with thousands separator ."
  #"(\d{1,3}(\.\d\d\d){1,5})"
  {:dim :number
   :integer true
   :value (-> (:groups %1)
            first
            (clojure.string/replace #"\." "")
            Long/parseLong)}

  ;;
  ;; Decimals
  ;;

  "decimal number"
  #"(\d*,\d+)"
  {:dim :number
   :value (parse-number-fr (first (:groups %1)))}

  "decimal with thousands separator"
  #"(\d+(\.\d\d\d)+,\d+)"
  {:dim :number
   :value (-> (:groups %1)
            first
            (clojure.string/replace #"\." "")
            parse-number-fr)}

  ;; prefixes
  "numbers prefix with -, negative or minus"
  [#"(?i)-|meno|negativo" (dim :number #(not (:number-prefixed %)))]
  (let [multiplier -1
        value      (* (:value %2) multiplier)
        int?       (zero? (mod value 1)) ; often true, but we could have 1.1111K
        value      (if int? (long value) value)] ; cleaner if we have the right type
    (assoc %2 :value value
              :integer int?
              :number-prefixed true)) ; prevent "- -3km" to be 3 billions

  ;; suffixes

  "numbers suffixes (K, M, G)"
  [(dim :number #(not (:number-suffixed %))) #"(?i)([kmg])(?=[\W\$€]|$)"]
  (let [multiplier (get {"k" 1000 "m" 1000000 "g" 1000000000}
                        (-> %2 :groups first .toLowerCase))
        value      (* (:value %1) multiplier)
        int?       (zero? (mod value 1)) ; often true, but we could have 1.1111K
        value      (if int? (long value) value)] ; cleaner if we have the right type
    (assoc %1 :value value
              :integer int?
              :number-suffixed true)) ; prevent "3km" to be 3 billions

  ;;
  ;; Ordinal numbers
  ;;

  "ordinals (primo..10)"
  #"(?i)(prim|second|terz|quart|quint|sest|settim|ottav|non|decim)(o|a|i|e)"
  {:dim :ordinal
   :value (get {"primo" 1 "secondo" 2 "terzo" 3 "quarto" 4 "quinto" 5 "sesto" 6 "settimo" 7 "ottavo" 8 "nono" 9 "decimo" 10 "prima" 1 "seconda" 2 "terza" 3 "quarta" 4 "quinta" 5 "sesta" 6 "settima" 7 "ottava" 8 "nona" 9 "decima" 10 "primi" 1 "secondi" 2 "terzi" 3 "quarti" 4 "quinti" 5 "sesti" 6 "settimi" 7 "ottavi" 8 "noni" 9 "decimi" 10 "prime" 1 "seconde" 2 "terze" 3 "quarte" 4 "quinte" 5 "seste" 6 "settime" 7 "ottave" 8 "none" 9 "decime" 10}
              (-> %1 :groups first .toLowerCase))}

  "ordinal (digits)"
  #"0*(\d+) ?[ª°]"
  {:dim :ordinal
   :value (read-string (first (:groups %1)))}  ; read-string not the safest

)

(
  "number (0..19)"
  #"(?i)(zero|nulla|niente|uno|due|tre|quattro|cinque|sei|sette|otto|nove|dieci|undici|dodici|tredici|quattordici|quindici|sedici|diciassette|diciotto|diciannove)"
  {:dim :number
   :integer true
   :value (get {"zero" 0 "nulla" 0 "niente" 0 "uno" 1 "due" 2 "tre" 3 "quattro" 4 "cinque" 5 "sei" 6 "sette" 7 "otto" 8 "nove" 9 "dieci" 10 "undici" 11 "dodici" 12 "tredici" 13 "quattordici" 14 "quindici" 15 "sedici" 16 "diciassette" 17 "diciotto" 18 "diciannove" 19}
              (-> %1 :groups first .toLowerCase))}

  "number (20..90)"
  #"(?i)(venti|trenta|quaranta|cinquanta|sessanta|settanta|ottanta|novanta)"
  {:dim :number
   :integer true
   :value (get {"venti" 20 "trenta" 30 "quaranta" 40 "cinquanta" 50 "sessanta" 60 "settanta" 70 "ottanta" 80 "novanta" 90}
             (-> %1 :groups first .toLowerCase))}

  "number (21..29 31..39 41..49 51..59 61..69 71..79 81..89 91..99)"
  [(integer 20 90 #(#{20 30 40 50 60 70 80 90} (:value %))) #"(?i)e" (integer 1 9)]
  {:dim :number
   :integer true
   :value (+ (:value %1) (:value %3))}

  "number (21..29 31..39 41..49 51..59 61..69 71..79 81..89 91..99)"
  #"(?i)((venti|trenta|quaranta|cinquanta|sessanta|settanta|ottanta|novanta)(due|tre|tré|quattro|cinque|sei|sette|nove))|((vent|trent|quarant|cinquant|sessant|settant|ottant|novant)(uno|otto))"
  {:dim :number
   :integer true
   :value (get {"ventuno" 21 "ventidue" 22 "ventitre" 23 "ventitré" 23 "ventiquattro" 24 "venticinque" 25 "ventisei" 26 "ventisette" 27 "ventotto" 28 "ventinove" 29 "trentuno" 31 "trentadue" 32 "trentatre" 33 "trentatré" 33 "trentaquattro" 34 "trentacinque" 35 "trentasei" 36 "trentasette" 37 "trentotto" 38 "trentanove" 39 "quarantuno" 41 "quarantadue" 42 "quarantatre" 43 "quarantatré" 43 "quarantaquattro" 44 "quarantacinque" 45 "quarantasei" 46 "quarantasette" 47 "quarantotto" 48 "quarantanove" 49 "cinquantuno" 51 "cinquantadue" 52 "cinquantatre" 53  "cinquantatré" 53"cinquantaquattro" 54 "cinquantacinque" 55 "cinquantasei" 56 "cinquantasette" 57 "cinquantotto" 58 "cinquantanove" 59 "sessantuno" 61 "sessantadue" 62 "sessantatre" 63 "sessantatré" 63 "sessantaquattro" 64 "sessantacinque" 65 "sessantasei" 66 "sessantasette" 67 "sessantotto" 68 "sessantanove" 69 "settantuno" 71 "settantadue" 72 "settantatre" 73 "settantatré" 73 "settantaquattro" 74 "settantacinque" 75 "settantasei" 76 "settantasette" 77 "settantotto" 78 "settantanove" 79 "ottantuno" 81 "ottantadue" 82 "ottantatre" 83 "ottantatré" 83 "ottantaquattro" 84 "ottantacinque" 85 "ottantasei" 86 "ottantasette" 87 "ottantotto" 88 "ottantanove" 89 "novantuno" 91 "novantadue" 92 "novantatre" 93 "novantatré" 93 "novantaquattro" 94 "novantacinque" 95 "novantasei" 96 "novantasette" 97 "novantotto" 98 "novantanove" 99}
              (-> %1 :groups first .toLowerCase))}

  "number 100..1000 "
  #"(?i)(due|tre|quattro|cinque|sei|sette|otto|nove)?cento|mil(a|le)"
  {:dim :number
   :integer true
   :value (get {"cento" 100 "duecento" 200 "trecento" 300 "quattrocento" 400 "cinquecento" 500 "seicento" 600 "settecento" 700 "ottocento" 800 "novecento" 900 "mille" 1000" mila" 1000}
              (-> %1 :groups first .toLowerCase))}

  "numbers 200..999"
  [(integer 2 9) (integer 100 100) (integer 0 99)]
  {:dim :number
   :integer true
   :value (+ (* (:value %1) (:value %2)) (:value %3))}

  ;; numeric

  "integer (numeric)"
  #"(\d{1,18})"
  {:dim :number
   :integer true
   :value (Long/parseLong (first (:groups %1)))}

  "integer with thousands separator ."
  #"(\d{1,3}(\.\d\d\d){1,5})"
  {:dim :number
   :integer true
   :value (-> (:groups %1)
            first
            (clojure.string/replace #"\." "")
            Long/parseLong)}

  ;;
  ;; Decimals
  ;;

  "decimal number"
  #"(\d*,\d+)"
  {:dim :number
   :value (parse-number-fr (first (:groups %1)))}

  "decimal with thousands separator"
  #"(\d+(\.\d\d\d)+,\d+)"
  {:dim :number
   :value (-> (:groups %1)
            first
            (clojure.string/replace #"\." "")
            parse-number-fr)}

  ;; prefixes
  "numbers prefix with -, negative or minus"
  [#"(?i)-|meno|negativo" (dim :number #(not (:number-prefixed %)))]
  (let [multiplier -1
        value      (* (:value %2) multiplier)
        int?       (zero? (mod value 1)) ; often true, but we could have 1.1111K
        value      (if int? (long value) value)] ; cleaner if we have the right type
    (assoc %2 :value value
              :integer int?
              :number-prefixed true)) ; prevent "- -3km" to be 3 billions

  ;; suffixes

  "numbers suffixes (K, M, G)"
  [(dim :number #(not (:number-suffixed %))) #"(?i)([kmg])(?=[\W\$€]|$)"]
  (let [multiplier (get {"k" 1000 "m" 1000000 "g" 1000000000}
                        (-> %2 :groups first .toLowerCase))
        value      (* (:value %1) multiplier)
        int?       (zero? (mod value 1)) ; often true, but we could have 1.1111K
        value      (if int? (long value) value)] ; cleaner if we have the right type
    (assoc %1 :value value
              :integer int?
              :number-suffixed true)) ; prevent "3km" to be 3 billions

  ;;
  ;; Ordinal numbers
  ;;

  "ordinals (primo..10)"
  #"(?i)((prim|second|terz|quart|quint|sest|settim|ottav|non|decim)(o|a|i|e))"
  {:dim :ordinal
   :value (get {"primo" 1 "secondo" 2 "terzo" 3 "quarto" 4 "quinto" 5 "sesto" 6 "settimo" 7 "ottavo" 8 "nono" 9 "decimo" 10 "prima" 1 "seconda" 2 "terza" 3 "quarta" 4 "quinta" 5 "sesta" 6 "settima" 7 "ottava" 8 "nona" 9 "decima" 10 "primi" 1 "secondi" 2 "terzi" 3 "quarti" 4 "quinti" 5 "sesti" 6 "settimi" 7 "ottavi" 8 "noni" 9 "decimi" 10 "prime" 1 "seconde" 2 "terze" 3 "quarte" 4 "quinte" 5 "seste" 6 "settime" 7 "ottave" 8 "none" 9 "decime" 10}
              (-> %1 :groups first .toLowerCase))}

  "ordinal (digits)"
  #"0*(\d+) ?[ª°]"
  {:dim :ordinal
   :value (read-string (first (:groups %1)))}  ; read-string not the safest

)

fix ordinal rules

it.number: fix ordinal rules


;; Copyright 2013-2016 Andrey Antukh <niwi@niwi.nz>
;;
;; Licensed 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 buddy.auth.accessrules
  "Access Rules system for ring based applications."
  (:require [buddy.auth :refer [throw-unauthorized]]
            [buddy.auth.http :as http]
            [clojure.walk :refer [postwalk]]
            [clout.core :as clout]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rule Handler Protocol
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defprotocol IRuleHandlerResponse
  "Abstraction for uniform handling of rule handler return values.
  It comes with default implementation for nil and boolean types."
  (success? [_] "Check if a response is a success.")
  (get-value [_] "Get a handler response value."))

(extend-protocol IRuleHandlerResponse
  nil
  (success? [_] false)
  (get-value [_] nil)

  Boolean
  (success? [v] v)
  (get-value [_] nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rule Handler Response Type
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype RuleSuccess [v]
  IRuleHandlerResponse
  (success? [_] true)
  (get-value [_] v)

  Object
  (equals [self other]
    (if (instance? RuleSuccess other)
      (= v (.-v other))
      false))

  (toString [self]
    (with-out-str (print [v]))))

(deftype RuleError [v]
  IRuleHandlerResponse
  (success? [_] false)
  (get-value [_] v)

  Object
  (equals [self other]
    (if (instance? RuleError other)
      (= v (.-v other))
      false))

  (toString [self]
    (with-out-str (print [v]))))

(alter-meta! #'->RuleSuccess assoc :private true)
(alter-meta! #'->RuleError assoc :private true)

(defn success
  "Function that returns a success state
  from one access rule handler."
  ([] (RuleSuccess. nil))
  ([v] (RuleSuccess. v)))

(defn error
  "Function that returns a failure state
  from one access rule handler."
  ([] (RuleError. nil))
  ([v] (RuleError. v)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn compile-rule-handler
  "Receives a rule handler and returns a compiled version of it.

  The compiled version of a rule handler consists of
  one function that accepts a request as first parameter
  and returns the result of the evaluation of it.

  The rule can be a simple function or logical expression. Logical
  expression is expressed using a hashmap:

      {:or [f1 f2]}
      {:and [f1 f2]}

  Logical expressions can be nested as deep as you want:

      {:or [f1 {:and [f2 f3]}]}

  The rule handler as unit of work, should return a
  `success` or `error`. `success` is a simple mark that
  means that handler passes the validation and `error`
  is a mark that means that rule does not pass the
  validation.

  An error mark can return a ring response that will be
  returned to the http client or string message that will be
  passed to `on-error` handler if it exists, or returned as
  bad-request response with message as response body.

  Example of success marks:

  - `true`
  - `(success)`

  Example of error marks:

  - `nil`
  - `false`
  - `(error \"Error msg\")`
  - `(error {:status 400 :body \"Unauthorized\"})`
  "
  [rule]
  (postwalk (fn [form]
              (cond
               ;; In this case is a handler
               (fn? form)
               (fn [req] (form req))

               (:or form)
               (fn [req]
                 (let [rules (:or form)
                       evals (map (fn [x] (x req)) rules)
                       accepts (filter success? evals)]
                   (if (seq accepts)
                     (first accepts)
                     (last evals))))

               (:and form)
               (fn [req]
                 (let [rules (:and form)
                       evals (map (fn [x] (x req)) rules)
                       rejects (filter (complement success?) evals)]
                   (if (seq rejects)
                     (first rejects)
                     (first evals))))

               :else form))
            rule))

(defn- matches-request-method
  "Match the :request-method of `request` against `allowed` HTTP
  methods. `allowed` can be a keyword, a set of keywords or nil."
  [request allowed]
  (let [actual (:request-method request)]
    (cond
      (keyword? allowed)
      (= actual allowed)

      (set? allowed)
      (or (empty? allowed)
          (contains? allowed actual))

      :else true)))

(defn  compile-access-rule
  "Receives an access rule and returns a compiled version of it.

  The plain version of access rule consists of one hash-map with
  with `:uri` and `:handler` keys. `:uri` is a url match syntax
  that will be used for matching the url and `:handler` is a rule
  handler.

  Little overview of aspect of access rules:

      [{:uri \"/foo\"
        :handler user-access}
       {:uris [\"/bar\" \"/baz\"]
        :handler admin-access}]

  The clout library (https://github.com/weavejester/clout)
  for matching the `:uri`.

  It also has support for more advanced matching using plain
  regular expressions, which are matched against the full
  request uri:

      [{:pattern #\"^/foo$\"
        :handler user-access}

  An access rule can also match against certain HTTP methods, by using
  the `:request-method` option. `:request-method` can be a keyword or
  a set of keywords.

      [{:pattern #\"^/foo$\"
        :handler user-access
        :request-method :get}

  The compilation process consists in transforming the plain version
  into an optimized one in order to avoid unnecessary overhead to the
  request process time.

  The compiled version of access rule has a very similar format with
  the plain one. The difference is that `:handler` is a compiled
  version, and `:pattern` or `:uri` is replaced by matcher function.

  Little overview of aspect of compiled version of acces rule:

      [{:matcher #<accessrules$compile_access_rule$fn__13092$fn__13095...>
        :handler #<accessrules$compile_rule_handler$fn__14040$fn__14043...>
  "
  [accessrule]
  {:pre [(map? accessrule)]}
  (let [request-method (:request-method accessrule)
        handler (compile-rule-handler (:handler accessrule))
        matcher (cond
                  (:pattern accessrule)
                  (fn [request]
                    (let [pattern (:pattern accessrule)
                          uri (:uri request)]
                      (when (and (matches-request-method request request-method)
                                 (seq (re-matches pattern uri)))
                        {})))

                  (:uri accessrule)
                  (let [route (clout/route-compile (:uri accessrule))]
                    (fn [request]
                      (let [match-params (clout/route-matches route request)]
                        (when (and (matches-request-method request request-method) match-params)
                          match-params))))

                  (:uris accessrule)
                  (let [routes (mapv clout/route-compile (:uris accessrule))]
                    (fn [request]
                      (let [match-params (->> (map #(clout/route-matches % request) routes)
                                              (filter identity)
                                              (first))]
                        (when (and (matches-request-method request request-method) match-params)
                          match-params))))

                  :else (fn [request] {}))]
    (assoc accessrule
           :matcher matcher
           :handler handler)))

(defn compile-access-rules
  "Compile a list of access rules.

  For more information, see the docstring
  of `compile-access-rule` function."
  [accessrules]
  (mapv compile-access-rule accessrules))

(defn- match-access-rules
  "Iterates over all access rules and try to match each one
  in order. Return the first matched access rule or nil."
  [accessrules request]
  (reduce (fn [acc accessrule]
            (let [matcher (:matcher accessrule)
                  match-result (matcher request)]
              (when match-result
                (reduced (assoc accessrule :match-params match-result)))))
          nil
          accessrules))

(defn handle-error
  "Handles the error situation when access rules are
  evaluated in `wrap-access-rules` middleware.

  It receives a handler response (anything that rule handler may
  return), a current request and a hashmap passwd to the access
  rule definition.

  The received response has to satisfy the
  IRuleHandlerResponse protocol."
  {:no-doc true}
  [response request {:keys [reject-handler on-error redirect]}]
  {:pre [(satisfies? IRuleHandlerResponse response)]}
  (let [val (get-value response)]
    (cond
     (string? redirect)
     (http/redirect redirect)

     (fn? on-error)
     (on-error request val)

     (http/response? val)
     val

     (fn? reject-handler)
     (reject-handler request val)

     (string? val)
     (http/response val 400)

     :else
     (throw-unauthorized))))

(defn- apply-matched-access-rule
  "Simple helper that executes the rule handler
  of received access rule and returns the result."
  [match request]
  {:pre [(map? match)
         (contains? match :handler)]}
  (let [handler (:handler match)
        params  (:match-params match)]
    (-> request
        (assoc :match-params params)
        (handler))))

(defn wrap-access-rules
  "A ring middleware that helps to define access rules for
  ring handler.

  This is an example of access rules list that `wrap-access-rules`
  middleware expects:

      [{:uri \"/foo/*\"
        :handler user-access}
       {:uri \"/bar/*\"
        :handler {:or [user-access admin-access]}}
       {:uri \"/baz/*\"
        :handler {:and [user-access {:or [admin-access operator-access]}]}}]

  All access rules are evaluated in order and the process stops when
  a match is found.

  See docstring of `compile-rule-handler` for documentation
  about rule handlers."
  [handler & [{:keys [policy rules] :or {policy :allow} :as opts}]]
  (when (nil? rules)
    (throw (IllegalArgumentException. "rules should not be empty.")))
  (let [accessrules (compile-access-rules rules)]
    (fn [request]
      (if-let [match (match-access-rules accessrules request)]
        (let [res (apply-matched-access-rule match request)]
          (if (success? res)
           (handler request)
           (handle-error res request (merge opts match))))
        (case policy
          :allow (handler request)
          :reject (handle-error (error nil) request opts))))))

(defn restrict
  "Like `wrap-access-rules` middleware but works as
  decorator. It is intended to bw used with compojure routing
  library or similar. Example:

      (defn login-ctrl [req] ...)
      (defn admin-ctrl [req] ...)

      (defroutes app
        (ANY \"/login\" [] login-ctrl)
        (GET \"/admin\" [] (restrict admin-ctrl {:handler admin-access ;; Mandatory
                                                 :on-error my-reject-handler)

  This decorator allows using the same access rules but without
  any url matching algorithm, however it has the disadvantage of
  accoupling your routers code with access rules."
  [handler rule]
  (let [match (compile-access-rule rule)]
    (fn [request]
      (let [rsp (apply-matched-access-rule match request)]
        (if (success? rsp)
         (handler request)
         (handle-error rsp request rule))))))

;; Copyright 2013-2016 Andrey Antukh <niwi@niwi.nz>
;;
;; Licensed 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 buddy.auth.accessrules
  "Access Rules system for ring based applications."
  (:require [buddy.auth :refer [throw-unauthorized]]
            [buddy.auth.http :as http]
            [clojure.walk :refer [postwalk]]
            [clout.core :as clout]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rule Handler Protocol
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defprotocol IRuleHandlerResponse
  "Abstraction for uniform handling of rule handler return values.
  It comes with default implementation for nil and boolean types."
  (success? [_] "Check if a response is a success.")
  (get-value [_] "Get a handler response value."))

(extend-protocol IRuleHandlerResponse
  nil
  (success? [_] false)
  (get-value [_] nil)

  Boolean
  (success? [v] v)
  (get-value [_] nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rule Handler Response Type
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype RuleSuccess [v]
  IRuleHandlerResponse
  (success? [_] true)
  (get-value [_] v)

  Object
  (equals [self other]
    (if (instance? RuleSuccess other)
      (= v (.-v other))
      false))

  (toString [self]
    (with-out-str (print [v]))))

(deftype RuleError [v]
  IRuleHandlerResponse
  (success? [_] false)
  (get-value [_] v)

  Object
  (equals [self other]
    (if (instance? RuleError other)
      (= v (.-v other))
      false))

  (toString [self]
    (with-out-str (print [v]))))

(alter-meta! #'->RuleSuccess assoc :private true)
(alter-meta! #'->RuleError assoc :private true)

(defn success
  "Function that returns a success state
  from one access rule handler."
  ([] (RuleSuccess. nil))
  ([v] (RuleSuccess. v)))

(defn error
  "Function that returns a failure state
  from one access rule handler."
  ([] (RuleError. nil))
  ([v] (RuleError. v)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn compile-rule-handler
  "Receives a rule handler and returns a compiled version of it.

  The compiled version of a rule handler consists of
  one function that accepts a request as first parameter
  and returns the result of the evaluation of it.

  The rule can be a simple function or logical expression. Logical
  expression is expressed using a hashmap:

      {:or [f1 f2]}
      {:and [f1 f2]}

  Logical expressions can be nested as deep as you want:

      {:or [f1 {:and [f2 f3]}]}

  The rule handler as unit of work, should return a
  `success` or `error`. `success` is a simple mark that
  means that handler passes the validation and `error`
  is a mark that means that rule does not pass the
  validation.

  An error mark can return a ring response that will be
  returned to the http client or string message that will be
  passed to `on-error` handler if it exists, or returned as
  bad-request response with message as response body.

  Example of success marks:

  - `true`
  - `(success)`

  Example of error marks:

  - `nil`
  - `false`
  - `(error \"Error msg\")`
  - `(error {:status 400 :body \"Unauthorized\"})`
  "
  [rule]
  (postwalk (fn [form]
              (cond
               ;; In this case is a handler
               (fn? form)
               (fn [req] (form req))

               (:or form)
               (fn [req]
                 (let [rules (:or form)
                       evals (map (fn [x] (x req)) rules)
                       accepts (filter success? evals)]
                   (if (seq accepts)
                     (first accepts)
                     (last evals))))

               (:and form)
               (fn [req]
                 (let [rules (:and form)
                       evals (map (fn [x] (x req)) rules)
                       rejects (filter (complement success?) evals)]
                   (if (seq rejects)
                     (first rejects)
                     (first evals))))

               :else form))
            rule))

(defn- matches-request-method
  "Match the :request-method of `request` against `allowed` HTTP
  methods. `allowed` can be a keyword, a set of keywords or nil."
  [request allowed]
  (let [actual (:request-method request)]
    (cond
      (keyword? allowed)
      (= actual allowed)

      (set? allowed)
      (or (empty? allowed)
          (contains? allowed actual))

      :else true)))

(defn  compile-access-rule
  "Receives an access rule and returns a compiled version of it.

  The plain version of access rule consists of one hash-map with
  with `:uri` and `:handler` keys. `:uri` is a url match syntax
  that will be used for matching the url and `:handler` is a rule
  handler.

  Little overview of aspect of access rules:

      [{:uri \"/foo\"
        :handler user-access}
       {:uris [\"/bar\" \"/baz\"]
        :handler admin-access}]

  The clout library (https://github.com/weavejester/clout)
  for matching the `:uri`.

  It also has support for more advanced matching using plain
  regular expressions, which are matched against the full
  request uri:

      [{:pattern #\"^/foo$\"
        :handler user-access}

  An access rule can also match against certain HTTP methods, by using
  the `:request-method` option. `:request-method` can be a keyword or
  a set of keywords.

      [{:pattern #\"^/foo$\"
        :handler user-access
        :request-method :get}

  The compilation process consists in transforming the plain version
  into an optimized one in order to avoid unnecessary overhead to the
  request process time.

  The compiled version of access rule has a very similar format with
  the plain one. The difference is that `:handler` is a compiled
  version, and `:pattern` or `:uri` is replaced by matcher function.

  Little overview of aspect of compiled version of acces rule:

      [{:matcher #<accessrules$compile_access_rule$fn__13092$fn__13095...>
        :handler #<accessrules$compile_rule_handler$fn__14040$fn__14043...>
  "
  [accessrule]
  {:pre [(map? accessrule)]}
  (let [request-method (:request-method accessrule)
        handler (compile-rule-handler (:handler accessrule))
        matcher (cond
                  (:pattern accessrule)
                  (fn [request]
                    (let [pattern (:pattern accessrule)
                          uri (:uri request)]
                      (when (and (matches-request-method request request-method)
                                 (seq (re-matches pattern uri)))
                        {})))

                  (:uri accessrule)
                  (let [route (clout/route-compile (:uri accessrule))]
                    (fn [request]
                      (let [match-params (clout/route-matches route request)]
                        (when (and (matches-request-method request request-method) match-params)
                          match-params))))

                  (:uris accessrule)
                  (let [routes (mapv clout/route-compile (:uris accessrule))]
                    (fn [request]
                      (let [match-params (->> (map #(clout/route-matches % request) routes)
                                              (filter identity)
                                              (first))]
                        (when (and (matches-request-method request request-method) match-params)
                          match-params))))

                  :else (fn [request] {}))]
    (assoc accessrule
           :matcher matcher
           :handler handler)))

(defn compile-access-rules
  "Compile a list of access rules.

  For more information, see the docstring
  of `compile-access-rule` function."
  [accessrules]
  (mapv compile-access-rule accessrules))

(defn- match-access-rules
  "Iterates over all access rules and try to match each one
  in order. Return the first matched access rule or nil."
  [accessrules request]
  (reduce (fn [acc accessrule]
            (let [matcher (:matcher accessrule)
                  match-result (matcher request)]
              (when match-result
                (reduced (assoc accessrule :match-params match-result)))))
          nil
          accessrules))

(defn handle-error
  "Handles the error situation when access rules are
  evaluated in `wrap-access-rules` middleware.

  It receives a handler response (anything that rule handler may
  return), a current request and a hashmap passwd to the access
  rule definition.

  The received response has to satisfy the
  IRuleHandlerResponse protocol."
  {:no-doc true}
  [response request {:keys [reject-handler on-error redirect]}]
  {:pre [(satisfies? IRuleHandlerResponse response)]}
  (let [val (get-value response)]
    (cond
     (string? redirect)
     (http/redirect redirect)

     (fn? on-error)
     (on-error request val)

     (http/response? val)
     val

     (fn? reject-handler)
     (reject-handler request val)

     (string? val)
     (http/response val 400)

     :else
     (throw-unauthorized))))

(defn- apply-matched-access-rule
  "Simple helper that executes the rule handler
  of received access rule and returns the result."
  [match request]
  {:pre [(map? match)
         (contains? match :handler)]}
  (let [handler (:handler match)
        params  (:match-params match)]
    (-> request
        (assoc :match-params params)
        (handler))))

(defn wrap-access-rules
  "A ring middleware that helps to define access rules for
  ring handler.

  This is an example of access rules list that `wrap-access-rules`
  middleware expects:

      [{:uri \"/foo/*\"
        :handler user-access}
       {:uri \"/bar/*\"
        :handler {:or [user-access admin-access]}}
       {:uri \"/baz/*\"
        :handler {:and [user-access {:or [admin-access operator-access]}]}}]

  All access rules are evaluated in order and the process stops when
  a match is found.

  See docstring of `compile-rule-handler` for documentation
  about rule handlers."
  [handler & [{:keys [policy rules] :or {policy :allow} :as opts}]]
  (when (nil? rules)
    (throw (IllegalArgumentException. "rules should not be empty.")))
  (let [accessrules (compile-access-rules rules)]
    (fn [request]
      (if-let [match (match-access-rules accessrules request)]
        (let [res (apply-matched-access-rule match request)]
          (if (success? res)
           (handler request)
           (handle-error res request (merge opts match))))
        (case policy
          :allow (handler request)
          :reject (handle-error (error nil) request opts))))))

(defn restrict
  "Like `wrap-access-rules` middleware but works as
  decorator. It is intended to be used with compojure routing
  library or similar. Example:

      (defn login-ctrl [req] ...)
      (defn admin-ctrl [req] ...)

      (defroutes app
        (ANY \"/login\" [] login-ctrl)
        (GET \"/admin\" [] (restrict admin-ctrl {:handler admin-access ;; Mandatory
                                                 :on-error my-reject-handler)

  This decorator allows using the same access rules but without
  any url matching algorithm, however it has the disadvantage of
  accoupling your routers code with access rules."
  [handler rule]
  (let [match (compile-access-rule rule)]
    (fn [request]
      (let [rsp (apply-matched-access-rule match request)]
        (if (success? rsp)
         (handler request)
         (handle-error rsp request rule))))))

Fix speling error

Fix speling error