;; This Source Code Form is subject to the terms of the Mozilla Public ;; License, v. 2.0. If a copy of the MPL was not distributed with this ;; file, You can obtain one at http://mozilla.org/MPL/2.0/. ;; ;; Copyright (c) KALEIDOS INC (ns app.srepl.main #_:clj-kondo/ignore (:require [app.auth :refer [derive-password]] [app.binfile.common :as bfc] [app.common.data :as d] [app.common.data.macros :as dm] [app.common.exceptions :as ex] [app.common.features :as cfeat] [app.common.files.validate :as cfv] [app.common.logging :as l] [app.common.pprint :as pp] [app.common.schema :as sm] [app.common.spec :as us] [app.common.time :as ct] [app.common.uuid :as uuid] [app.config :as cf] [app.db :as db] [app.db.sql :as-alias sql] [app.features.fdata :as fdata] [app.features.file-snapshots :as fsnap] [app.http.session :as session] [app.loggers.audit :as audit] [app.main :as main] [app.msgbus :as mbus] [app.rpc.commands.auth :as auth] [app.rpc.commands.files :as files] [app.rpc.commands.management :as mgmt] [app.rpc.commands.profile :as profile] [app.rpc.commands.projects :as projects] [app.rpc.commands.teams :as teams] [app.srepl.helpers :as h] [app.srepl.procs.file-repair :as procs.file-repair] [app.util.blob :as blob] [app.util.pointer-map :as pmap] [app.worker :as wrk] [clojure.datafy :refer [datafy]] [clojure.java.io :as io] [clojure.pprint :refer [print-table]] [clojure.stacktrace :as strace] [clojure.tools.namespace.repl :as repl] [cuerdas.core :as str] [datoteka.fs :as fs] [promesa.exec :as px] [promesa.exec.csp :as sp] [promesa.exec.semaphore :as ps] [promesa.util :as pu])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TASKS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn print-tasks [] (let [tasks (:app.worker/registry main/system)] (pp/pprint (keys tasks) :level 200))) (defn run-task! ([tname] (run-task! tname {})) ([tname params] (wrk/invoke! (-> main/system (assoc ::wrk/task tname) (assoc ::wrk/params params))))) (defn schedule-task! ([name] (schedule-task! name {})) ([name params] (wrk/submit! (-> main/system (assoc ::wrk/task name) (assoc ::wrk/params params))))) (defn send-test-email! [destination] (assert (string? destination) "destination should be provided") (-> main/system (assoc ::wrk/task :sendmail) (assoc ::wrk/params {:body "test email" :subject "test email" :to [destination]}) (wrk/invoke!))) (defn resend-email-verification-email! [email] (db/tx-run! main/system (fn [{:keys [::db/conn] :as cfg}] (let [email (profile/clean-email email) profile (profile/get-profile-by-email conn email)] (#'auth/send-email-verification! cfg profile))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PROFILES MANAGEMENT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn mark-profile-as-active! "Mark the profile blocked and removes all the http sessiones associated with the profile-id." [email] (some-> main/system (db/tx-run! (fn [{:keys [::db/conn] :as system}] (when-let [profile (db/get* conn :profile {:email (str/lower email)} {:columns [:id :email]})] (when-not (:is-blocked profile) (db/update! conn :profile {:is-active true} {:id (:id profile)}) :activated)))))) (defn mark-profile-as-blocked! "Mark the profile blocked and removes all the http sessiones associated with the profile-id." [email] (some-> main/system (db/tx-run! (fn [{:keys [::db/conn] :as system}] (when-let [profile (db/get* conn :profile {:email (str/lower email)} {:columns [:id :email]})] (when-not (:is-blocked profile) (db/update! conn :profile {:is-blocked true} {:id (:id profile)}) (db/delete! conn :http-session {:profile-id (:id profile)}) :blocked)))))) (defn reset-password! "Reset a password to a specific one for a concrete user or all users if email is `:all` keyword." [& {:keys [email password]}] (assert (string? email) "expected email") (assert (string? password) "expected password") (some-> main/system (db/tx-run! (fn [{:keys [::db/conn] :as system}] (let [password (derive-password password) email (str/lower email)] (-> (db/exec-one! conn ["update profile set password=? where email=?" password email]) (db/get-update-count) (pos?))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; FEATURES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn enable-team-feature! [team-id feature & {:keys [skip-check] :or {skip-check false}}] (when (and (not skip-check) (not (contains? cfeat/supported-features feature))) (ex/raise :type :assertion :code :feature-not-supported :hint (str "feature '" feature "' not supported"))) (let [team-id (h/parse-uuid team-id)] (db/tx-run! main/system (fn [{:keys [::db/conn]}] (let [team (-> (db/get conn :team {:id team-id}) (update :features db/decode-pgarray #{})) features (conj (:features team) feature)] (when (not= features (:features team)) (db/update! conn :team {:features (db/create-array conn "text" features)} {:id team-id}) :enabled)))))) (defn disable-team-feature! [team-id feature & {:keys [skip-check] :or {skip-check false}}] (when (and (not skip-check) (not (contains? cfeat/supported-features feature))) (ex/raise :type :assertion :code :feature-not-supported :hint (str "feature '" feature "' not supported"))) (let [team-id (h/parse-uuid team-id)] (db/tx-run! main/system (fn [{:keys [::db/conn]}] (let [team (-> (db/get conn :team {:id team-id}) (update :features db/decode-pgarray #{})) features (disj (:features team) feature)] (when (not= features (:features team)) (db/update! conn :team {:features (db/create-array conn "text" features)} {:id team-id}) :disabled)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; NOTIFICATIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn notify! "Send flash notifications. This method allows send flash notifications to specified target destinations. The message can be a free text or a preconfigured one. The destination can be: all, profile-id, team-id, or a coll of them. It also can be: {:email \"some@example.com\"} [[:email \"some@example.com\"], ...] Command examples: (notify! :dest :all :code :maintenance) (notify! :dest :all :code :upgrade-version) " [& {:keys [dest code message level] :or {code :generic level :info} :as params}] (when-not (contains? #{:success :error :info :warning} level) (ex/raise :type :assertion :code :incorrect-level :hint (str "level '" level "' not supported"))) (let [{:keys [::mbus/msgbus ::db/pool]} main/system send (fn [dest] (l/inf :hint "sending notification" :dest (str dest)) (let [message {:type :notification :code code :level level :version (:full cf/version) :subs-id dest :message message} message (->> (dissoc params :dest :code :message :level) (merge message))] (mbus/pub! msgbus :topic dest :message message))) resolve-profile (fn [email] (some-> (db/get* pool :profile {:email (str/lower email)} {:columns [:id]}) :id vector)) resolve-team (fn [team-id] (->> (db/query pool :team-profile-rel {:team-id team-id} {:columns [:profile-id]}) (map :profile-id))) resolve-dest (fn resolve-dest [dest] (cond (= :all dest) [uuid/zero] (uuid? dest) [dest] (string? dest) (some-> dest h/parse-uuid resolve-dest) (nil? dest) [uuid/zero] (map? dest) (sequence (comp (map vec) (mapcat resolve-dest)) dest) (and (vector? dest) (every? vector? dest)) (sequence (comp (map vec) (mapcat resolve-dest)) dest) (and (vector? dest) (keyword? (first dest))) (let [[op param] dest] (cond (= op :email) (cond (and (coll? param) (every? string? param)) (sequence (comp (keep resolve-profile) (mapcat identity)) param) (string? param) (resolve-profile param)) (= op :team-id) (cond (coll? param) (sequence (comp (mapcat resolve-team) (keep h/parse-uuid)) param) (uuid? param) (resolve-team param) (string? param) (some-> param h/parse-uuid resolve-team)) (= op :profile-id) (if (coll? param) (sequence (keep h/parse-uuid) param) (resolve-dest param))))))] (->> (resolve-dest dest) (filter some?) (into #{}) (run! send)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SNAPSHOTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn take-file-snapshot! "An internal helper that persist the file snapshot using non-gc collectable file-changes entry." [& {:keys [file-id label]}] (let [file-id (h/parse-uuid file-id)] (db/tx-run! main/system (fn [cfg] (let [file (bfc/get-file cfg file-id :realize? true)] (fsnap/create! cfg file {:label label :created-by "admin"})))))) (defn restore-file-snapshot! [file-id & {:keys [label id]}] (let [file-id (h/parse-uuid file-id) snapshot-id (some-> id h/parse-uuid)] (db/tx-run! main/system (fn [{:keys [::db/conn] :as system}] (cond (uuid? snapshot-id) (fsnap/restore! system file-id snapshot-id) (string? label) (->> (h/search-file-snapshots conn #{file-id} label) (map :id) (first) (fsnap/restore! system file-id)) :else (throw (ex-info "snapshot id or label should be provided" {}))))))) (defn list-file-snapshots! [file-id & {:as _}] (let [file-id (h/parse-uuid file-id)] (db/tx-run! main/system (fn [cfg] (->> (fsnap/get-visible-snapshots cfg file-id) (print-table [:label :id :revn :created-at :created-by])))))) (defn take-team-snapshot! [team-id & {:keys [label rollback?] :or {rollback? true}}] (let [team-id (h/parse-uuid team-id)] (-> (assoc main/system ::db/rollback rollback?) (db/tx-run! h/take-team-snapshot! team-id label)))) (defn restore-team-snapshot! "Restore a snapshot on all files of the team. The snapshot should exists for all files; if is not the case, an exception is raised." [team-id label & {:keys [rollback?] :or {rollback? true}}] (let [team-id (h/parse-uuid team-id)] (-> (assoc main/system ::db/rollback rollback?) (db/tx-run! h/restore-team-snapshot! team-id label)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; FILE VALIDATION & REPAIR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn validate-file "Validate structure, referencial integrity and semantic coherence of all contents of a file. Returns a list of errors." [file-id] (let [file-id (h/parse-uuid file-id)] (db/tx-run! (assoc main/system ::db/rollback true) (fn [system] (let [file (bfc/get-file system file-id) libs (bfc/get-resolved-file-libraries system file)] (cfv/validate-file file libs)))))) (defn validate-file-schema "Validate structure, referencial integrity and semantic coherence of all contents of a file. Returns a list of errors." [file-id] (let [file-id (h/parse-uuid file-id)] (db/tx-run! (assoc main/system ::db/rollback true) (fn [system] (try (let [file (bfc/get-file system file-id)] (cfv/validate-file-schema! file) (println "OK")) (catch Exception cause (if-let [explain (-> cause ex-data ::sm/explain)] (println (sm/humanize-explain explain)) (ex/print-throwable cause)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PROCESSING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn repair-file! "Repair the list of errors detected by validation." [file-id & {:keys [rollback?] :or {rollback? true} :as options}] (let [system (assoc main/system ::db/rollback rollback?) file-id (h/parse-uuid file-id) options (assoc options ::h/with-libraries? true)] (db/tx-run! system h/process-file! file-id procs.file-repair/repair-file options))) (defn update-file! "Apply a function to the file. Optionally save the changes or not. The function receives the decoded and migrated file data." [file-id update-fn & {:keys [rollback?] :or {rollback? true} :as opts}] (let [file-id (h/parse-uuid file-id)] (db/tx-run! (assoc main/system ::db/rollback rollback?) (fn [system] (binding [h/*system* system db/*conn* (db/get-connection system)] (h/process-file! system file-id update-fn opts)))))) (defn process! [& {:keys [max-items max-jobs rollback? query proc-fn buffer] :or {max-items Long/MAX_VALUE rollback? true max-jobs 1 buffer 128} :as opts}] (l/inf :hint "process start" :rollback rollback? :max-jobs max-jobs :max-items max-items) (let [tpoint (ct/tpoint) max-jobs (or max-jobs (px/get-available-processors)) query (or query (:query (meta proc-fn)) (throw (ex-info "missing query" {}))) query (if (vector? query) query [query]) proc-fn (if (var? proc-fn) (deref proc-fn) proc-fn) in-ch (sp/chan :buf buffer) worker-fn (fn [worker-id] (l/dbg :hint "worker started" :id worker-id) (loop [] (when-let [[index item] (sp/ main/system (assoc ::db/rollback rollback?) (db/tx-run! (fn [system] (binding [h/*system* system db/*conn* (db/get-connection system)] (proc-fn system item opts))))) (catch Throwable cause (l/wrn :hint "unexpected error on processing item (skiping)" :worker-id worker-id :item item :cause cause)) (finally (when-let [pause (:pause opts)] (Thread/sleep (int pause))))) (recur))) (l/dbg :hint "worker stoped" :id worker-id)) enqueue-item (fn [index row] (sp/>! in-ch [index (into {} row)]) (inc index)) process-items (fn [{:keys [::db/conn] :as system}] (db/exec! conn ["SET statement_timeout = 0"]) (db/exec! conn ["SET idle_in_transaction_session_timeout = 0"]) (->> (db/plan conn query {:fetch-size (* max-jobs 3)}) (transduce (take max-items) (completing enqueue-item) 0)) (sp/close! in-ch)) threads (->> (range max-jobs) (map (fn [idx] (px/fn->thread (partial worker-fn idx) :name (str "pentpot/process/" idx)))) (doall))] (try (db/tx-run! main/system process-items) ;; Await threads termination (doseq [thread threads] (px/await! thread)) (catch Throwable cause (l/dbg :hint "process:error" :cause cause)) (finally (let [elapsed (ct/format-duration (tpoint))] (l/inf :hint "process end" :rollback rollback? :elapsed elapsed)))))) (defn process-file! "A specialized, file specific process! alternative" [& {:keys [id] :as opts}] (let [id (h/parse-uuid id)] (-> opts (assoc :query ["select id from file where id = ?" id]) (assoc :max-items 1) (assoc :max-jobs 1) (process!)))) (defn mark-file-as-trimmed [id] (let [id (h/parse-uuid id)] (db/tx-run! main/system (fn [cfg] (-> (db/update! cfg :file {:has-media-trimmed true} {:id id} {::db/return-keys false}) (db/get-update-count) (pos?)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DELETE/RESTORE OBJECTS (WITH CASCADE, SOFT) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn delete-file! "Mark a project for deletion" [file-id] (let [file-id (h/parse-uuid file-id) tnow (ct/now)] (audit/insert! main/system {::audit/name "delete-file" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props {:id file-id} ::audit/context {:triggered-by "srepl" :cause "explicit call to delete-file!"} ::audit/tracked-at tnow}) (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :file :deleted-at tnow :id file-id}))) :deleted)) (defn restore-file! "Mark a file and all related objects as not deleted" [file-id] (let [file-id (h/parse-uuid file-id)] (db/tx-run! main/system (fn [{:keys [::db/conn] :as system}] (when-let [file (db/get* system :file {:id file-id} {::db/remove-deleted false ::sql/columns [:id :name]})] (audit/insert! system {::audit/name "restore-file" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props file ::audit/context {:triggered-by "srepl" :cause "explicit call to restore-file!"} ::audit/tracked-at (ct/now)}) (#'files/restore-files conn [file-id])) :restored)))) (defn delete-project! "Mark a project for deletion" [project-id] (let [project-id (h/parse-uuid project-id) tnow (ct/now)] (audit/insert! main/system {::audit/name "delete-project" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props {:id project-id} ::audit/context {:triggered-by "srepl" :cause "explicit call to delete-project!"} ::audit/tracked-at tnow}) (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :project :deleted-at tnow :id project-id}))) :deleted)) (defn- restore-project* [{:keys [::db/conn] :as cfg} project-id] (db/update! conn :project {:deleted-at nil} {:id project-id}) (doseq [{:keys [id]} (db/query conn :file {:project-id project-id} {::sql/columns [:id]})] (#'files/restore-files conn [id])) :restored) (defn restore-project! "Mark a project and all related objects as not deleted" [project-id] (let [project-id (h/parse-uuid project-id)] (db/tx-run! main/system (fn [system] (when-let [project (db/get* system :project {:id project-id} {::db/remove-deleted false})] (audit/insert! system {::audit/name "restore-project" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props project ::audit/context {:triggered-by "srepl" :cause "explicit call to restore-team!"} ::audit/tracked-at (ct/now)}) (restore-project* system project-id)))))) (defn delete-team! "Mark a team for deletion" [team-id] (let [team-id (h/parse-uuid team-id) tnow (ct/now)] (audit/insert! main/system {::audit/name "delete-team" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props {:id team-id} ::audit/context {:triggered-by "srepl" :cause "explicit call to delete-profile!"} ::audit/tracked-at tnow}) (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :team :deleted-at tnow :id team-id}))) :deleted)) (defn- restore-team* [{:keys [::db/conn] :as cfg} team-id] (db/update! conn :team {:deleted-at nil} {:id team-id}) (db/update! conn :team-font-variant {:deleted-at nil} {:team-id team-id}) (doseq [{:keys [id]} (db/query conn :project {:team-id team-id} {::sql/columns [:id]})] (restore-project* cfg id)) :restored) (defn restore-team! "Mark a team and all related objects as not deleted" [team-id] (let [team-id (h/parse-uuid team-id)] (db/tx-run! main/system (fn [system] (when-let [team (some-> (db/get* system :team {:id team-id} {::db/remove-deleted false}) (teams/decode-row))] (audit/insert! system {::audit/name "restore-team" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props team ::audit/context {:triggered-by "srepl" :cause "explicit call to restore-team!"} ::audit/tracked-at (ct/now)}) (restore-team* system team-id)))))) (defn delete-profile! "Mark a profile for deletion." [profile-id] (let [profile-id (h/parse-uuid profile-id) tnow (ct/now)] (audit/insert! main/system {::audit/name "delete-profile" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/context {:triggered-by "srepl" :cause "explicit call to delete-profile!"} ::audit/tracked-at tnow}) (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :profile :deleted-at tnow :id profile-id}))) :deleted)) (defn restore-profile! "Mark a team and all related objects as not deleted" [profile-id] (let [profile-id (h/parse-uuid profile-id)] (db/tx-run! main/system (fn [system] (when-let [profile (some-> (db/get* system :profile {:id profile-id} {::db/remove-deleted false}) (profile/decode-row))] (audit/insert! system {::audit/name "restore-profile" ::audit/type "action" ::audit/profile-id uuid/zero ::audit/props (audit/profile->props profile) ::audit/context {:triggered-by "srepl" :cause "explicit call to restore-profile!"} ::audit/tracked-at (ct/now)}) (db/update! system :profile {:deleted-at nil} {:id profile-id} {::db/return-keys false}) (doseq [{:keys [id]} (profile/get-owned-teams system profile-id)] (restore-team* system id)) :restored))))) (defn delete-profiles-in-bulk! [system path] (letfn [(process-data! [system deleted-at emails] (loop [emails emails deleted 0 total 0] (if-let [email (first emails)] (if-let [profile (some-> (db/get* system :profile {:email (str/lower email)} {::db/remove-deleted false}) (profile/decode-row))] (do (audit/insert! system {::audit/name "delete-profile" ::audit/type "action" ::audit/profile-id (:id profile) ::audit/tracked-at deleted-at ::audit/props (audit/profile->props profile) ::audit/context {:triggered-by "srepl" :cause "explicit call to delete-profiles-in-bulk!"}}) (wrk/invoke! (-> system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :profile :deleted-at deleted-at :id (:id profile)}))) (recur (rest emails) (inc deleted) (inc total))) (recur (rest emails) deleted (inc total))) {:deleted deleted :total total})))] (let [path (fs/path path) deleted-at (ct/minus (ct/now) (cf/get-deletion-delay))] (when-not (fs/exists? path) (throw (ex-info "path does not exists" {:path path}))) (db/tx-run! system (fn [system] (with-open [reader (io/reader path)] (process-data! system deleted-at (line-seq reader)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CASCADE FIXING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn process-deleted-profiles-cascade [] (->> (db/exec! main/system ["select id, deleted_at from profile where deleted_at is not null"]) (run! (fn [{:keys [id deleted-at]}] (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :profile :deleted-at deleted-at :id id}))))))) (defn process-deleted-teams-cascade [] (->> (db/exec! main/system ["select id, deleted_at from team where deleted_at is not null"]) (run! (fn [{:keys [id deleted-at]}] (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :team :deleted-at deleted-at :id id}))))))) (defn process-deleted-projects-cascade [] (->> (db/exec! main/system ["select id, deleted_at from project where deleted_at is not null"]) (run! (fn [{:keys [id deleted-at]}] (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :project :deleted-at deleted-at :id id}))))))) (defn process-deleted-files-cascade [] (->> (db/exec! main/system ["select id, deleted_at from file where deleted_at is not null"]) (run! (fn [{:keys [id deleted-at]}] (wrk/invoke! (-> main/system (assoc ::wrk/task :delete-object) (assoc ::wrk/params {:object :file :deleted-at deleted-at :id id}))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SSO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn add-sso-config [& {:keys [base-uri client-id client-secret domain]}] (assert (and (string? base-uri) (str/starts-with? base-uri "http")) "expected a valid base-uri") (assert (string? client-id) "expected a valid client-id") (assert (string? client-secret) "expected a valid client-secret") (assert (string? domain) "expected a valid domain") (db/insert! main/system :sso-provider {:id (uuid/next) :type "oidc" :client-id client-id :client-secret client-secret :domain domain :base-uri base-uri})) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; MISC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn decode-session-token [token] (session/decode-token main/system token)) (defn instrument-var [var] (alter-var-root var (fn [f] (let [mf (meta f)] (if (::original mf) f (with-meta (fn [& params] (tap> params) (let [result (apply f params)] (tap> result) result)) {::original f})))))) (defn uninstrument-var [var] (alter-var-root var (fn [f] (or (::original (meta f)) f)))) (defn duplicate-team [team-id & {:keys [name]}] (let [team-id (h/parse-uuid team-id)] (db/tx-run! main/system (fn [{:keys [::db/conn] :as cfg}] (db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"]) (let [team (-> (assoc cfg ::bfc/timestamp (ct/now)) (mgmt/duplicate-team :team-id team-id :name name)) rels (db/query conn :team-profile-rel {:team-id team-id})] (doseq [rel rels] (let [params (-> rel (assoc :id (uuid/next)) (assoc :team-id (:id team)))] (teams/add-profile-to-team! cfg params {::db/return-keys false}))))))))