(ns akvo.lumen.admin.add-tenant
  "The following env vars are assumed to be present:
  KC_URL, KC_SECRET, PG_HOST, PG_DATABASE, PG_USER, PG_PASSWORD
  The PG_* env vars can be found in the ElephantSQL console for the appropriate
  instance. KC_URL is the url to keycloak (without trailing /auth).
  KC_SECRET is the client secret found in the Keycloak admin at
  > Realms > Akvo > Clients > akvo-lumen-confidential > Credentials > Secret.
  Use this as follow
  $ env KC_URL=https://*** KC_SECRET=*** \\
        PG_HOST=***.db.elephantsql.com PG_DATABASE=*** \\
        PG_USER=*** PG_PASSWORD=*** \\
        lein run -m akvo.lumen.admin.add-tenant <url> <title> <email>
  KC_URL is probably one of:
  - http://localhost:8080 for local development
  - https://login.akvo.org for production
  - https://kc.akvotest.org for the test environment"
  (:require [akvo.lumen.admin.util :as util]
            [akvo.lumen.config :refer [error-msg]]
            [akvo.lumen.component.keycloak :as keycloak]
            [akvo.lumen.lib.share-impl :refer [random-url-safe-string]]
            [akvo.lumen.util :refer [conform-email squuid]]
            [cheshire.core :as json]
            [clj-http.client :as client]
            [clojure.java.browse :as browse]
            [clojure.java.jdbc :as jdbc]
            [clojure.pprint :refer [pprint]]
            [clojure.set :as set]
            [clojure.string :as s]
            [environ.core :refer [env]]
            [ragtime.jdbc]
            [ragtime.repl])
  (:import java.net.URL))

(def blacklist ["admin"
                "deck"
                "ftp"
                "mail"
                "next"
                "smtp"
                "stage"
                "test"
                "www"])

(defn conform-label
  "First fence on label names, uniques are enforced in db."
  [label]
  (cond
    (< (count label) 3)
    (throw
     (ex-info "Too short label, should be 3 or more characters."
              {:label label}))

    (> (count label) 30)
    (throw
     (ex-info "Too long label, should be less than 30 or more characters."
              {:label label}))

    (contains? (set blacklist) label)
    (throw
     (ex-info (format "Label in blacklist: [%s]"
                      (s/join ", "  blacklist))
              {:label label}))

    (not (Character/isLetter (get label 0)))
    (throw
     (ex-info "First letter should be a character"
              {:label label}))

    (nil? (re-matches #"^[a-z0-9\-]+" label))
    (throw
     (ex-info "Label is only allowed to be a-z 0-9 or hyphen"
              {:label label}))

    :else label))

(defn label [url]
  (-> url
      (s/split #"//")
      second
      (s/split #"\.")
      first
      conform-label))

(defn conform-url
  "Make sure https is used for non development mode and remove trailing slash."
  [v]
  (let [url (URL. v)]
    (if (= (:kc-url env) "http://localhost:8080")
      (when (= (.getProtocol url) "https")
        (throw (ex-info "Use http in development mode" {:url v})))
      (when (= (.getProtocol url) "https")
        (throw (ex-info "Url should use https" {:url v}))))
    (format "%s://%s" (.getProtocol url) (.getHost url))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Database
;;;

(defn migrate-tenant [db-uri]
  (ragtime.repl/migrate
   {:datastore (ragtime.jdbc/sql-database db-uri)
    :migrations (ragtime.jdbc/load-resources "akvo/lumen/migrations/tenants")}))

(defn setup-database
  [label title]
  (let [tenant (str "tenant_" label)
        tenant-password (s/replace (squuid) "-" "")
        db-uri (util/db-uri)
        lumen-db-uri (util/db-uri {:database "lumen" :user "lumen"})
        tenant-db-uri (util/db-uri {:database tenant :user tenant :password tenant-password})
        tenant-db-uri-with-superuser (util/db-uri {:database tenant})]
    (util/exec! db-uri "CREATE ROLE %s WITH PASSWORD '%s' LOGIN;" tenant tenant-password)
    (util/exec! db-uri
                (str "CREATE DATABASE %1$s "
                     "WITH OWNER = %1$s "
                     "TEMPLATE = template0 "
                     "ENCODING = 'UTF8' "
                     "LC_COLLATE = 'en_US.UTF-8' "
                     "LC_CTYPE = 'en_US.UTF-8';")
                tenant)
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS btree_gist WITH SCHEMA public;")
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS pgcrypto WITH SCHEMA public;")
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS tablefunc WITH SCHEMA public;")
    (jdbc/insert! lumen-db-uri :tenants {:db_uri tenant-db-uri :label label :title title})
    (migrate-tenant tenant-db-uri)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keycloak
;;;

(defn root-group-id
  "Returns the id of group on path akvo/lumen"
  [request-headers api-root]
  (-> (client/get (format "%s/group-by-path/%s" api-root "akvo/lumen")
                  {:headers request-headers})
      :body json/decode (get "id")))

(defn create-group
  [request-headers api-root root-group-id role group-name]
  (client/post (format "%s/roles" api-root)
               {:body (json/encode {"name" role})
                :headers request-headers})
  (let [new-group-id (-> (client/post
                          (format "%s/groups/%s/children"
                                  api-root root-group-id)
                          {:body (json/encode {"name" group-name})
                           :headers request-headers})
                         :body json/decode (get "id"))
        available-roles (-> (client/get
                             (format "%s/groups/%s/role-mappings/realm/available"
                                     api-root root-group-id)
                             {:headers request-headers})
                            :body json/decode)
        role-id (-> (filter #(= role (get % "name"))
                            available-roles)
                    first
                    (get "id"))
        pair-resp (client/post
                   (format "%s/groups/%s/role-mappings/realm" api-root new-group-id)
                   {:body (json/encode [{"id" role-id
                                         "name" role
                                         "scopeParamRequired" false
                                         "composite" false
                                         "clientRole" false
                                         "containerId" "Akvo"}])
                    :headers request-headers})]
    new-group-id))

(defn create-new-user
  "Creates a new user and return a map containing email, and
   new user-id and temporary password."
  [request-headers api-root email]
  (let [tmp-password (random-url-safe-string 6)
        user-id (-> (client/post (format "%s/users" api-root)
                                 {:body (json/encode
                                         {"username" email
                                          "email" email
                                          "emailVerified" false
                                          "enabled" true})
                                  :headers request-headers})
                    (get-in [:headers "Location"])
                    (s/split #"/")
                    last)]
    (client/put (format "%s/users/%s/reset-password" api-root user-id)
                {:body (json/encode {"temporary" true
                                     "type" "password"
                                     "value" tmp-password})
                 :headers request-headers})
    {:email email
     :user-id user-id
     :tmp-password tmp-password}))

(defn user-representation
  [request-headers api-root email]
  (if-let [user (keycloak/fetch-user-by-email request-headers api-root email)]
    {:email email
     :user-id (get user "id")}
    (create-new-user request-headers api-root email)))

(defn fetch-client
  [request-headers api-root client-id]
  (-> (client/get (format "%s/clients" api-root)
                  {:query-params {"clientId" client-id}
                   :headers request-headers})
      :body json/decode first))

(defn update-client
  [request-headers api-root {:strs [id] :as client}]
  (client/put (format "%s/clients/%s" api-root id)
                {:body (json/encode client)
                 :headers request-headers}))

(defn add-tenant-urls-to-client
  [client url]
  (-> client
      (update "webOrigins" conj url)
      (update "redirectUris" conj (format "%s/*" url))))

(defn add-tenant-urls-to-clients
  [{:keys [api-root]} request-headers url]
  (let [confidential-client (fetch-client request-headers api-root "akvo-lumen-confidential")
        public-client (fetch-client request-headers api-root "akvo-lumen")]
    (update-client request-headers api-root
                   (add-tenant-urls-to-client confidential-client url))
    (update-client request-headers api-root
                   (add-tenant-urls-to-client public-client url))))

(defn setup-tenant-in-keycloak
  "Create two new groups as children to the akvo:lumen group"
  [label email url]
  (let [{:keys [api-root] :as kc} (util/create-keycloak)
        request-headers (keycloak/request-headers kc)
        lumen-group-id (root-group-id request-headers api-root)
        tenant-id (create-group request-headers api-root lumen-group-id
                                (format "akvo:lumen:%s" label) label)
        tenant-admin-id (create-group request-headers api-root tenant-id
                                      (format "akvo:lumen:%s:admin" label)
                                      "admin")
        {:keys [user-id email tmp-password] :as user-rep}
        (user-representation request-headers api-root email)]
    (add-tenant-urls-to-clients kc request-headers url)
    (keycloak/add-user-to-group request-headers api-root user-id tenant-admin-id)
    (assoc user-rep :url url)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Main
;;;

(defn conform-input [url title email]
  (let [url (conform-url url)]
    {:email (conform-email email)
     :label (label url)
     :title title
     :url url}))

(defn check-env-vars []
  (assert (:kc-url env) (error-msg "Specify KC_URL env var"))
  (assert (:kc-secret env)
          (do
            (browse/browse-url
             (format "%s/auth/admin/master/console/#/realms/akvo/clients" (:kc-url env)))
            (error-msg "Specify KC_SECRET env var from the Keycloak admin opened in the browser window at Client (akvo-lumen-confidential) -> Credentials -> Secret.")))
  (assert (:pg-host env) (error-msg "Specify PG_HOST env var"))
  (assert (:pg-database env) (error-msg "Specify PG_DATABASE env var"))
  (assert (:pg-user env) (error-msg "Specify PG_USER env var"))
  (when (not (= (:pg-host env) "localhost"))
    (assert (:pg-password env) (error-msg "Specify PG_PASSWORD env var"))))

(defn -main [url title email]
  (try
    (check-env-vars)
    (let [{:keys [email label title url]} (conform-input url title email)]
      (setup-database label title)
      (let [user-creds (setup-tenant-in-keycloak label email url)]
        (println "Credentials:")
        (pprint user-creds)))
    (catch java.lang.AssertionError e
      (prn (.getMessage e)))
    (catch Exception e
      (prn e)
      (prn (.getMessage e))
      (when (= (type e) clojure.lang.ExceptionInfo)
        (prn (ex-data e))))))

(ns akvo.lumen.admin.add-tenant
  "The following env vars are assumed to be present:
  KC_URL, KC_SECRET, PG_HOST, PG_DATABASE, PG_USER, PG_PASSWORD
  The PG_* env vars can be found in the ElephantSQL console for the appropriate
  instance. KC_URL is the url to keycloak (without trailing /auth).
  KC_SECRET is the client secret found in the Keycloak admin at
  > Realms > Akvo > Clients > akvo-lumen-confidential > Credentials > Secret.
  Use this as follow
  $ env KC_URL=https://*** KC_SECRET=*** \\
        PG_HOST=***.db.elephantsql.com PG_DATABASE=*** \\
        PG_USER=*** PG_PASSWORD=*** \\
        lein run -m akvo.lumen.admin.add-tenant <url> <title> <email>
  KC_URL is probably one of:
  - http://localhost:8080 for local development
  - https://login.akvo.org for production
  - https://kc.akvotest.org for the test environment"
  (:require [akvo.lumen.admin.util :as util]
            [akvo.lumen.component.keycloak :as keycloak]
            [akvo.lumen.config :refer [error-msg]]
            [akvo.lumen.lib.share-impl :refer [random-url-safe-string]]
            [akvo.lumen.util :refer [conform-email squuid]]
            [cheshire.core :as json]
            [clj-http.client :as client]
            [clojure.java.browse :as browse]
            [clojure.java.jdbc :as jdbc]
            [clojure.pprint :refer [pprint]]
            [clojure.set :as set]
            [clojure.string :as s]
            [environ.core :refer [env]]
            [ragtime.jdbc]
            [ragtime.repl])
  (:import java.net.URL))

(def blacklist ["admin"
                "deck"
                "ftp"
                "mail"
                "next"
                "smtp"
                "stage"
                "test"
                "www"])

(defn conform-label
  "First fence on label names, uniques are enforced in db."
  [label]
  (cond
    (< (count label) 3)
    (throw
     (ex-info "Too short label, should be 3 or more characters."
              {:label label}))

    (> (count label) 30)
    (throw
     (ex-info "Too long label, should be less than 30 or more characters."
              {:label label}))

    (contains? (set blacklist) label)
    (throw
     (ex-info (format "Label in blacklist: [%s]"
                      (s/join ", "  blacklist))
              {:label label}))

    (not (Character/isLetter (get label 0)))
    (throw
     (ex-info "First letter should be a character"
              {:label label}))

    (nil? (re-matches #"^[a-z0-9\-]+" label))
    (throw
     (ex-info "Label is only allowed to be a-z 0-9 or hyphen"
              {:label label}))

    :else label))

(defn label [url]
  (-> url
      (s/split #"//")
      second
      (s/split #"\.")
      first
      conform-label))

(defn conform-url
  "Make sure https is used for non development mode and remove trailing slash."
  [v]
  (let [url (URL. v)]
    (if (= (:kc-url env) "http://localhost:8080")
      (when (= (.getProtocol url) "https")
        (throw (ex-info "Use http in development mode" {:url v})))
      (when (not= (.getProtocol url) "https")
        (throw (ex-info "Url should use https" {:url v}))))
    (format "%s://%s" (.getProtocol url) (.getHost url))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Database
;;;

(defn migrate-tenant [db-uri]
  (ragtime.repl/migrate
   {:datastore (ragtime.jdbc/sql-database db-uri)
    :migrations (ragtime.jdbc/load-resources "akvo/lumen/migrations/tenants")}))

(defn setup-database
  [label title]
  (let [tenant (str "tenant_" label)
        tenant-password (s/replace (squuid) "-" "")
        db-uri (util/db-uri)
        lumen-db-uri (util/db-uri {:database "lumen" :user "lumen"})
        tenant-db-uri (util/db-uri {:database tenant :user tenant :password tenant-password})
        tenant-db-uri-with-superuser (util/db-uri {:database tenant})]
    (util/exec! db-uri "CREATE ROLE %s WITH PASSWORD '%s' LOGIN;" tenant tenant-password)
    (util/exec! db-uri
                (str "CREATE DATABASE %1$s "
                     "WITH OWNER = %1$s "
                     "TEMPLATE = template0 "
                     "ENCODING = 'UTF8' "
                     "LC_COLLATE = 'en_US.UTF-8' "
                     "LC_CTYPE = 'en_US.UTF-8';")
                tenant)
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS btree_gist WITH SCHEMA public;")
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS pgcrypto WITH SCHEMA public;")
    (util/exec! tenant-db-uri-with-superuser
                "CREATE EXTENSION IF NOT EXISTS tablefunc WITH SCHEMA public;")
    (jdbc/insert! lumen-db-uri :tenants {:db_uri tenant-db-uri :label label :title title})
    (migrate-tenant tenant-db-uri)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keycloak
;;;

(defn root-group-id
  "Returns the id of group on path akvo/lumen"
  [request-headers api-root]
  (-> (client/get (format "%s/group-by-path/%s" api-root "akvo/lumen")
                  {:headers request-headers})
      :body json/decode (get "id")))

(defn create-group
  [request-headers api-root root-group-id role group-name]
  (client/post (format "%s/roles" api-root)
               {:body (json/encode {"name" role})
                :headers request-headers})
  (let [new-group-id (-> (client/post
                          (format "%s/groups/%s/children"
                                  api-root root-group-id)
                          {:body (json/encode {"name" group-name})
                           :headers request-headers})
                         :body json/decode (get "id"))
        available-roles (-> (client/get
                             (format "%s/groups/%s/role-mappings/realm/available"
                                     api-root root-group-id)
                             {:headers request-headers})
                            :body json/decode)
        role-id (-> (filter #(= role (get % "name"))
                            available-roles)
                    first
                    (get "id"))
        pair-resp (client/post
                   (format "%s/groups/%s/role-mappings/realm" api-root new-group-id)
                   {:body (json/encode [{"id" role-id
                                         "name" role
                                         "scopeParamRequired" false
                                         "composite" false
                                         "clientRole" false
                                         "containerId" "Akvo"}])
                    :headers request-headers})]
    new-group-id))

(defn create-new-user
  "Creates a new user and return a map containing email, and
   new user-id and temporary password."
  [request-headers api-root email]
  (let [tmp-password (random-url-safe-string 6)
        user-id (-> (client/post (format "%s/users" api-root)
                                 {:body (json/encode
                                         {"username" email
                                          "email" email
                                          "emailVerified" false
                                          "enabled" true})
                                  :headers request-headers})
                    (get-in [:headers "Location"])
                    (s/split #"/")
                    last)]
    (client/put (format "%s/users/%s/reset-password" api-root user-id)
                {:body (json/encode {"temporary" true
                                     "type" "password"
                                     "value" tmp-password})
                 :headers request-headers})
    {:email email
     :user-id user-id
     :tmp-password tmp-password}))

(defn user-representation
  [request-headers api-root email]
  (if-let [user (keycloak/fetch-user-by-email request-headers api-root email)]
    {:email email
     :user-id (get user "id")}
    (create-new-user request-headers api-root email)))

(defn fetch-client
  [request-headers api-root client-id]
  (-> (client/get (format "%s/clients" api-root)
                  {:query-params {"clientId" client-id}
                   :headers request-headers})
      :body json/decode first))

(defn update-client
  [request-headers api-root {:strs [id] :as client}]
  (client/put (format "%s/clients/%s" api-root id)
                {:body (json/encode client)
                 :headers request-headers}))

(defn add-tenant-urls-to-client
  [client url]
  (-> client
      (update "webOrigins" conj url)
      (update "redirectUris" conj (format "%s/*" url))))

(defn add-tenant-urls-to-clients
  [{:keys [api-root]} request-headers url]
  (let [confidential-client (fetch-client request-headers api-root "akvo-lumen-confidential")
        public-client (fetch-client request-headers api-root "akvo-lumen")]
    (update-client request-headers api-root
                   (add-tenant-urls-to-client confidential-client url))
    (update-client request-headers api-root
                   (add-tenant-urls-to-client public-client url))))

(defn setup-tenant-in-keycloak
  "Create two new groups as children to the akvo:lumen group"
  [label email url]
  (let [{:keys [api-root] :as kc} (util/create-keycloak)
        request-headers (keycloak/request-headers kc)
        lumen-group-id (root-group-id request-headers api-root)
        tenant-id (create-group request-headers api-root lumen-group-id
                                (format "akvo:lumen:%s" label) label)
        tenant-admin-id (create-group request-headers api-root tenant-id
                                      (format "akvo:lumen:%s:admin" label)
                                      "admin")
        {:keys [user-id email tmp-password] :as user-rep}
        (user-representation request-headers api-root email)]
    (add-tenant-urls-to-clients kc request-headers url)
    (keycloak/add-user-to-group request-headers api-root user-id tenant-admin-id)
    (assoc user-rep :url url)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Main
;;;

(defn conform-input [url title email]
  (let [url (conform-url url)]
    {:email (conform-email email)
     :label (label url)
     :title title
     :url url}))

(defn check-env-vars []
  (assert (:kc-url env) (error-msg "Specify KC_URL env var"))
  (assert (:kc-secret env)
          (do
            (browse/browse-url
             (format "%s/auth/admin/master/console/#/realms/akvo/clients" (:kc-url env)))
            (error-msg "Specify KC_SECRET env var from the Keycloak admin opened in the browser window at Client (akvo-lumen-confidential) -> Credentials -> Secret.")))
  (assert (:pg-host env) (error-msg "Specify PG_HOST env var"))
  (assert (:pg-database env) (error-msg "Specify PG_DATABASE env var"))
  (assert (:pg-user env) (error-msg "Specify PG_USER env var"))
  (when (not (= (:pg-host env) "localhost"))
    (assert (:pg-password env) (error-msg "Specify PG_PASSWORD env var"))))

(defn -main [url title email]
  (try
    (check-env-vars)
    (let [{:keys [email label title url]} (conform-input url title email)]
      (setup-database label title)
      (let [user-creds (setup-tenant-in-keycloak label email url)]
        (println "Credentials:")
        (pprint user-creds)))
    (catch java.lang.AssertionError e
      (prn (.getMessage e)))
    (catch Exception e
      (prn e)
      (prn (.getMessage e))
      (when (= (type e) clojure.lang.ExceptionInfo)
        (prn (ex-data e))))))

Fix add-tenant regression

[#875] Fix add-tenant regression


(ns akvo.lumen.import.csv-test
  {:functional true}
  (:require [akvo.lumen.fixtures :refer [*tenant-conn*
                                         tenant-conn-fixture]]
            [akvo.lumen.test-utils :refer [import-file]]
            [clojure.string :as string]
            [clojure.test :refer :all]
            [hugsql.core :as hugsql]))

(hugsql/def-db-fns "akvo/lumen/job-execution.sql")
(hugsql/def-db-fns "akvo/lumen/transformation.sql")

(use-fixtures :once tenant-conn-fixture)

(deftest ^:functional test-dos-file
  (testing "Import of DOS-formatted CSV file"
    (try
      (let [dataset-id (import-file *tenant-conn* "dos.csv" {:dataset-name "DOS data"})
            dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                  :version 1})]
        (is (= 2 (count (:columns dataset)))))
      (catch Exception e
        (.printStackTrace (.getCause e))))))

(deftest ^:functional test-mixed-columns
  (testing "Import of mixed-type data"
    (let [dataset-id (import-file *tenant-conn* "mixed-columns.csv" {:dataset-name "Mixed Columns"})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          columns (:columns dataset)]
      (is (= "text" (get (first columns) "type")))
      (is (= "number" (get (second columns) "type")))
      (is (= "text" (get (last columns) "type"))))))

(deftest ^:functional test-geoshape-csv
  (testing "Import csv file generated from a shapefile"
    (let [dataset-id (import-file *tenant-conn* "liberia_adm2.csv" {:dataset-name "Liberia shapefile"
                                                                    :has-column-headers? true})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          columns (:columns dataset)]
      (is (= "geoshape" (get (first columns) "type")))
      (is (= "number" (get (second columns) "type")))
      (is (= "text" (get (last columns) "type")))
      (is (= (count columns) 15)))))

(deftest ^:functional test-varying-column-count
  (testing "Should fail to import csv file with varying number of columns"
    (is (thrown-with-msg? clojure.lang.ExceptionInfo
                          #"Invalid csv file. Varying number of columns"
                          (import-file *tenant-conn* "mixed-column-counts.csv"
                                       {:dataset-name "Mixed Column Counts"})))))

(deftest ^:functional test-trimmed-columns
  (testing "Testing if whitespace is removed from beginning & end of column titles"
    (let [dataset-id (import-file *tenant-conn* "whitespace.csv" {:dataset-name "Padded titles"})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          titles (map :title (:rows dataset))
          trimmable? #(or (string/starts-with? " " %) (string/ends-with? " " %))]
      (is (not (every? trimmable? titles))))))

(ns akvo.lumen.import.csv-test
  {:functional true}
  (:require [akvo.lumen.fixtures :refer [*tenant-conn*
                                         tenant-conn-fixture]]
            [akvo.lumen.test-utils :refer [import-file]]
            [clojure.string :as string]
            [clojure.test :refer :all]
            [hugsql.core :as hugsql]))

(hugsql/def-db-fns "akvo/lumen/job-execution.sql")
(hugsql/def-db-fns "akvo/lumen/transformation.sql")

(use-fixtures :once tenant-conn-fixture)

(deftest ^:functional test-dos-file
  (testing "Import of DOS-formatted CSV file"
    (try
      (let [dataset-id (import-file *tenant-conn* "dos.csv" {:dataset-name "DOS data"})
            dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                  :version 1})]
        (is (= 2 (count (:columns dataset)))))
      (catch Exception e
        (.printStackTrace (.getCause e))))))

(deftest ^:functional test-mixed-columns
  (testing "Import of mixed-type data"
    (let [dataset-id (import-file *tenant-conn* "mixed-columns.csv" {:dataset-name "Mixed Columns"})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          columns (:columns dataset)]
      (is (= "text" (get (first columns) "type")))
      (is (= "number" (get (second columns) "type")))
      (is (= "text" (get (last columns) "type"))))))

(deftest ^:functional test-geoshape-csv
  (testing "Import csv file generated from a shapefile"
    (let [dataset-id (import-file *tenant-conn* "liberia_adm2.csv" {:dataset-name "Liberia shapefile"
                                                                    :has-column-headers? true})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          columns (:columns dataset)]
      (is (= "geoshape" (get (first columns) "type")))
      (is (= "number" (get (second columns) "type")))
      (is (= "text" (get (last columns) "type")))
      (is (= (count columns) 15)))))

(deftest ^:functional test-varying-column-count
  (testing "Should fail to import csv file with varying number of columns"
    (is (thrown-with-msg? clojure.lang.ExceptionInfo
                          #"Invalid csv file. Varying number of columns"
                          (import-file *tenant-conn* "mixed-column-counts.csv"
                                       {:dataset-name "Mixed Column Counts"})))))

(deftest ^:functional test-trimmed-columns
  (testing "Testing if whitespace is removed from beginning & end of column titles"
    (let [dataset-id (import-file *tenant-conn* "whitespace.csv" {:dataset-name "Padded titles"})
          dataset (dataset-version-by-dataset-id *tenant-conn* {:dataset-id dataset-id
                                                                :version 1})
          titles (map :title (:rows dataset))
          trimmable? #(or (string/starts-with? " " %) (string/ends-with? " " %))]
      (is (every? trimmable? titles)))))

Fix test case - trimmable titles

[#1276] Fix test case - trimmable titles


(ns zaffre.imageutil
  (:require [clojure.java.io :as jio]
            [taoensso.timbre :as log]
            [clojure.test :refer [is]])
  (:import (java.lang AutoCloseable)
           (java.nio ByteBuffer)
           (org.apache.commons.io IOUtils)
           (org.lwjgl BufferUtils)
           (org.lwjgl.glfw GLFWImage GLFWImage$Buffer)
           (org.lwjgl.stb STBImage STBImageResize STBImageWrite)
           (de.matthiasmann.twl.utils PNGDecoder PNGDecoder$Format)))

(defprotocol Dimensions
  (width [this])
  (height [this]))

(defrecord Image [width height channels byte-buffer]
  Dimensions
  (width [_] width)
  (height [_] height)
  AutoCloseable
  (close [_]
    (STBImage/stbi_image_free byte-buffer)))

#_(defmacro close-> [x & forms]
  (close-threaded `(-> ~x ~@forms)))

#_(defn close-threaded
  "Works like img-> but calls (.close) on the input image as well as
   all intermediate images. The result is not automatically closed so
   with-open should be used.
   (with-open [img (load-image \"my.img\")]
     (img-> img
       (scale 2)
       (copy-channel :green)
       (write-png \"out.png\")))"
  {:added "1.0"}
  [f img-form & args]
    (if
    (reduce (fn [forms form]
      `(with-open [img# ~form]
         ~@forms))
      threaded)))

(defn image
  ([width height]
    (image width height 4))
  ([width height channels]
    (log/info "Creating buffer" width height channels)
    (->Image width height channels (BufferUtils/createByteBuffer (* width height channels)))))

(defn load-image [location]
  (let [w           (BufferUtils/createIntBuffer 1)
        h           (BufferUtils/createIntBuffer 1)
        c           (BufferUtils/createIntBuffer 1)
        buffer      (->
                      location
                      jio/input-stream
                      IOUtils/toByteArray
                      ByteBuffer/wrap)
        direct-buffer (BufferUtils/createByteBuffer (.limit buffer))]
    (doto direct-buffer
      (.put buffer)
      (.flip))
    (let [byte-buffer (STBImage/stbi_load_from_memory direct-buffer w h c 0)
          width       (.get w)
          height      (.get h)
          channels    (.get c)]
      (log/info "loaded image" location width "x" height channels)
      (->Image width height channels byte-buffer))))

(defn write-png [{:keys [width height channels byte-buffer] :as img} path]
  (STBImageWrite/stbi_write_png path width height channels byte-buffer 0)
  img)

(defn scale [{:keys [width height channels byte-buffer]} ^long s]
  (let [scaled-bytes (BufferUtils/createByteBuffer (* (* s width)
                                                      (* s height)
                                                      channels))]
    (when (zero?
            (STBImageResize/stbir_resize_uint8_generic
              byte-buffer width height 0
              scaled-bytes (* s width) (* s height) 0
              channels
              (if (= channels 4)
                3
                STBImageResize/STBIR_ALPHA_CHANNEL_NONE)
              0
              STBImageResize/STBIR_EDGE_ZERO
              STBImageResize/STBIR_FILTER_BOX
              STBImageResize/STBIR_COLORSPACE_LINEAR))
      (throw (RuntimeException. "Error scaling image")))
    (log/info "scaled-bytes" scaled-bytes)
    (->Image (* s width) (* s height) channels scaled-bytes)))

(defn copy-buffer-range! [dest src n]
  (when (pos? n)
    (let [slice (.limit (.slice src) n)]
      (.put dest slice))))

(defn copy-sub-image [{dwidth :width dheight :height dchannels :channels dbytes :byte-buffer :as dimg}
                      {swidth :width sheight :height schannels :channels sbytes :byte-buffer :as simg}
                      dx1 dy1 sx1 sy1 sx2 sy2]
  {:pre [(is (= dchannels schannels) (format "%s and %s differ in channels" dimg simg))]}
  ;; for each line
  (doseq [y (range (- sy2 sy1))
          :let [sidx (* (+ sx1 (* (+ y sy1) swidth)) schannels)
                didx (* (+ dx1 (* (+ y dy1) dwidth)) dchannels)]
          :when (and (< -1 didx (.limit dbytes))
                     (< -1 sidx (.limit sbytes)))]
      (.position dbytes didx)
      (.position sbytes sidx)
      (copy-buffer-range! dbytes sbytes (* (- sx2 sx1) schannels)))
  (.position sbytes (* swidth sheight schannels))
  (.position dbytes (* dwidth dheight dchannels))
  (.flip sbytes)
  (.flip dbytes)
  dimg)

(defn clip [min-v v max-v]
  (max min-v (min v max-v)))

(defn draw-image [{dwidth :width dheight :height :as dest-img}
                  {swidth :width sheight :height :as src-img}
                  x y]
  (let [;; source corner in dest coord-space
        sx1       (+ x swidth)
        sy1       (+ y sheight)
        ;; clip x and y to dest rect
        clipped-x (clip 0 x dwidth)
        clipped-y (clip 0 y dheight)
        ;; convert clipped xy to src coords
        sx0    (- clipped-x x)
        sy0    (- clipped-y y)

        ;; clip src corner
        clipped-x1 (clip 0 sx1 dwidth)
        clipped-y1 (clip 0 sy1 dheight)
        ;; convert clipped corder to src coords
        sx1    (- clipped-x1 x)
        sy1    (- clipped-y1 y)
        ;; find src width/height
        width  (- x swidth)
        height (- y sheight)]
    (log/info "copying from [" sx0 sy0 "] [" sx1 sy1 "] to" x y)
    (copy-sub-image dest-img src-img x y sx0 sy0 sx1 sy1)))

(defn resize [{swidth :width sheight :height :as img} width height]
  (copy-sub-image (image width height)
                  img
                  0 0
                  0 0
                  swidth sheight))
(defn- num-channels [k]
  (case k
    :grayscale 1
    :rgb       3
    :rgba      4
    (assert (str "Unknown image type" k))))

(defmulti mode (fn [{:keys [channels]} m]
                 (case [channels m]
                   [1 :grayscale]
                     :nop
                   [1 :rgb]
                     :grayscale->rgb
                   [1 :rgba]
                     :grayscale->rgba
                   [3 :grayscale]
                     :rgb->grayscale
                   [3 :rgb]
                     :nop
                   [3 :rgba]
                     :rgb->rgba
                   [4 :rgb]
                     :rgba->rgb
                   [4 :rgba]
                     :nop)))

(defmethod mode :nop [img _] img)

(defmethod mode :rgb->grayscale
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)]
        (.put dest-buffer (byte (quot (+ r g b) 3)))))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :grayscale->rgb
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (.limit byte-buffer))]
      (let [v (.get byte-buffer)]
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :grayscale->rgba
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (.limit byte-buffer))]
      (let [v (.get byte-buffer)]
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :rgb->rgba
  [{:keys [width height channels byte-buffer]} image-type]
  (log/info "rgb->rgba")
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (log/info "dest-buffer" dest-buffer)
    (log/info "pixels" (quot (.limit byte-buffer) channels))
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)]
        (.put dest-buffer r)
        (.put dest-buffer g)
        (.put dest-buffer b)
        (.put dest-buffer (byte 0))))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :rgba->rgb
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)
            a (.get byte-buffer)]
        (.put dest-buffer r)
        (.put dest-buffer g)
        (.put dest-buffer b)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defn- skip [buffer n]
  (.position buffer (+ (.position buffer) n)))

(defn- copy-channel [v channel]
  (let [channel-shift (case channel
                       :alpha 24
                       :blue  16
                       :green  8
                       :red    0)
        c (->
            (bit-shift-left 0xFF channel-shift)
            (bit-and v)
            (unsigned-bit-shift-right channel-shift))]
    (reduce (fn [a n] (bit-or a (bit-shift-left c n))) 0 [24 16 8 0])))

(defn copy-channels [{:keys [width height channels byte-buffer]} channel]
  (let [img           (image width height)
        result-buffer (BufferUtils/createByteBuffer (* width height channels))]
    (doseq [x (range width)
            y (range height)]
      (let [c (case channel
                :red   0
                :green 1
                :blue  2
                :alpha 3)]
      (skip byte-buffer c)
      (let [v (.get byte-buffer)]
        (dotimes [_ channels]
          (.put result-buffer v)))
      (skip byte-buffer (dec (- channels c)))))
    (.flip byte-buffer)
    (.flip result-buffer)
    (log/info "copy-channels" result-buffer)
    (->Image width height channels result-buffer)))

(ns zaffre.imageutil
  (:require [clojure.java.io :as jio]
            [taoensso.timbre :as log]
            [clojure.test :refer [is]])
  (:import (java.lang AutoCloseable)
           (java.nio ByteBuffer)
           (org.apache.commons.io IOUtils)
           (org.lwjgl BufferUtils)
           (org.lwjgl.glfw GLFWImage GLFWImage$Buffer)
           (org.lwjgl.stb STBImage STBImageResize STBImageWrite)
           (de.matthiasmann.twl.utils PNGDecoder PNGDecoder$Format)))

(defprotocol Dimensions
  (width [this])
  (height [this]))

(defrecord Image [width height channels byte-buffer]
  Dimensions
  (width [_] width)
  (height [_] height)
  AutoCloseable
  (close [_]
    (STBImage/stbi_image_free byte-buffer)))

#_(defmacro close-> [x & forms]
  (close-threaded `(-> ~x ~@forms)))

#_(defn close-threaded
  "Works like img-> but calls (.close) on the input image as well as
   all intermediate images. The result is not automatically closed so
   with-open should be used.
   (with-open [img (load-image \"my.img\")]
     (img-> img
       (scale 2)
       (copy-channel :green)
       (write-png \"out.png\")))"
  {:added "1.0"}
  [f img-form & args]
    (if
    (reduce (fn [forms form]
      `(with-open [img# ~form]
         ~@forms))
      threaded)))

(defn image
  ([width height]
    (image width height 4))
  ([width height channels]
    (log/info "Creating buffer" width height channels)
    (->Image width height channels (BufferUtils/createByteBuffer (* width height channels)))))

(defn load-image [location]
  (let [w           (BufferUtils/createIntBuffer 1)
        h           (BufferUtils/createIntBuffer 1)
        c           (BufferUtils/createIntBuffer 1)
        buffer      (->
                      location
                      jio/input-stream
                      IOUtils/toByteArray
                      ByteBuffer/wrap)
        direct-buffer (BufferUtils/createByteBuffer (.limit buffer))]
    (doto direct-buffer
      (.put buffer)
      (.flip))
    (let [byte-buffer (STBImage/stbi_load_from_memory direct-buffer w h c 0)
          width       (.get w)
          height      (.get h)
          channels    (.get c)]
      (log/info "loaded image" location width "x" height channels)
      (->Image width height channels byte-buffer))))

(defn write-png [{:keys [width height channels byte-buffer] :as img} path]
  (STBImageWrite/stbi_write_png path width height channels byte-buffer 0)
  img)

(defn scale [{:keys [width height channels byte-buffer]} ^long s]
  (let [scaled-bytes (BufferUtils/createByteBuffer (* (* s width)
                                                      (* s height)
                                                      channels))]
    (when (zero?
            (STBImageResize/stbir_resize_uint8_generic
              byte-buffer width height 0
              scaled-bytes (* s width) (* s height) 0
              channels
              (if (= channels 4)
                3
                STBImageResize/STBIR_ALPHA_CHANNEL_NONE)
              0
              STBImageResize/STBIR_EDGE_ZERO
              STBImageResize/STBIR_FILTER_BOX
              STBImageResize/STBIR_COLORSPACE_LINEAR))
      (throw (RuntimeException. "Error scaling image")))
    (log/info "scaled-bytes" scaled-bytes)
    (->Image (* s width) (* s height) channels scaled-bytes)))

(defn copy-buffer-range! [dest src n]
  (when (pos? n)
    (let [slice (.limit (.slice src) n)]
      (.put dest slice))))

(defn copy-sub-image [{dwidth :width dheight :height dchannels :channels dbytes :byte-buffer :as dimg}
                      {swidth :width sheight :height schannels :channels sbytes :byte-buffer :as simg}
                      dx1 dy1 sx1 sy1 sx2 sy2]
  {:pre [(is (= dchannels schannels) (format "%s and %s differ in channels" dimg simg))]}
  ;; for each line
  (doseq [y (range (- sy2 sy1))
          :let [sidx (* (+ sx1 (* (+ y sy1) swidth)) schannels)
                didx (* (+ dx1 (* (+ y dy1) dwidth)) dchannels)]
          :when (and (< -1 didx (.limit dbytes))
                     (< -1 sidx (.limit sbytes)))]
      (.position dbytes didx)
      (.position sbytes sidx)
      (copy-buffer-range! dbytes sbytes (* (- sx2 sx1) schannels)))
  (.position sbytes (* swidth sheight schannels))
  (.position dbytes (* dwidth dheight dchannels))
  (.flip sbytes)
  (.flip dbytes)
  dimg)

(defn rect-intersect [x0 y0 x1 y1 x2 y2 x3 y3]
  (let [x4 (max x0 x2)
        y4 (max y0 y2)
        x5 (min x1 x3)
        y5 (min y1 y3)]
    (when (and (< x4 x5)
               (< y4 y5))
      [x4 y4 x5 y5])))

(defn draw-image [{dwidth :width dheight :height :as dest-img}
                  {swidth :width sheight :height :as src-img}
                  x y]
  (let [;; dest image rect
        x0 0
        y0 0
        x1 dwidth
        y1 dheight
        ;; src image rect
        x2 x
        y2 y
        x3 (+ x swidth)
        y3 (+ y sheight)]
    (when-let [[x4 y4 x5 y5] (rect-intersect x0 y0 x1 y1 x2 y2 x3 y3)]
      (let [sx0 (- x4 x)
            sy0 (- y4 y)
            sx1 (- x5 x)
            sy1 (- y5 y)]
        (log/info "copying from [" sx0 sy0 "] [" sx1 sy1 "] to" x y)
        (copy-sub-image dest-img src-img x y sx0 sy0 sx1 sy1)))))

(defn resize [{swidth :width sheight :height :as img} width height]
  (copy-sub-image (image width height)
                  img
                  0 0
                  0 0
                  swidth sheight))
(defn- num-channels [k]
  (case k
    :grayscale 1
    :rgb       3
    :rgba      4
    (assert (str "Unknown image type" k))))

(defmulti mode (fn [{:keys [channels]} m]
                 (case [channels m]
                   [1 :grayscale]
                     :nop
                   [1 :rgb]
                     :grayscale->rgb
                   [1 :rgba]
                     :grayscale->rgba
                   [3 :grayscale]
                     :rgb->grayscale
                   [3 :rgb]
                     :nop
                   [3 :rgba]
                     :rgb->rgba
                   [4 :rgb]
                     :rgba->rgb
                   [4 :rgba]
                     :nop)))

(defmethod mode :nop [img _] img)

(defmethod mode :rgb->grayscale
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)]
        (.put dest-buffer (byte (quot (+ r g b) 3)))))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :grayscale->rgb
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (.limit byte-buffer))]
      (let [v (.get byte-buffer)]
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :grayscale->rgba
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (.limit byte-buffer))]
      (let [v (.get byte-buffer)]
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)
        (.put dest-buffer v)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :rgb->rgba
  [{:keys [width height channels byte-buffer]} image-type]
  (log/info "rgb->rgba")
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (log/info "dest-buffer" dest-buffer)
    (log/info "pixels" (quot (.limit byte-buffer) channels))
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)]
        (.put dest-buffer r)
        (.put dest-buffer g)
        (.put dest-buffer b)
        (.put dest-buffer (byte 0))))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defmethod mode :rgba->rgb
  [{:keys [width height channels byte-buffer]} image-type]
  (let [dest-buffer (BufferUtils/createByteBuffer (* width height (num-channels image-type)))]
    (doseq [i (range (quot (.limit byte-buffer) channels))]
      (let [r (.get byte-buffer)
            g (.get byte-buffer)
            b (.get byte-buffer)
            a (.get byte-buffer)]
        (.put dest-buffer r)
        (.put dest-buffer g)
        (.put dest-buffer b)))
    (.flip byte-buffer)
    (.flip dest-buffer)
    (->Image width height (num-channels image-type) dest-buffer)))

(defn- skip [buffer n]
  (.position buffer (+ (.position buffer) n)))

(defn- copy-channel [v channel]
  (let [channel-shift (case channel
                       :alpha 24
                       :blue  16
                       :green  8
                       :red    0)
        c (->
            (bit-shift-left 0xFF channel-shift)
            (bit-and v)
            (unsigned-bit-shift-right channel-shift))]
    (reduce (fn [a n] (bit-or a (bit-shift-left c n))) 0 [24 16 8 0])))

(defn copy-channels [{:keys [width height channels byte-buffer]} channel]
  (let [img           (image width height)
        result-buffer (BufferUtils/createByteBuffer (* width height channels))]
    (doseq [x (range width)
            y (range height)]
      (let [c (case channel
                :red   0
                :green 1
                :blue  2
                :alpha 3)]
      (skip byte-buffer c)
      (let [v (.get byte-buffer)]
        (dotimes [_ channels]
          (.put result-buffer v)))
      (skip byte-buffer (dec (- channels c)))))
    (.flip byte-buffer)
    (.flip result-buffer)
    (log/info "copy-channels" result-buffer)
    (->Image width height channels result-buffer)))

Fix rect calc for image drawing

Fix rect calc for image drawing


(ns metabase.api.query-test
  "Tests for /api/query endpoints."
  (:require [expectations :refer :all]
            [korma.core :refer :all]
            [metabase.db :refer :all]
            (metabase.models [query :refer [Query]]
                             [query-execution :refer [QueryExecution]])
            [metabase.test.util :refer [match-$ random-name expect-eval-actual-first]]
            [metabase.test-data :refer :all]))

;; ## Helper Fns

(defn create-query [& {:as kwargs}]
  ((user->client :rasta) :post 200 "query" (merge {:database (:id @test-db)
                                                   :sql "SELECT COUNT(*) FROM VENUES;"}
                                                  kwargs)))

;; ## POST /api/query (create)
;; Check that we can save a Query
(expect-eval-actual-first
    (match-$ (sel :one Query (order :id :DESC))
      {:database_id (:id @test-db)
       :name $
       :type "rawsql"
       :creator_id (user->id :rasta)
       :updated_at $
       :details {:timezone nil
                 :sql "SELECT COUNT(*) FROM VENUES;"}
       :id $
       :version $
       :public_perms 0
       :created_at $})
  (create-query))

;; ## GET /api/query/:id
;; Check that we can fetch details for a Query
(expect-eval-actual-first
    (match-$ (sel :one Query (order :id :DESC))
      {:id $
       :name $
       :type "rawsql"
       :creator_id (user->id :rasta)
       :updated_at $
       :details {:timezone nil
                 :sql "SELECT COUNT(*) FROM VENUES;"}
       :database_id (:id @test-db)
       :database (match-$ @test-db
                   {:created_at $
                    :engine "h2"
                    :id $
                    :details $
                    :updated_at $
                    :name "Test Database"
                    :organization_id (:id @test-org)
                    :description nil})
       :creator (match-$ (fetch-user :rasta)
                  {:common_name "Rasta Toucan"
                   :date_joined $
                   :last_name "Toucan"
                   :id $
                   :is_superuser false
                   :last_login $
                   :first_name "Rasta"
                   :email "rasta@metabase.com"})
       :can_read true
       :can_write true
       :version $
       :public_perms 0
       :created_at $})
  (let [{id :id} (create-query)]
    ((user->client :rasta) :get 200 (format "query/%d" id))))

;; ## PUT /api/query/:id
;; Check that we can update a Query
(expect-eval-actual-first
    [{:name "My Awesome Query"
      :version 2}
     {:name "My Awesome Query 2"
      :version 3}]
  (let [{:keys [id name database_id]} (create-query)
        get-query-name-and-version (fn [] (sel :one :fields [Query :name :version] :id id))]
    [(do ((user->client :rasta) :put 200 (format "query/%d" id) {:name "My Awesome Query"
                                                                 :database {:id database_id}})
         (get-query-name-and-version))
     (do ((user->client :rasta) :put 200 (format "query/%d" id) {:name "My Awesome Query 2"
                                                                 :database {:id database_id}})
         (get-query-name-and-version))]))

;; ## DELETE /api/query/:id
;; Check that we can delete a Query
(let [query-name (random-name)
      get-query-name (fn [] (sel :one :field [Query :name] :name query-name))]
  (expect-eval-actual-first
      [query-name
       nil]
    (let [{id :id} (create-query :name query-name)]
      [(get-query-name)
       (do ((user->client :rasta) :delete 204 (format "query/%d" id))
           (get-query-name))])))

;; ## POST /api/query (clone)
;; Can we clone a Query?
(let [query-name (random-name)]
  (expect-eval-actual-first
      (match-$ (sel :one Query :name (format "%s CLONED" query-name))
        {:database_id (:id @test-db)
         :name $
         :type "rawsql"
         :creator_id (user->id :crowberto)
         :updated_at $
         :details {:timezone nil
                   :sql "SELECT COUNT(*) FROM VENUES;"}
         :id $
         :version 1
         :public_perms 0
         :created_at $})
    ;; Clone Query with a different User than the one that created it
    (let [{id :id} (create-query :name query-name)]
      ((user->client :crowberto) :post 200 "query" {:clone id}))))

;; ## POST /api/query/:id & GET /api/query/:id/results
;; Can we execute a Query (i.e., create a new QueryExecution) ?
(expect-eval-actual-first
    (let [{query-id :id :as query} (sel :one Query (order :id :DESC))
          query-execution (sel :one QueryExecution :query_id query-id (order :id :DESC))]
      [(match-$ query-execution
         {:id $
          :uuid $
          :query_id query-id
          :version 1
          :status "starting"
          :started_at $})
       [(match-$ query-execution
           {:query_id query-id
            :raw_query ""
            :result_rows 1
            :finished_at $
            :started_at $
            :json_query {:native {:timezone nil
                                  :query "SELECT COUNT(*) FROM VENUES;"}
                         :database (:id @test-db)
                         :type "native"}
            :status "completed"
            :id $
            :uuid $
            :row_count 1
            :running_time $
            :version 1})]])
  (let [{id :id} (create-query)]
    [;; POST /query/:id should create a new QueryExecution
     ((user->client :rasta) :post 200 (format "query/%d" id))
     ;; GET /query/:id/results should return array of QueryExecutions for the Query (e.g., the one we just created)
     (do
       ;; wait 100ms for QueryExecution to complete. If it takes longer than that, it's probably brokesies
       (Thread/sleep 100)
       ((user->client :rasta) :get 200 (format "query/%d/results" id)))]))

;; ## GET /api/query
;; Fetch Queries for the current Org
(expect-eval-actual-first
    (let [[query-1 query-2] (sel :many Query :database_id (:id @test-db) (order :id :ASC))
          rasta (match-$ (fetch-user :rasta)
                  {:common_name "Rasta Toucan"
                   :date_joined $
                   :last_name "Toucan"
                   :id $
                   :is_superuser false
                   :last_login $
                   :first_name "Rasta"
                   :email "rasta@metabase.com"})
          db (match-$ @test-db
               {:created_at $
                :engine "h2"
                :id $
                :details $
                :updated_at $
                :name "Test Database"
                :organization_id (:id @test-org)
                :description nil})]
      [(match-$ query-1
         {:creator rasta
          :database_id (:id @test-db)
          :name $
          :type "rawsql"
          :creator_id (user->id :rasta)
          :updated_at $
          :details {:timezone nil
                    :sql "SELECT COUNT(*) FROM VENUES;"}
          :id $
          :database db
          :version 1
          :public_perms 0
          :created_at $})
       (match-$ query-2
         {:creator rasta
          :database_id (:id @test-db)
          :name $
          :type "rawsql"
          :creator_id (user->id :rasta)
          :updated_at $
          :details {:timezone nil
                    :sql "SELECT COUNT(*) FROM VENUES;"}
          :id $
          :database db
          :version 1
          :public_perms 0
          :created_at $})])
  (do (cascade-delete Query :database_id (:id @test-db))
      (create-query)
      (create-query)
      ((user->client :rasta) :get 200 "query" :org (:id @test-org))))

test for GET /api/query

test for GET /api/query


(ns smallex.test.generators
  (:refer-clojure :exclude [alias])
  (:require [smallex.records :as r]
            [simple-check.generators :as gen]
            [clojure.test :refer :all]
            [clojure.pprint :as pprint :refer [pprint]]))

(defn- set->char-set [s]
  (with-meta
    {:type :char-set :value (apply str s)}
    {:result :char}))

(def char-set
  (gen/fmap (comp set->char-set set) (gen/vector gen/char)))

(defn- string->item-string [s]
  (with-meta
    {:type :string :value s}
    {:result (if (= 1 (count s))
               :char
               :string)}))

(def string
  (gen/fmap string->item-string
            (gen/not-empty gen/string-alpha-numeric)))

(defn use-alias [aliases]
  (gen/elements aliases))

(def collection-generators
  (map #(gen/resize 20 %) [string char-set]))

(declare operation)

(defn- operation-generator
  [{:keys [op max-args type-fn such-that]
    :or {max-args 4 such-that (constantly true)}}]
  (fn [alias-gen]
    (gen/sized
     (fn [size]
       (let [smaller-ops (gen/resize (dec size) (operation alias-gen))
             arg-gen (cond-> (conj collection-generators alias-gen)
                             (pos? size)
                             ;; v- hack to get more nested ops
                             (conj smaller-ops smaller-ops smaller-ops))]
         (->> (gen/vector (gen/one-of arg-gen) 1 max-args)
              (gen/fmap
               (fn [args]
                 (with-meta {:type :op, :value op, :args args}
                   {:result (type-fn (map #(-> % meta :result) args))})))
              (gen/such-that such-that)))))))

(def or-op
  (operation-generator
   {:op :or
    :type-fn (fn [args]
               (if (every? #(= :char %) args)
                 :char
                 :string))}))

(def cat-op
  (operation-generator
   {:op :cat
    :type-fn (fn [[f & r]]
               (if (seq r)
                 :string
                 f))}))
(def star-op
  (operation-generator
   {:op :star, :max-args 1, :type-fn (constantly :string)}))

(def plus-op
  (operation-generator
   {:op :plus, :max-args 1, :type-fn (constantly :string)}))

(def opt-op
  (operation-generator
   {:op :opt, :max-args 1, :type-fn (constantly :string)}))

(def not-op
  (operation-generator
   {:op :not, :max-args 1, :type-fn (fn [[f]] f)
    :such-that #(-> % meta :result (= :char))}))

(def all-op-generators
  [or-op cat-op star-op plus-op opt-op not-op])

(def operation
  (fn [alias-gen]
    (gen/sized
     (fn [size]
       (let [op-generators (map #(gen/resize size (% alias-gen))
                                all-op-generators)]
         (gen/one-of op-generators))))))

(defn expression
  [alias-gen]
  (gen/frequency [[8 (operation alias-gen)]
                  [4 (gen/one-of collection-generators)]
                  [1 alias-gen]]))

(defn ppm [obj]
  (let [orig-dispatch pprint/*print-pprint-dispatch*]
    (pprint/with-pprint-dispatch
      (fn [o]
        (when (meta o)
          (print "^")
          (orig-dispatch (meta o))
          (pprint/pprint-newline :fill))
        (orig-dispatch o))
      (pprint obj))))

(defn alias
  [prev-aliases]
  (let [alias-gen (if (seq prev-aliases)
                    (gen/elements prev-aliases)
                    string) ;; avoid throwing when empty
        alias-name (gen/such-that #(and (seq %)
                                        (Character/isLetter (first %))
                                        (not-any? (fn [e] (= % (:value e)))
                                                  prev-aliases))
                                  (gen/resize 20 gen/string-alpha-numeric))
        expr (expression alias-gen)]
    (->> (gen/tuple alias-name expr)
         (gen/fmap (fn [[alias-name expr]]
                     {(with-meta {:type :symbol :value alias-name}
                        {:result (-> expr meta :result)})
                      expr})))))

(defn aliases
  [size]
  (if (zero? size)
    (alias nil)
    (gen/bind (gen/resize (dec size)
                          (gen/sized aliases))
              (fn [alias-map]
                (gen/fmap
                 (fn [generated-alias]
                   (merge alias-map generated-alias))
                 (alias (keys alias-map)))))))

(defn rules
  [alias-defs]
  (let [alias-items (keys alias-defs)
        alias-names (set (map :value alias-items))
        alias-gen (if (seq alias-items)
                    (gen/elements alias-items)
                    string) ;; avoid throwing when empty
        rule-name-gen (gen/such-that #(and (seq %)
                                           (Character/isLetter (first %))
                                           (not (contains? alias-names %)))
                                     (gen/resize 20 gen/string-alpha-numeric))]
    (->> (gen/map rule-name-gen (expression alias-gen))
         (gen/not-empty)
         (gen/fmap (fn [m] ;; tag on priority on rules
                     (into {}
                           (for [[k v p] (mapv conj (shuffle (vec m)) (range))]
                             [k (vary-meta v assoc :priority p)])))))))

(def grammar
  (->>
   (gen/bind (gen/sized aliases)
             (fn [alias-defs]
               (gen/hash-map :aliases (gen/return alias-defs)
                             :rules (rules alias-defs))))
   (gen/fmap (fn [{:keys [aliases rules]}]
               (r/map->Grammar
                {:aliases (into {}
                                (for [[k v] aliases]
                                  [(:value k) v]))
                 :rules rules})))))

(deftest ^:examples test-grammar-generation
  (doseq [grammar (gen/sample grammar)]
    (print(str grammar))
    (println "-------------------------------")))

(ns smallex.test.generators
  (:refer-clojure :exclude [alias])
  (:require [smallex.records :as r]
            [simple-check.generators :as gen]
            [clojure.test :refer :all]
            [clojure.pprint :as pprint :refer [pprint]]))

(defn- set->char-set [s]
  (with-meta
    {:type :char-set :value (apply str s)}
    {:result :char}))

(def char-set
  (gen/fmap (comp set->char-set set) (gen/vector gen/char)))

(defn- string->item-string [s]
  (with-meta
    {:type :string :value s}
    {:result (if (= 1 (count s))
               :char
               :string)}))

(def string
  (gen/fmap string->item-string
            (gen/not-empty gen/string-alpha-numeric)))

(defn use-alias [aliases]
  (gen/elements aliases))

(def collection-generators
  (mapv vector
        [3 1]
        (map #(gen/resize 10 %) [string char-set])))

(declare operation)

(defn- operation-generator
  [{:keys [op max-args type-fn such-that]
    :or {max-args 4 such-that (constantly true)}}]
  (fn [alias-gen]
    (gen/sized
     (fn [size]
       (let [smaller-ops (gen/resize (dec size) (operation alias-gen))
             arg-gen (cond-> (conj collection-generators [2 alias-gen])
                             (pos? size)
                             ;; v- hack to get more nested ops
                             (conj [7 smaller-ops]))]
         (->> (gen/vector (gen/frequency arg-gen) 1 max-args)
              (gen/fmap
               (fn [args]
                 (with-meta {:type :op, :value op, :args args}
                   {:result (type-fn (map #(-> % meta :result) args))})))
              (gen/such-that such-that)))))))

(def or-op
  (operation-generator
   {:op :or
    :type-fn (fn [args]
               (if (every? #(= :char %) args)
                 :char
                 :string))}))

(def cat-op
  (operation-generator
   {:op :cat
    :type-fn (fn [[f & r]]
               (if (seq r)
                 :string
                 f))}))
(def star-op
  (operation-generator
   {:op :star, :max-args 1, :type-fn (constantly :string)}))

(def plus-op
  (operation-generator
   {:op :plus, :max-args 1, :type-fn (constantly :string)}))

(def opt-op
  (operation-generator
   {:op :opt, :max-args 1, :type-fn (constantly :string)}))

(def not-op
  (operation-generator
   {:op :not, :max-args 1, :type-fn (fn [[f]] f)
    :such-that #(-> % meta :result (= :char))}))

(def all-op-generators
  [or-op cat-op star-op plus-op opt-op not-op])

(def operation
  (fn [alias-gen]
    (gen/sized
     (fn [size]
       (let [op-generators (map #(gen/resize size (% alias-gen))
                                all-op-generators)]
         (gen/one-of op-generators))))))

(defn expression
  [alias-gen]
  (gen/frequency (conj collection-generators
                       [10 (operation alias-gen)]
                       [2 alias-gen])))

(defn ppm [obj]
  (let [orig-dispatch pprint/*print-pprint-dispatch*]
    (pprint/with-pprint-dispatch
      (fn [o]
        (when (meta o)
          (print "^")
          (orig-dispatch (meta o))
          (pprint/pprint-newline :fill))
        (orig-dispatch o))
      (pprint obj))))

(defn alias
  [prev-aliases]
  (let [alias-gen (if (seq prev-aliases)
                    (gen/elements prev-aliases)
                    string) ;; avoid throwing when empty
        alias-name (gen/such-that #(and (seq %)
                                        (Character/isLetter (first %))
                                        (not-any? (fn [e] (= % (:value e)))
                                                  prev-aliases))
                                  (gen/resize 20 gen/string-alpha-numeric))
        expr (expression alias-gen)]
    (->> (gen/tuple alias-name expr)
         (gen/fmap (fn [[alias-name expr]]
                     {(with-meta {:type :symbol :value alias-name}
                        {:result (-> expr meta :result)})
                      expr})))))

(defn aliases
  [size]
  (if (zero? size)
    (alias nil)
    (gen/bind (gen/resize (dec size)
                          (gen/sized aliases))
              (fn [alias-map]
                (gen/fmap
                 (fn [generated-alias]
                   (merge alias-map generated-alias))
                 (alias (keys alias-map)))))))

(defn rules
  [alias-defs]
  (let [alias-items (keys alias-defs)
        alias-names (set (map :value alias-items))
        alias-gen (if (seq alias-items)
                    (gen/elements alias-items)
                    string) ;; avoid throwing when empty
        rule-name-gen (gen/such-that #(and (seq %)
                                           (Character/isLetter (first %))
                                           (not (contains? alias-names %)))
                                     (gen/resize 20 gen/string-alpha-numeric))]
    (->> (gen/map rule-name-gen (expression alias-gen))
         (gen/not-empty)
         (gen/fmap (fn [m] ;; tag on priority on rules
                     (into {}
                           (for [[k v p] (mapv conj (shuffle (vec m)) (range))]
                             [k (vary-meta v assoc :priority p)])))))))

(def grammar
  (->>
   (gen/bind (gen/sized aliases)
             (fn [alias-defs]
               (gen/hash-map :aliases (gen/return alias-defs)
                             :rules (rules alias-defs))))
   (gen/fmap (fn [{:keys [aliases rules]}]
               (r/map->Grammar
                {:aliases (into {}
                                (for [[k v] aliases]
                                  [(:value k) v]))
                 :rules rules})))))

(deftest ^:examples test-grammar-generation
  (doseq [grammar (gen/sample grammar)]
    (print(str grammar))
    (println "-------------------------------")))

Tweak frequencies on generators.

Tweak frequencies on generators.


(ns huon.log
  (:require [clojure.string] ; required by macros
            [goog.debug.Console]
            [goog.debug.Logger.Level :as Level]
            [goog.debug.LogManager :as LogManager])
  ;; automatically include in requiring namespaces
  (:require-macros huon.log))

(LogManager/initialize)

(defonce console
  (goog.debug.Console.))

(defn enable!
  "Start capturing console output. Apps that want to display log output should
  call this function, but libraries that depend on Huon for logging should not."
  []
  (set! (.-showLoggerName (.getFormatter console)) false)
  (.setCapturing console true))

(def ^:private levels
  {:debug Level/FINE
   :info  Level/INFO
   :warn  Level/WARNING
   :error Level/SEVERE})

(defn- get-logger [name]
  (LogManager/getLogger name))

(defn set-level!
  "Set a per-namespace logging level. This overrides the level defined by
  (set-root-level!)."
  [logger-or-name level]
  {:pre [(contains? levels level)]}
  (let [logger (if (string? logger-or-name)
                 (get-logger logger-or-name)
                 logger-or-name)]
    (.setLevel logger (levels level))))

(defn set-root-level!
  "Set the global logging threshold. This can be overridden on a per-namespace
  basis with (set-level!)."
  [level]
  (set-level! (LogManager/getRoot) level))

(defn log* [logger-name level msg-fn]
  {:pre [(contains? levels level)]}
  (let [logger (get-logger logger-name)
        glevel (levels level)]
    (if (.isLoggable logger glevel)
      (.log logger glevel msg-fn))))

(ns huon.log
  (:require [clojure.string] ; required by macros
            [goog.debug.Console]
            [goog.debug.Logger.Level :as Level]
            [goog.debug.LogManager :as LogManager])
  ;; automatically include in requiring namespaces
  (:require-macros huon.log))

(LogManager/initialize)

(defonce console
  (goog.debug.Console.))

(defn enable!
  "Start capturing console output. Apps that want to display log output should
  call this function, but libraries that depend on Huon for logging should not."
  []
  ;; Ensure gclosure logging works in node.js with various compiler
  ;; optimizations enabled. See https://dev.clojure.org/jira/browse/CLJS-2930.
  (.setConsole goog.debug.Console js/console)
  (set! (.-showLoggerName (.getFormatter console)) false)
  (.setCapturing console true))

(def ^:private levels
  {:debug Level/FINE
   :info  Level/INFO
   :warn  Level/WARNING
   :error Level/SEVERE})

(defn- get-logger [name]
  (LogManager/getLogger name))

(defn set-level!
  "Set a per-namespace logging level. This overrides the level defined by
  (set-root-level!)."
  [logger-or-name level]
  {:pre [(contains? levels level)]}
  (let [logger (if (string? logger-or-name)
                 (get-logger logger-or-name)
                 logger-or-name)]
    (.setLevel logger (levels level))))

(defn set-root-level!
  "Set the global logging threshold. This can be overridden on a per-namespace
  basis with (set-level!)."
  [level]
  (set-level! (LogManager/getRoot) level))

(defn log* [logger-name level msg-fn]
  {:pre [(contains? levels level)]}
  (let [logger (get-logger logger-name)
        glevel (levels level)]
    (if (.isLoggable logger glevel)
      (.log logger glevel msg-fn))))

Fix `:simple` optimizations for node.js

Fix `:simple` optimizations for node.js


(ns lt.macros
  (:require [clojure.walk :as walk]))

(defmacro defui [sym params hiccup & events]
  `(defn ~sym ~params
     (let [e# (crate.core/html ~hiccup)]
       (doseq [[ev# func#] (partition 2 ~(vec events))]
         (lt.util.dom/on e# ev# func#))
       e#)))

(defmacro timed [ev & body]
  `(let [start# (lighttable.util.js/now)
         res# (do ~@body)]
     (lighttable.components.logger/log ~ev (- (lighttable.util.js/now) start#))
     res#))

(defn ->params [body]
  (if (vector? (first body))
    [(first body) (rest body)]
    [[] body]))

(defmacro on [name & body]
  `(lighttable.command/on ~name (fn ~@body)))

(defmacro in [ctx & body]
  (let [[params body] (->params body)]
    `(assoc ~ctx :in (fn ~params ~@body))))

(defmacro out [ctx & body]
  (let [[params body] (->params body)]
    `(assoc ~ctx :out (fn ~params ~@body))))

(defmacro defcontext [name & body]
  `(let [ctx# {:name ~name}]
     (lighttable.context/add-context!
       (-> ctx#
           ~@body))))

(defmacro extract [elem kvs & body]
  (let [defs (vec (apply concat (for [[k v] (partition 2 kvs)]
                                  `[~k (lt.util.dom/$ ~v ~elem)])))]
    `(let ~defs
       ~@body)))

(defmacro foreach [xs & body]
  `(let [xs# ~(second xs)
         len# (.-length xs#)]
     (loop [left# 0]
       (when (< left# len#)
         (let [~(first xs) (aget xs# left)]
           ~@body
           (recur (inc left#)))))))

(defmacro with-time [& body]
  (let [start (gensym "start")
        body (walk/postwalk-replace {'time (list '- '(.getTime (js/Date.)) start)} body)]
  `(let [~start (.getTime (js/Date.))]
     ~@body)))

(defmacro background [func]
  `(lt.objs.thread/thread*
    (fn ~(gensym "tfun") []
      (let [orig# (js/argsArray js/arguments)
            msg# (.shift orig#)
            args# (.map orig# cljs.reader/read-string)
            ~'raise (fn [obj# k# v#]
                     (js/_send obj# k# (pr-str v#) "clj"))]
        (.unshift args# (.-obj msg#))
        (.apply ~func nil args#)))))

(comment

  (worker (fn [v]
            (do-something v))
          :zomg (fn [r]
                  ))

  (defui cool [l]
    [:li (bound l)]

    :click (fn [e]
             (this-as me
                      ))
    :hover (fn [e]
             ))

  )

(ns lt.macros
  (:require [clojure.walk :as walk]))

(defn- namify [keyword]
  (symbol (.replace (name keyword) "." "__DOT__")))

(defmacro behavior [name & {:keys [reaction] :as r}]
  (if (and (seq? reaction) (= 'fn (first reaction)))
    (let [[_ args & body] reaction]
      `(do
         (defn- ~(namify name) ~args ~@body)
         (lt.object/behavior* ~name ~@(apply concat (assoc r :reaction (namify name))))))
    `(lt.object/behavior* ~name ~@(apply concat r))))

(defmacro defui [sym params hiccup & events]
  `(defn ~sym ~params
     (let [e# (crate.core/html ~hiccup)]
       (doseq [[ev# func#] (partition 2 ~(vec events))]
         (lt.util.dom/on e# ev# func#))
       e#)))

(defmacro timed [ev & body]
  `(let [start# (lighttable.util.js/now)
         res# (do ~@body)]
     (lighttable.components.logger/log ~ev (- (lighttable.util.js/now) start#))
     res#))

(defn ->params [body]
  (if (vector? (first body))
    [(first body) (rest body)]
    [[] body]))

(defmacro on [name & body]
  `(lighttable.command/on ~name (fn ~@body)))

(defmacro in [ctx & body]
  (let [[params body] (->params body)]
    `(assoc ~ctx :in (fn ~params ~@body))))

(defmacro out [ctx & body]
  (let [[params body] (->params body)]
    `(assoc ~ctx :out (fn ~params ~@body))))

(defmacro defcontext [name & body]
  `(let [ctx# {:name ~name}]
     (lighttable.context/add-context!
       (-> ctx#
           ~@body))))

(defmacro extract [elem kvs & body]
  (let [defs (vec (apply concat (for [[k v] (partition 2 kvs)]
                                  `[~k (lt.util.dom/$ ~v ~elem)])))]
    `(let ~defs
       ~@body)))

(defmacro foreach [xs & body]
  `(let [xs# ~(second xs)
         len# (.-length xs#)]
     (loop [left# 0]
       (when (< left# len#)
         (let [~(first xs) (aget xs# left)]
           ~@body
           (recur (inc left#)))))))

(defmacro with-time [& body]
  (let [start (gensym "start")
        body (walk/postwalk-replace {'time (list '- '(.getTime (js/Date.)) start)} body)]
  `(let [~start (.getTime (js/Date.))]
     ~@body)))

(defmacro background [func]
  `(lt.objs.thread/thread*
    (fn ~(gensym "tfun") []
      (let [orig# (js/argsArray js/arguments)
            msg# (.shift orig#)
            args# (.map orig# cljs.reader/read-string)
            ~'raise (fn [obj# k# v#]
                     (js/_send obj# k# (pr-str v#) "clj"))]
        (.unshift args# (.-obj msg#))
        (.apply ~func nil args#)))))

(comment

  (worker (fn [v]
            (do-something v))
          :zomg (fn [r]
                  ))

  (defui cool [l]
    [:li (bound l)]

    :click (fn [e]
             (this-as me
                      ))
    :hover (fn [e]
             ))

  )

Add a behaviour macro to name reactions

Add a behaviour macro to name reactions


(defproject
  carry-history "0.1.0"
  :description "Carry middleware which simplifies working with browser history."
  :url "https://github.com/metametadata/carry/tree/master/contrib/history"
  :license {:name "MIT" :url "http://opensource.org/licenses/MIT"}

  :dependencies [[org.clojure/clojure "1.8.0" :scope "provided"]
                 [org.clojure/clojurescript "1.8.51" :scope "provided"]]

  :pedantic? :abort

  :source-paths ["src"]

  :repositories {"clojars" {:sign-releases false}})

(defproject
  carry-history "0.1.0"
  :description "Carry middleware which simplifies working with browser history."
  :url "https://github.com/metametadata/carry/tree/master/contrib/history"
  :license {:name "MIT" :url "http://opensource.org/licenses/MIT"}

  :dependencies [[org.clojure/clojure "1.8.0" :scope "provided"]
                 [org.clojure/clojurescript "1.8.51" :scope "provided"]

                 [org.clojure/core.match "0.3.0-alpha4" :scope "provided"]]

  :pedantic? :abort

  :source-paths ["src"]

  :repositories {"clojars" {:sign-releases false}})

add core.match dep

carry-history: add core.match dep


(ns waiter.kubernetes-scheduler-integration-test
  (:require [clojure.data.json :as json]
            [clojure.set :as set]
            [clojure.string :as string]
            [clojure.walk :as walk]
            [clojure.test :refer :all]
            [clojure.tools.logging :as log]
            [waiter.util.client-tools :refer :all]))

(defn- get-watch-state [state-json]
  (or (get-in state-json ["state" "watch-state"])
      (get-in state-json ["state" "components" "kubernetes" "watch-state"])))

(deftest ^:parallel ^:integration-fast test-kubernetes-watch-state-update
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [cookies (all-cookies waiter-url)
            router-url (-> waiter-url routers first val)
            {:keys [body] :as response} (make-request router-url "/state/scheduler" :method :get :cookies cookies)
            _ (assert-response-status response 200)
            body-json (-> body str try-parse-json)
            watch-state-json (get-watch-state body-json)
            initial-pods-snapshot-version (get-in watch-state-json ["pods-metadata" "version" "snapshot"])
            initial-pods-watch-version (get-in watch-state-json ["pods-metadata" "version" "watch"])
            initial-rs-snapshot-version (get-in watch-state-json ["rs-metadata" "version" "snapshot"])
            initial-rs-watch-version (get-in watch-state-json ["rs-metadata" "version" "watch"])
            {:keys [service-id request-headers]} (make-request-with-debug-info
                                                   {:x-waiter-name (rand-name)}
                                                   #(make-kitchen-request waiter-url % :path "/hello"))]
        (with-service-cleanup
          service-id
          (let [{:keys [body] :as response} (make-request router-url "/state/scheduler" :method :get :cookies cookies)
                _ (assert-response-status response 200)
                body-json (-> body str try-parse-json)
                watch-state-json (get-watch-state body-json)
                pods-snapshot-version' (get-in watch-state-json ["pods-metadata" "version" "snapshot"])
                pods-watch-version' (get-in watch-state-json ["pods-metadata" "version" "watch"])
                rs-snapshot-version' (get-in watch-state-json ["rs-metadata" "version" "snapshot"])
                rs-watch-version' (get-in watch-state-json ["rs-metadata" "version" "watch"])]
            (is (or (nil? initial-pods-watch-version)
                    (< initial-pods-snapshot-version initial-pods-watch-version)))
            (is (<= initial-pods-snapshot-version pods-snapshot-version'))
            (is (< pods-snapshot-version' pods-watch-version'))
            (is (or (nil? initial-rs-watch-version)
                    (< initial-rs-snapshot-version initial-rs-watch-version)))
            (is (<= initial-rs-snapshot-version rs-snapshot-version'))
            (is (< rs-snapshot-version' rs-watch-version'))))))))

; test that we can provide a custom docker image that contains /tmp/index.html with "Integration Test Image" in it
(deftest ^:parallel ^:integration-slow test-kubernetes-custom-image
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [custom-image (System/getenv "INTEGRATION_TEST_CUSTOM_IMAGE")
            _ (is (not (string/blank? custom-image)) "You must provide a custom image in the INTEGRATION_TEST_CUSTOM_IMAGE environment variable")
            {:keys [body]} (make-kitchen-request
                             waiter-url
                             {:x-waiter-name (rand-name)
                              :x-waiter-image custom-image
                              :x-waiter-cmd "echo -n $INTEGRATION_TEST_SENTINEL_VALUE > index.html && python3 -m http.server $PORT0"
                              :x-waiter-health-check-url "/"}
                             :method :get
                             :path "/")]
        (is (= "Integration Test Sentinel Value" body))))))

(deftest ^:parallel ^:integration-slow ^:resource-heavy test-s3-logs
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [headers {:x-waiter-name (rand-name)
                     :x-waiter-max-instances 2
                     :x-waiter-scale-up-factor 0.99
                     :x-waiter-scale-down-factor 0.99
                     :x-kitchen-delay-ms 500}
            _ (log/info "making canary request...")
            {:keys [cookies instance-id service-id]} (make-request-with-debug-info headers #(make-kitchen-request waiter-url %))
            request-fn (fn [] (->> #(make-kitchen-request waiter-url %)
                                   (make-request-with-debug-info headers)
                                   :instance-id))]
        (with-service-cleanup
          service-id
          (assert-service-on-all-routers waiter-url service-id cookies)

          ;; Test that the active instances' logs are available.
          ;; This portion of the test logic was copied from basic-test/test-basic-logs
          (let [active-instances (get-in (service-settings waiter-url service-id :cookies cookies)
                                         [:instances :active-instances])
                log-url (:log-url (first active-instances))
                _ (log/debug "Log Url Active:" log-url)
                make-request-fn (fn [url] (make-request url "" :verbose true))
                {:keys [body] :as logs-response} (make-request-fn log-url)
                _ (assert-response-status logs-response 200)
                _ (log/debug "Response body:" body)
                log-files-list (walk/keywordize-keys (json/read-str body))
                stdout-file-link (:url (first (filter #(= (:name %) "stdout") log-files-list)))
                stderr-file-link (:url (first (filter #(= (:name %) "stderr") log-files-list)))]
            (is (every? #(string/includes? body %) ["stderr" "stdout"])
                (str "Live directory listing is missing entries: stderr and stdout, got response: " logs-response))
            (doseq [file-link [stderr-file-link stdout-file-link]]
              (if (string/starts-with? (str file-link) "http")
                (assert-response-status (make-request-fn file-link) 200)
                (log/warn "test-basic-logs did not verify file link:" stdout-file-link))))

          ;; Get a service with at least one active and one killed instance.
          ;; This portion of the test logic was copied from basic-test/test-killed-instances
          (log/info "starting parallel requests")
          (let [instance-ids-atom (atom #{})
                instance-request-fn (fn []
                                      (let [instance-id (request-fn)]
                                        (swap! instance-ids-atom conj instance-id)))
                instance-ids (->> (parallelize-requests 4 16 instance-request-fn
                                                        :canceled? (fn [] (> (count @instance-ids-atom) 2))
                                                        :verbose true
                                                        :service-id service-id)
                                  (reduce set/union))]
            (is (> (count instance-ids) 1) (str instance-ids)))

          (log/info "waiting for at least one instance to get killed")
          (is (wait-for #(->> (get-in (service-settings waiter-url service-id) [:instances :killed-instances])
                              (map :id)
                              set
                              seq)
                        :interval 2 :timeout 45)
              (str "No killed instances found for " service-id))

          ;; Test that the killed instances' logs were persisted to S3.
          ;; This portion of the test logic was modified from the active-instances tests above.
          (let [log-bucket-url (k8s-log-bucket-url waiter-url)
                killed-instances (get-in (service-settings waiter-url service-id :cookies cookies)
                                         [:instances :killed-instances])
                log-url (:log-url (first killed-instances))
                make-request-fn (fn [url] (make-request url "" :verbose true))
                _ (do
                    (log/info "waiting s3 logs to appear")
                    (is (wait-for
                          #(let [{:keys [body] :as logs-response} (make-request-fn log-url)]
                             (string/includes? body log-bucket-url))
                          :interval 1 :timeout 60)
                        (str "Log URL never pointed to S3 bucket " log-bucket-url)))
                _ (log/debug "Log Url Killed:" log-url)
                {:keys [body] :as logs-response} (make-request-fn log-url)
                _ (assert-response-status logs-response 200)
                _ (log/debug "Response body:" body)
                log-files-list (walk/keywordize-keys (json/read-str body))
                stdout-file-link (:url (first (filter #(= (:name %) "stdout") log-files-list)))
                stderr-file-link (:url (first (filter #(= (:name %) "stderr") log-files-list)))]
            (is (wait-for
                  #(every? (partial string/includes? body) ["stderr" "stdout"])
                  :interval 1 :timeout 30)
                (str "Killed directory listing is missing entries: stderr and stdout, got response: " logs-response))
            (doseq [file-link [stderr-file-link stdout-file-link]]
              (if (string/starts-with? (str file-link) "http")
                (assert-response-status (make-request-fn file-link) 200)
                (log/warn "test-basic-logs did not verify file link:" stdout-file-link)))))))))

(ns waiter.kubernetes-scheduler-integration-test
  (:require [clojure.data.json :as json]
            [clojure.set :as set]
            [clojure.string :as string]
            [clojure.walk :as walk]
            [clojure.test :refer :all]
            [clojure.tools.logging :as log]
            [waiter.util.client-tools :refer :all]))

(defn- get-watch-state [state-json]
  (or (get-in state-json ["state" "watch-state"])
      (get-in state-json ["state" "components" "kubernetes" "watch-state"])))

(deftest ^:parallel ^:integration-fast test-kubernetes-watch-state-update
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [cookies (all-cookies waiter-url)
            router-url (-> waiter-url routers first val)
            {:keys [body] :as response} (make-request router-url "/state/scheduler" :method :get :cookies cookies)
            _ (assert-response-status response 200)
            body-json (-> body str try-parse-json)
            watch-state-json (get-watch-state body-json)
            initial-pods-snapshot-version (get-in watch-state-json ["pods-metadata" "version" "snapshot"])
            initial-pods-watch-version (get-in watch-state-json ["pods-metadata" "version" "watch"])
            initial-rs-snapshot-version (get-in watch-state-json ["rs-metadata" "version" "snapshot"])
            initial-rs-watch-version (get-in watch-state-json ["rs-metadata" "version" "watch"])
            {:keys [service-id request-headers]} (make-request-with-debug-info
                                                   {:x-waiter-name (rand-name)}
                                                   #(make-kitchen-request waiter-url % :path "/hello"))]
        (with-service-cleanup
          service-id
          (let [{:keys [body] :as response} (make-request router-url "/state/scheduler" :method :get :cookies cookies)
                _ (assert-response-status response 200)
                body-json (-> body str try-parse-json)
                watch-state-json (get-watch-state body-json)
                pods-snapshot-version' (get-in watch-state-json ["pods-metadata" "version" "snapshot"])
                pods-watch-version' (get-in watch-state-json ["pods-metadata" "version" "watch"])
                rs-snapshot-version' (get-in watch-state-json ["rs-metadata" "version" "snapshot"])
                rs-watch-version' (get-in watch-state-json ["rs-metadata" "version" "watch"])]
            (is (or (nil? initial-pods-watch-version)
                    (< initial-pods-snapshot-version initial-pods-watch-version)))
            (is (<= initial-pods-snapshot-version pods-snapshot-version'))
            (is (< pods-snapshot-version' pods-watch-version'))
            (is (or (nil? initial-rs-watch-version)
                    (< initial-rs-snapshot-version initial-rs-watch-version)))
            (is (<= initial-rs-snapshot-version rs-snapshot-version'))
            (is (< rs-snapshot-version' rs-watch-version'))))))))

; test that we can provide a custom docker image that contains /tmp/index.html with "Integration Test Image" in it
(deftest ^:parallel ^:integration-slow test-kubernetes-custom-image
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [custom-image (System/getenv "INTEGRATION_TEST_CUSTOM_IMAGE")
            _ (is (not (string/blank? custom-image)) "You must provide a custom image in the INTEGRATION_TEST_CUSTOM_IMAGE environment variable")
            {:keys [body service-id]} (make-request-with-debug-info
                                        {:x-waiter-name (rand-name)
                                         :x-waiter-image custom-image
                                         :x-waiter-cmd "echo -n $INTEGRATION_TEST_SENTINEL_VALUE > index.html && python3 -m http.server $PORT0"
                                         :x-waiter-health-check-url "/"}
                                        #(make-kitchen-request waiter-url % :method :get :path "/"))]
        (is (= "Integration Test Sentinel Value" body))
        (delete-service waiter-url service-id)))))

(deftest ^:parallel ^:integration-slow ^:resource-heavy test-s3-logs
  (testing-using-waiter-url
    (when (using-k8s? waiter-url)
      (let [headers {:x-waiter-name (rand-name)
                     :x-waiter-max-instances 2
                     :x-waiter-scale-up-factor 0.99
                     :x-waiter-scale-down-factor 0.99
                     :x-kitchen-delay-ms 500}
            _ (log/info "making canary request...")
            {:keys [cookies instance-id service-id]} (make-request-with-debug-info headers #(make-kitchen-request waiter-url %))
            request-fn (fn [] (->> #(make-kitchen-request waiter-url %)
                                   (make-request-with-debug-info headers)
                                   :instance-id))]
        (with-service-cleanup
          service-id
          (assert-service-on-all-routers waiter-url service-id cookies)

          ;; Test that the active instances' logs are available.
          ;; This portion of the test logic was copied from basic-test/test-basic-logs
          (let [active-instances (get-in (service-settings waiter-url service-id :cookies cookies)
                                         [:instances :active-instances])
                log-url (:log-url (first active-instances))
                _ (log/debug "Log Url Active:" log-url)
                make-request-fn (fn [url] (make-request url "" :verbose true))
                {:keys [body] :as logs-response} (make-request-fn log-url)
                _ (assert-response-status logs-response 200)
                _ (log/debug "Response body:" body)
                log-files-list (walk/keywordize-keys (json/read-str body))
                stdout-file-link (:url (first (filter #(= (:name %) "stdout") log-files-list)))
                stderr-file-link (:url (first (filter #(= (:name %) "stderr") log-files-list)))]
            (is (every? #(string/includes? body %) ["stderr" "stdout"])
                (str "Live directory listing is missing entries: stderr and stdout, got response: " logs-response))
            (doseq [file-link [stderr-file-link stdout-file-link]]
              (if (string/starts-with? (str file-link) "http")
                (assert-response-status (make-request-fn file-link) 200)
                (log/warn "test-basic-logs did not verify file link:" stdout-file-link))))

          ;; Get a service with at least one active and one killed instance.
          ;; This portion of the test logic was copied from basic-test/test-killed-instances
          (log/info "starting parallel requests")
          (let [instance-ids-atom (atom #{})
                instance-request-fn (fn []
                                      (let [instance-id (request-fn)]
                                        (swap! instance-ids-atom conj instance-id)))
                instance-ids (->> (parallelize-requests 4 16 instance-request-fn
                                                        :canceled? (fn [] (> (count @instance-ids-atom) 2))
                                                        :verbose true
                                                        :service-id service-id)
                                  (reduce set/union))]
            (is (> (count instance-ids) 1) (str instance-ids)))

          (log/info "waiting for at least one instance to get killed")
          (is (wait-for #(->> (get-in (service-settings waiter-url service-id) [:instances :killed-instances])
                              (map :id)
                              set
                              seq)
                        :interval 2 :timeout 45)
              (str "No killed instances found for " service-id))

          ;; Test that the killed instances' logs were persisted to S3.
          ;; This portion of the test logic was modified from the active-instances tests above.
          (let [log-bucket-url (k8s-log-bucket-url waiter-url)
                killed-instances (get-in (service-settings waiter-url service-id :cookies cookies)
                                         [:instances :killed-instances])
                log-url (:log-url (first killed-instances))
                make-request-fn (fn [url] (make-request url "" :verbose true))
                _ (do
                    (log/info "waiting s3 logs to appear")
                    (is (wait-for
                          #(let [{:keys [body] :as logs-response} (make-request-fn log-url)]
                             (string/includes? body log-bucket-url))
                          :interval 1 :timeout 60)
                        (str "Log URL never pointed to S3 bucket " log-bucket-url)))
                _ (log/debug "Log Url Killed:" log-url)
                {:keys [body] :as logs-response} (make-request-fn log-url)
                _ (assert-response-status logs-response 200)
                _ (log/debug "Response body:" body)
                log-files-list (walk/keywordize-keys (json/read-str body))
                stdout-file-link (:url (first (filter #(= (:name %) "stdout") log-files-list)))
                stderr-file-link (:url (first (filter #(= (:name %) "stderr") log-files-list)))]
            (is (wait-for
                  #(every? (partial string/includes? body) ["stderr" "stdout"])
                  :interval 1 :timeout 30)
                (str "Killed directory listing is missing entries: stderr and stdout, got response: " logs-response))
            (doseq [file-link [stderr-file-link stdout-file-link]]
              (if (string/starts-with? (str file-link) "http")
                (assert-response-status (make-request-fn file-link) 200)
                (log/warn "test-basic-logs did not verify file link:" stdout-file-link)))))))))

Clean up service after k8s custom image test (#612)