0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-20 19:51:23 -05:00

Merge pull request from penpot/niwinz-hot-improvements

Enhancements
This commit is contained in:
Alejandro 2022-09-21 10:01:31 +02:00 committed by GitHub
commit cc18f84d62
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
532 changed files with 1483 additions and 1244 deletions

View file

@ -23,6 +23,10 @@
- Add Libraries & Templates carousel [Taiga #3860](https://tree.taiga.io/project/penpot/us/3860)
- Ungroup frames [Taiga #4012](https://tree.taiga.io/project/penpot/us/4012)
- Newsletter Opt-in options for subscription categories [Taiga #3242](https://tree.taiga.io/project/penpot/us/3242)
- Print emails to console by default if smtp is disabled
- Add `email-verification` flag for enable/disable email verification
### :bug: Bugs fixed
@ -53,6 +57,7 @@
- Fix issue when scaling to value 0 [#2252](https://github.com/penpot/penpot/issues/2252)
- Fix problem when moving shapes inside nested frames [Taiga #4113](https://tree.taiga.io/project/penpot/issue/4113)
## 1.15.3-beta
### :bug: Bugs fixed

View file

@ -71,7 +71,8 @@
{:extra-paths ["test"]
:extra-deps
{io.github.cognitect-labs/test-runner
{:git/tag "v0.5.0" :git/sha "b3fd0d2"}}
{:git/tag "v0.5.1" :git/sha "dfb30dd"}}
:main-opts ["-m" "cognitect.test-runner"]
:exec-fn cognitect.test-runner.api/test}
:outdated

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
;; This is an example on how it can be executed:
;; clojure -Scp $(cat classpath) -M dev/script-fix-sobjects.clj

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns user
(:require
@ -74,7 +74,7 @@
[]
(alter-var-root #'system (fn [sys]
(when sys (ig/halt! sys))
(-> main/system-config
(-> (merge main/system-config main/worker-config)
(ig/prep)
(ig/init))))
:started)

View file

@ -2,7 +2,7 @@
export PENPOT_HOST=devenv
export PENPOT_TENANT=dev
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-rpc-rate-limit enable-warn-rpc-rate-limits"
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-rpc-rate-limit enable-warn-rpc-rate-limits enable-smtp"
# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot"
# export PENPOT_DATABASE_USERNAME="penpot"

View file

@ -2,7 +2,7 @@
export PENPOT_HOST=devenv
export PENPOT_TENANT=dev
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies"
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-smtp"
set -ex

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.auth.ldap
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.auth.oidc
"OIDC client implementation."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.cli.manage
"A manage cli api."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.config
"A configuration management."
@ -11,7 +11,6 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.flags :as flags]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.version :as v]
[app.util.time :as dt]
@ -94,7 +93,6 @@
(s/def ::telemetry-enabled ::us/boolean)
(s/def ::audit-log-archive-uri ::us/string)
(s/def ::audit-log-gc-max-age ::dt/duration)
(s/def ::admins ::us/set-of-strings)
(s/def ::file-change-snapshot-every ::us/integer)
@ -171,12 +169,11 @@
(s/def ::redis-uri ::us/string)
(s/def ::registration-domain-whitelist ::us/set-of-strings)
(s/def ::semaphore-font-process ::us/integer)
(s/def ::semaphore-file-update ::us/integer)
(s/def ::semaphore-image-process ::us/integer)
(s/def ::semaphore-authentication ::us/integer)
(s/def ::rpc-semaphore-permits-font ::us/integer)
(s/def ::rpc-semaphore-permits-file-update ::us/integer)
(s/def ::rpc-semaphore-permits-image ::us/integer)
(s/def ::rpc-semaphore-permits-password ::us/integer)
(s/def ::smtp-default-from ::us/string)
(s/def ::smtp-default-reply-to ::us/string)
(s/def ::smtp-host ::us/string)
@ -212,7 +209,6 @@
::admins
::allow-demo-users
::audit-log-archive-uri
::audit-log-gc-max-age
::auth-token-cookie-name
::auth-token-cookie-max-age
::authenticated-cookie-name
@ -280,10 +276,12 @@
::public-uri
::redis-uri
::registration-domain-whitelist
::rpc-semaphore-permits-font
::rpc-semaphore-permits-file-update
::rpc-semaphore-permits-image
::rpc-semaphore-permits-password
::semaphore-process-font
::semaphore-process-image
::semaphore-update-file
::semaphore-auth
::rpc-rlimit-config
::sentry-dsn
::sentry-debug
@ -318,7 +316,8 @@
(def default-flags
[:enable-backend-api-doc
:enable-backend-worker
:enable-secure-session-cookies])
:enable-secure-session-cookies
:enable-email-verification])
(defn- parse-flags
[config]
@ -359,11 +358,7 @@
"%version%")))
(defonce ^:dynamic config (read-config))
(defonce ^:dynamic flags
(let [flags (parse-flags config)]
(l/info :hint "flags initialized" :flags (str/join "," (map name flags)))
flags))
(defonce ^:dynamic flags (parse-flags config))
(def deletion-delay
(dt/duration {:days 7}))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.db
(:require
@ -75,7 +75,7 @@
(def defaults
{:name :main
:min-size 0
:max-size 30
:max-size 60
:connection-timeout 10000
:validation-timeout 10000
:idle-timeout 120000 ; 2min
@ -367,23 +367,23 @@
(.rollback conn sp)))
(defn interval
[data]
[o]
(cond
(integer? data)
(->> (/ data 1000.0)
(or (integer? o)
(float? o))
(->> (/ o 1000.0)
(format "%s seconds")
(pginterval))
(string? data)
(pginterval data)
(string? o)
(pginterval o)
(dt/duration? data)
(->> (/ (.toMillis ^java.time.Duration data) 1000.0)
(format "%s seconds")
(pginterval))
(dt/duration? o)
(interval (inst-ms o))
:else
(ex/raise :type :not-implemented)))
(ex/raise :type :not-implemented
:hint (format "no implementation found for value %s" (pr-str o)))))
(defn decode-json-pgobject
[^PGobject o]

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.db.sql
(:refer-clojure :exclude [update])

View file

@ -2,30 +2,263 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.emails
"Main api for send emails."
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.util.emails :as emails]
[app.emails.invite-to-team :as-alias emails.invite-to-team]
[app.metrics :as mtx]
[app.util.template :as tmpl]
[app.worker :as wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[cuerdas.core :as str]
[integrant.core :as ig])
(:import
jakarta.mail.Message$RecipientType
jakarta.mail.Session
jakarta.mail.Transport
jakarta.mail.internet.InternetAddress
jakarta.mail.internet.MimeBodyPart
jakarta.mail.internet.MimeMessage
jakarta.mail.internet.MimeMultipart
java.util.Properties))
;; --- PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EMAIL IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- parse-address
[v]
(InternetAddress/parse ^String v))
(defn- resolve-recipient-type
^Message$RecipientType
[type]
(case type
:to Message$RecipientType/TO
:cc Message$RecipientType/CC
:bcc Message$RecipientType/BCC))
(defn- assign-recipient
[^MimeMessage mmsg type address]
(if (sequential? address)
(reduce #(assign-recipient %1 type %2) mmsg address)
(let [address (parse-address address)
type (resolve-recipient-type type)]
(.addRecipients mmsg type address)
mmsg)))
(defn- assign-recipients
[mmsg {:keys [to cc bcc] :as params}]
(cond-> mmsg
(some? to) (assign-recipient :to to)
(some? cc) (assign-recipient :cc cc)
(some? bcc) (assign-recipient :bcc bcc)))
(defn- assign-from
[mmsg {:keys [default-from]} {:keys [from] :as props}]
(let [from (or from default-from)]
(when from
(let [from (parse-address from)]
(.addFrom ^MimeMessage mmsg from)))))
(defn- assign-reply-to
[mmsg {:keys [default-reply-to] :as cfg} {:keys [reply-to] :as params}]
(let [reply-to (or reply-to default-reply-to)]
(when reply-to
(let [reply-to (parse-address reply-to)]
(.setReplyTo ^MimeMessage mmsg reply-to)))))
(defn- assign-subject
[mmsg {:keys [subject charset] :or {charset "utf-8"} :as params}]
(assert (string? subject) "subject is mandatory")
(.setSubject ^MimeMessage mmsg
^String subject
^String charset))
(defn- assign-extra-headers
[^MimeMessage mmsg {:keys [headers extra-data] :as params}]
(let [headers (assoc headers "X-Penpot-Data" extra-data)]
(reduce-kv (fn [^MimeMessage mmsg k v]
(doto mmsg
(.addHeader (name k) (str v))))
mmsg
headers)))
(defn- assign-body
[^MimeMessage mmsg {:keys [body charset] :or {charset "utf-8"}}]
(let [mpart (MimeMultipart. "mixed")]
(cond
(string? body)
(let [bpart (MimeBodyPart.)]
(.setContent bpart ^String body (str "text/plain; charset=" charset))
(.addBodyPart mpart bpart))
(vector? body)
(let [mmp (MimeMultipart. "alternative")
mbp (MimeBodyPart.)]
(.addBodyPart mpart mbp)
(.setContent mbp mmp)
(doseq [item body]
(let [mbp (MimeBodyPart.)]
(.setContent mbp
^String (:content item)
^String (str (:type item "text/plain") "; charset=" charset))
(.addBodyPart mmp mbp))))
(map? body)
(let [bpart (MimeBodyPart.)]
(.setContent bpart
^String (:content body)
^String (str (:type body "text/plain") "; charset=" charset))
(.addBodyPart mpart bpart))
:else
(throw (ex-info "Unsupported type" {:body body})))
(.setContent mmsg mpart)
mmsg))
(defn- opts->props
[{:keys [username tls host port timeout default-from]
:or {timeout 30000}
:as opts}]
(reduce-kv
(fn [^Properties props k v]
(if (nil? v)
props
(doto props (.put ^String k ^String (str v)))))
(Properties.)
{"mail.user" username
"mail.host" host
"mail.from" default-from
"mail.smtp.auth" (boolean username)
"mail.smtp.starttls.enable" tls
"mail.smtp.starttls.required" tls
"mail.smtp.host" host
"mail.smtp.port" port
"mail.smtp.user" username
"mail.smtp.timeout" timeout
"mail.smtp.connectiontimeout" timeout}))
(defn- create-smtp-session
[{:keys [debug] :or {debug false} :as opts}]
(let [props (opts->props opts)
session (Session/getInstance props)]
(.setDebug session debug)
session))
(defn- create-smtp-message
^MimeMessage
[cfg params]
(let [session (create-smtp-session cfg)
mmsg (MimeMessage. ^Session session)]
(assign-recipients mmsg params)
(assign-from mmsg cfg params)
(assign-reply-to mmsg cfg params)
(assign-subject mmsg params)
(assign-extra-headers mmsg params)
(assign-body mmsg params)
(.saveChanges ^MimeMessage mmsg)
mmsg))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TEMPLATE EMAIL IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private email-path "app/emails/%(id)s/%(lang)s.%(type)s")
(defn- render-email-template-part
[type id context]
(let [lang (:lang context :en)
path (str/format email-path {:id (name id)
:lang (name lang)
:type (name type)})]
(some-> (io/resource path)
(tmpl/render context))))
(defn- build-email-template
[id context]
(let [subj (render-email-template-part :subj id context)
text (render-email-template-part :txt id context)
html (render-email-template-part :html id context)]
(when (or (not subj)
(and (not text)
(not html)))
(ex/raise :type :internal
:code :missing-email-templates))
{:subject subj
:body (into
[{:type "text/plain"
:content text}]
(when html
[{:type "text/html"
:content html}]))}))
(s/def ::priority #{:high :low})
(s/def ::to (s/or :single ::us/email
:multi (s/coll-of ::us/email)))
(s/def ::from ::us/email)
(s/def ::reply-to ::us/email)
(s/def ::lang string?)
(s/def ::extra-data ::us/string)
(s/def ::context
(s/keys :req-un [::to]
:opt-un [::reply-to ::from ::lang ::priority ::extra-data]))
(defn template-factory
([id] (template-factory id {}))
([id extra-context]
(s/assert keyword? id)
(fn [context]
(us/verify ::context context)
(when-let [spec (s/get-spec id)]
(s/assert spec context))
(let [context (merge (if (fn? extra-context)
(extra-context)
extra-context)
context)
email (build-email-template id context)]
(when-not email
(ex/raise :type :internal
:code :email-template-does-not-exists
:hint "seems like the template is wrong or does not exists."
:context {:id id}))
(cond-> (assoc email :id (name id))
(:extra-data context)
(assoc :extra-data (:extra-data context))
(:from context)
(assoc :from (:from context))
(:reply-to context)
(assoc :reply-to (:reply-to context))
(:to context)
(assoc :to (:to context)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC HIGH-LEVEL API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn render
[email-factory context]
(email-factory context))
(defn send!
"Schedule the email for sending."
"Schedule an already defined email to be sent using asynchronously
using worker task."
[{:keys [::conn ::factory] :as context}]
(us/verify fn? factory)
(us/verify some? conn)
@ -33,12 +266,130 @@
(wrk/submit! (assoc email
::wrk/task :sendmail
::wrk/delay 0
::wrk/max-retries 1
::wrk/max-retries 4
::wrk/priority 200
::wrk/conn conn))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SENDMAIL FN / TASK HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- BOUNCE/COMPLAINS HANDLING
(s/def ::username ::cf/smtp-username)
(s/def ::password ::cf/smtp-password)
(s/def ::tls ::cf/smtp-tls)
(s/def ::ssl ::cf/smtp-ssl)
(s/def ::host ::cf/smtp-host)
(s/def ::port ::cf/smtp-port)
(s/def ::default-reply-to ::cf/smtp-default-reply-to)
(s/def ::default-from ::cf/smtp-default-from)
(s/def ::smtp-config
(s/keys :opt-un [::username
::password
::tls
::ssl
::host
::port
::default-from
::default-reply-to]))
(declare send-to-logger!)
(s/def ::sendmail fn?)
(defmethod ig/pre-init-spec ::sendmail [_]
(s/spec ::smtp-config))
(defmethod ig/init-key ::sendmail
[_ cfg]
(fn [params]
(when (contains? cf/flags :smtp)
(Transport/send (create-smtp-message cfg params)
(:username cfg)
(:password cfg)))
(when (or (contains? cf/flags :log-emails)
(not (contains? cf/flags :smtp)))
(send-to-logger! cfg params))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::sendmail ::mtx/metrics]))
(defmethod ig/init-key ::handler
[_ {:keys [sendmail]}]
(fn [{:keys [props] :as task}]
(sendmail props)))
(defn- send-to-logger!
[_ email]
(let [body (:body email)
out (with-out-str
(println "email console dump:")
(println "******** start email" (:id email) "**********")
(pp/pprint (dissoc email :body))
(if (string? body)
(println body)
(println (->> body
(filter #(= "text/plain" (:type %)))
(map :content)
first)))
(println "******** end email" (:id email) "**********"))]
(l/info ::l/raw out)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EMAIL FACTORIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::subject ::us/string)
(s/def ::content ::us/string)
(s/def ::feedback
(s/keys :req-un [::subject ::content]))
(def feedback
"A profile feedback email."
(template-factory ::feedback))
(s/def ::name ::us/string)
(s/def ::register
(s/keys :req-un [::name]))
(def register
"A new profile registration welcome email."
(template-factory ::register))
(s/def ::token ::us/string)
(s/def ::password-recovery
(s/keys :req-un [::name ::token]))
(def password-recovery
"A password recovery notification email."
(template-factory ::password-recovery))
(s/def ::pending-email ::us/email)
(s/def ::change-email
(s/keys :req-un [::name ::pending-email ::token]))
(def change-email
"Password change confirmation email"
(template-factory ::change-email))
(s/def ::emails.invite-to-team/invited-by ::us/string)
(s/def ::emails.invite-to-team/team ::us/string)
(s/def ::emails.invite-to-team/token ::us/string)
(s/def ::invite-to-team
(s/keys :req-un [::emails.invite-to-team/invited-by
::emails.invite-to-team/token
::emails.invite-to-team/team]))
(def invite-to-team
"Teams member invitation email."
(template-factory ::invite-to-team))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BOUNCE/COMPLAINS HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:profile-complaint-report
"select (select count(*)
@ -85,106 +436,3 @@
{:email email :type "bounce"}
{:limit 10}))]
(>= (count reports) threshold))))
;; --- EMAIL FACTORIES
(s/def ::subject ::us/string)
(s/def ::content ::us/string)
(s/def ::feedback
(s/keys :req-un [::subject ::content]))
(def feedback
"A profile feedback email."
(emails/template-factory ::feedback))
(s/def ::name ::us/string)
(s/def ::register
(s/keys :req-un [::name]))
(def register
"A new profile registration welcome email."
(emails/template-factory ::register))
(s/def ::token ::us/string)
(s/def ::password-recovery
(s/keys :req-un [::name ::token]))
(def password-recovery
"A password recovery notification email."
(emails/template-factory ::password-recovery))
(s/def ::pending-email ::us/email)
(s/def ::change-email
(s/keys :req-un [::name ::pending-email ::token]))
(def change-email
"Password change confirmation email"
(emails/template-factory ::change-email))
(s/def :internal.emails.invite-to-team/invited-by ::us/string)
(s/def :internal.emails.invite-to-team/team ::us/string)
(s/def :internal.emails.invite-to-team/token ::us/string)
(s/def ::invite-to-team
(s/keys :req-un [:internal.emails.invite-to-team/invited-by
:internal.emails.invite-to-team/token
:internal.emails.invite-to-team/team]))
(def invite-to-team
"Teams member invitation email."
(emails/template-factory ::invite-to-team))
;; --- SENDMAIL TASK
(declare send-console!)
(s/def ::username ::cf/smtp-username)
(s/def ::password ::cf/smtp-password)
(s/def ::tls ::cf/smtp-tls)
(s/def ::ssl ::cf/smtp-ssl)
(s/def ::host ::cf/smtp-host)
(s/def ::port ::cf/smtp-port)
(s/def ::default-reply-to ::cf/smtp-default-reply-to)
(s/def ::default-from ::cf/smtp-default-from)
(defmethod ig/pre-init-spec ::sendmail-handler [_]
(s/keys :opt-un [::username
::password
::tls
::ssl
::host
::port
::default-from
::default-reply-to]))
(defmethod ig/init-key ::sendmail-handler
[_ cfg]
(fn [{:keys [props] :as task}]
(let [enabled? (or (contains? cf/flags :smtp)
(cf/get :smtp-enabled)
(:enabled task))]
(when enabled?
(emails/send! cfg props))
(when (contains? cf/flags :log-emails)
(send-console! cfg props)))))
(defn- send-console!
[_ email]
(let [body (:body email)
out (with-out-str
(println "email console dump:")
(println "******** start email" (:id email) "**********")
(pp/pprint (dissoc email :body))
(if (string? body)
(println body)
(println (->> body
(filter #(= "text/plain" (:type %)))
(map :content)
first)))
(println "******** end email" (:id email) "**********"))]
(l/info ::l/raw out)))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.assets
"Assets related handlers."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.awsns
"AWS SNS webhook handler for bounces."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.client
"Http client abstraction layer."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.debug
(:refer-clojure :exclude [error-handler])

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.errors
"A errors handling for the http server."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.feedback
"A general purpose feedback module."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.middleware
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.session
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.http.websocket
"A penpot notification service for file cooperative edition."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.audit
"Services related to the user activity (audit log)."
@ -264,7 +264,7 @@
(let [n (archive-events cfg)]
(if n
(do
(aa/thread-sleep 200)
(aa/thread-sleep 100)
(recur (+ total n)))
(when (pos? total)
(l/trace :hint "events chunk archived" :num total)))))))))
@ -345,23 +345,18 @@
(def sql:clean-archived
"delete from audit_log
where archived_at is not null
and archived_at < now() - ?::interval")
where archived_at is not null")
(defn- clean-archived
[{:keys [pool max-age]}]
(let [interval (db/interval max-age)
result (db/exec-one! pool [sql:clean-archived interval])
result (:next.jdbc/update-count result)]
(l/debug :action "clean archived audit log" :removed result)
[{:keys [pool]}]
(let [result (db/exec-one! pool [sql:clean-archived])
result (:next.jdbc/update-count result)]
(l/debug :hint "delete archived audit log entries" :deleted result)
result))
(s/def ::max-age ::cf/audit-log-gc-max-age)
(defmethod ig/pre-init-spec ::gc-task [_]
(s/keys :req-un [::db/pool ::max-age]))
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::gc-task
[_ cfg]
(fn [_]
(clean-archived cfg)))
(partial clean-archived cfg))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.database
"A specific logger impl that persists errors on the database."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.loki
"A Loki integration."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.mattermost
"A mattermost integration for error reporting."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.sentry
"A mattermost integration for error reporting."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.loggers.zmq
"A generic ZMQ listener."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.main
(:require
@ -10,6 +10,7 @@
[app.common.logging :as l]
[app.config :as cf]
[app.util.time :as dt]
[cuerdas.core :as str]
[integrant.core :as ig])
(:gen-class))
@ -23,36 +24,26 @@
:migrations (ig/ref :app.migrations/all)
:name :main
:min-size (cf/get :database-min-pool-size 0)
:max-size (cf/get :database-max-pool-size 30)}
:max-size (cf/get :database-max-pool-size 60)}
;; Default thread pool for IO operations
[::default :app.worker/executor]
{:parallelism (cf/get :default-executor-parallelism 60)
:prefix :default}
;; Constrained thread pool. Should only be used from high resources
;; demanding operations.
[::blocking :app.worker/executor]
{:parallelism (cf/get :blocking-executor-parallelism 10)
:prefix :blocking}
{:parallelism (cf/get :default-executor-parallelism 70)}
;; Dedicated thread pool for backround tasks execution.
[::worker :app.worker/executor]
{:parallelism (cf/get :worker-executor-parallelism 10)
:prefix :worker}
{:parallelism (cf/get :worker-executor-parallelism 20)}
:app.worker/scheduler
{:parallelism 1
:prefix :scheduler}
:app.worker/executors
{:default (ig/ref [::default :app.worker/executor])
:worker (ig/ref [::worker :app.worker/executor])
:blocking (ig/ref [::blocking :app.worker/executor])}
{:default (ig/ref [::default :app.worker/executor])
:worker (ig/ref [::worker :app.worker/executor])}
:app.worker/executors-monitor
:app.worker/executor-monitor
{:metrics (ig/ref :app.metrics/metrics)
:scheduler (ig/ref :app.worker/scheduler)
:executors (ig/ref :app.worker/executors)}
:app.migrations/migrations
@ -216,6 +207,10 @@
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::default :app.worker/executor])}
:app.rpc/semaphores
{:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref [::default :app.worker/executor])}
:app.rpc/rlimit
{:executor (ig/ref [::worker :app.worker/executor])
:scheduler (ig/ref :app.worker/scheduler)}
@ -234,7 +229,10 @@
:http-client (ig/ref :app.http/client)
:rlimit (ig/ref :app.rpc/rlimit)
:executors (ig/ref :app.worker/executors)
:templates (ig/ref :app.setup/builtin-templates)}
:executor (ig/ref [::default :app.worker/executor])
:templates (ig/ref :app.setup/builtin-templates)
:semaphores (ig/ref :app.rpc/semaphores)
}
:app.rpc.doc/routes
{:methods (ig/ref :app.rpc/methods)}
@ -245,7 +243,7 @@
:app.worker/registry
{:metrics (ig/ref :app.metrics/metrics)
:tasks
{:sendmail (ig/ref :app.emails/sendmail-handler)
{:sendmail (ig/ref :app.emails/handler)
:objects-gc (ig/ref :app.tasks.objects-gc/handler)
:file-gc (ig/ref :app.tasks.file-gc/handler)
:file-xlog-gc (ig/ref :app.tasks.file-xlog-gc/handler)
@ -257,17 +255,21 @@
:audit-log-archive (ig/ref :app.loggers.audit/archive-task)
:audit-log-gc (ig/ref :app.loggers.audit/gc-task)}}
:app.emails/sendmail-handler
:app.emails/sendmail
{:host (cf/get :smtp-host)
:port (cf/get :smtp-port)
:ssl (cf/get :smtp-ssl)
:tls (cf/get :smtp-tls)
:username (cf/get :smtp-username)
:password (cf/get :smtp-password)
:metrics (ig/ref :app.metrics/metrics)
:default-reply-to (cf/get :smtp-default-reply-to)
:default-from (cf/get :smtp-default-from)}
:app.emails/handler
{:sendmail (ig/ref :app.emails/sendmail)
:metrics (ig/ref :app.metrics/metrics)}
:app.tasks.tasks-gc/handler
{:pool (ig/ref :app.db/pool)
:max-age cf/deletion-delay}
@ -318,8 +320,7 @@
:http-client (ig/ref :app.http/client)}
:app.loggers.audit/gc-task
{:max-age (cf/get :audit-log-gc-max-age cf/deletion-delay)
:pool (ig/ref :app.db/pool)}
{:pool (ig/ref :app.db/pool)}
:app.loggers.loki/reporter
{:uri (cf/get :loggers-loki-uri)
@ -360,7 +361,7 @@
(def worker-config
{ :app.worker/cron
{:app.worker/cron
{:executor (ig/ref [::worker :app.worker/executor])
:scheduler (ig/ref :app.worker/scheduler)
:tasks (ig/ref :app.worker/registry)
@ -395,7 +396,7 @@
:task :audit-log-archive})
(when (contains? cf/flags :audit-log-gc)
{:cron #app/cron "0 0 0 * * ?" ;; daily
{:cron #app/cron "30 */5 * * * ?" ;; every 5m
:task :audit-log-gc})]}
:app.worker/worker
@ -417,6 +418,8 @@
(ig/prep)
(ig/init))))
(l/info :msg "welcome to penpot"
:flags (str/join "," (map name cf/flags))
:worker? (contains? cf/flags :backend-worker)
:version (:full cf/version)))
(defn stop

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.media
"Media & Font postprocessing."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.metrics
(:refer-clojure :exclude [run!])
@ -100,23 +100,23 @@
::mdef/labels ["name"]
::mdef/type :summary}
:rpc-semaphore-queued-submissions
{::mdef/name "penpot_rpc_semaphore_queued_submissions"
::mdef/help "Current number of queued submissions on RPC-SEMAPHORE."
:semaphore-queued-submissions
{::mdef/name "penpot_semaphore_queued_submissions"
::mdef/help "Current number of queued submissions on SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :gauge}
:rpc-semaphore-used-permits
{::mdef/name "penpot_rpc_semaphore_used_permits"
::mdef/help "Current number of used permits on RPC-SEMAPHORE."
:semaphore-used-permits
{::mdef/name "penpot_semaphore_used_permits"
::mdef/help "Current number of used permits on SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :gauge}
:rpc-semaphore-acquires-total
{::mdef/name "penpot_rpc_semaphore_acquires_total"
::mdef/help "Total number of acquire operations on RPC-SEMAPHORE."
:semaphore-timing
{::mdef/name "penpot_semaphore_timing"
::mdef/help "Total timing of SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :counter}
::mdef/type :summary}
:executors-active-threads
{::mdef/name "penpot_executors_active_threads"

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.migrations
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.migrations.clj.migration-0023
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.msgbus
"The msgbus abstraction implemented using redis as underlying backend."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.redis
"The msgbus abstraction implemented using redis as underlying backend."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc
(:require
@ -16,10 +16,9 @@
[app.msgbus :as-alias mbus]
[app.rpc.retry :as retry]
[app.rpc.rlimit :as rlimit]
[app.rpc.semaphore :as rsem]
[app.util.async :as async]
[app.rpc.semaphore :as-alias rsem]
[app.util.services :as sv]
[app.worker :as wrk]
[app.util.time :as ts]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
@ -107,38 +106,25 @@
"Wrap service method with metrics measurement."
[{:keys [metrics ::metrics-id]} f mdata]
(let [labels (into-array String [(::sv/name mdata)])]
(fn [cfg params]
(let [start (System/nanoTime)]
(let [tp (ts/tpoint)]
(p/finally
(f cfg params)
(fn [_ _]
(mtx/run! metrics
{:id metrics-id
:val (/ (- (System/nanoTime) start) 1000000)
:labels labels})))))))
:id metrics-id
:val (inst-ms (tp))
:labels labels)))))))
(defn- wrap-dispatch
"Wraps service method into async flow, with the ability to dispatching
it to a preconfigured executor service."
[{:keys [executors] :as cfg} f mdata]
(let [dname (::async/dispatch mdata :default)]
(if (= :none dname)
(with-meta
(fn [cfg params]
(p/do (f cfg params)))
mdata)
(let [executor (get executors dname)]
(when-not executor
(ex/raise :type :internal
:code :executor-not-configured
:hint (format "executor %s not configured" dname)))
(with-meta
(fn [cfg params]
(-> (px/submit! executor #(f cfg params))
(p/bind p/wrap)))
mdata)))))
[{:keys [executor] :as cfg} f mdata]
(with-meta
(fn [cfg params]
(-> (px/submit! executor #(f cfg params))
(p/bind p/wrap)))
mdata))
(defn- wrap-audit
[{:keys [audit] :as cfg} f mdata]
@ -171,12 +157,11 @@
[cfg f mdata]
(let [f (as-> f $
(wrap-dispatch cfg $ mdata)
(wrap-metrics cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(rsem/wrap cfg $ mdata)
(rlimit/wrap cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(wrap-audit cfg $ mdata)
(wrap-metrics cfg $ mdata)
)
(wrap-audit cfg $ mdata))
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
@ -245,8 +230,6 @@
(into {}))))
(s/def ::audit (s/nilable fn?))
(s/def ::executors (s/map-of keyword? ::wrk/executor))
(s/def ::executors map?)
(s/def ::http-client fn?)
(s/def ::ldap (s/nilable map?))
(s/def ::msgbus ::mbus/msgbus)
@ -260,10 +243,10 @@
::session
::sprops
::audit
::executors
::public-uri
::msgbus
::http-client
::rsem/semaphores
::rlimit/rlimit
::mtx/metrics
::db/pool

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.auth
(:require
@ -136,7 +136,7 @@
(sv/defmethod ::login-with-password
"Performs authentication using penpot password."
{:auth false
::rsem/permits (cf/get :rpc-semaphore-permits-password)
::rsem/queue :auth
::doc/added "1.15"}
[cfg params]
(login-with-password cfg params))
@ -177,7 +177,7 @@
(sv/defmethod ::recover-profile
{:auth false
::rsem/permits (cf/get :rpc-semaphore-permits-password)
::rsem/queue :auth
::doc/added "1.15"}
[cfg params]
(recover-profile cfg params))
@ -297,23 +297,52 @@
(assoc :default-team-id (:id team))
(assoc :default-project-id (:default-project-id team)))))
(defn send-email-verification!
[conn sprops profile]
(let [vtoken (tokens/generate sprops
{:iss :verify-email
:exp (dt/in-future "72h")
:profile-id (:id profile)
:email (:email profile)})
;; NOTE: this token is mainly used for possible complains
;; identification on the sns webhook
ptoken (tokens/generate sprops
{:iss :profile-identity
:profile-id (:id profile)
:exp (dt/in-future {:days 30})})]
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})))
(defn register-profile
[{:keys [conn sprops session] :as cfg} {:keys [token] :as params}]
(let [claims (tokens/verify sprops {:token token :iss :prepared-register})
params (merge params claims)]
(check-profile-existence! conn params)
(let [is-active (or (:is-active params)
(not (contains? cf/flags :email-verification))
;; DEPRECATED: v1.15
(contains? cf/flags :insecure-register))
profile (->> (assoc params :is-active is-active)
(create-profile conn)
(create-profile-relations conn)
(profile/decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens/verify sprops {:token token :iss :team-invitation}))]
(cond
;; If invitation token comes in params, this is because the user comes from team-invitation process;
;; in this case, regenerate token and send back to the user a new invitation token (and mark current
;; session as logged). This happens only if the invitation email matches with the register email.
;; If invitation token comes in params, this is because the
;; user comes from team-invitation process; in this case,
;; regenerate token and send back to the user a new invitation
;; token (and mark current session as logged). This happens
;; only if the invitation email matches with the register
;; email.
(and (some? invitation) (= (:email profile) (:member-email invitation)))
(let [claims (assoc invitation :member-id (:id profile))
token (tokens/generate sprops claims)
@ -342,23 +371,8 @@
;; In all other cases, send a verification email.
:else
(let [vtoken (tokens/generate sprops
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})
ptoken (tokens/generate sprops
{:iss :profile-identity
:profile-id (:id profile)
:exp (dt/in-future {:days 30})})]
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (:public-uri cfg)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(do
(send-email-verification! conn sprops profile)
(with-meta profile
{::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
@ -368,7 +382,7 @@
(sv/defmethod ::register-profile
{:auth false
::rsem/permits (cf/get :rpc-semaphore-permits-password)
::rsem/queue :auth
::doc/added "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.binfile
(:refer-clojure :exclude [assert])

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.comments
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.demo
"A demo specific mutations."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.files
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.ldap
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.commands.management
"A collection of RPC methods for manage the files, projects and team organization."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.doc
"API autogenerated documentation."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.helpers
"General purpose RPC helpers."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.comments
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.files
(:require
@ -315,7 +315,7 @@
(contains? o :changes-with-metadata)))))
(sv/defmethod ::update-file
{::rsem/permits (cf/get :rpc-semaphore-permits-file-update)}
{::rsem/queue :update-file}
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(db/xact-lock! conn id)

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.fonts
(:require
@ -10,7 +10,6 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.rpc.doc :as-alias doc]
@ -20,8 +19,7 @@
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
(declare create-font-variant)
@ -42,24 +40,21 @@
::font-id ::font-family ::font-weight ::font-style]))
(sv/defmethod ::create-font-variant
{::rsem/permits (cf/get :rpc-semaphore-permits-font)}
[{:keys [pool] :as cfg} {:keys [team-id profile-id] :as params}]
(let [cfg (update cfg :storage media/configure-assets-storage)]
(teams/check-edition-permissions! pool profile-id team-id)
(create-font-variant cfg params)))
(defn create-font-variant
[{:keys [storage pool executors] :as cfg} {:keys [data] :as params}]
[{:keys [storage pool executor semaphores] :as cfg} {:keys [data] :as params}]
(letfn [(generate-fonts [data]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-font semaphores)
(media/run {:cmd :generate-fonts :input data})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data. Even though it uses the hight
;; performance BLAKE2b algorithm, we prefer to schedule it
;; to be executed on the blocking executor.
;; the provided data.
(calculate-hash [data]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-font semaphores)
(sto/calculate-hash data)))
(validate-data [data]
@ -110,8 +105,8 @@
(-> (generate-fonts data)
(p/then validate-data)
(p/then persist-fonts (:default executors))
(p/then insert-into-db (:default executors)))))
(p/then persist-fonts executor)
(p/then insert-into-db executor))))
;; --- UPDATE FONT FAMILY

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.management
"Move & Duplicate RPC methods for files and projects."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.media
(:require
@ -23,8 +23,7 @@
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
(def default-max-file-size (* 1024 1024 10)) ; 10 MiB
@ -53,7 +52,6 @@
:opt-un [::id]))
(sv/defmethod ::upload-file-media-object
{::rsem/permits (cf/get :rpc-semaphore-permits-image)}
[{:keys [pool] :as cfg} {:keys [profile-id file-id content] :as params}]
(let [file (select-file pool file-id)
cfg (update cfg :storage media/configure-assets-storage)]
@ -106,26 +104,25 @@
;; inverse, soft referential integrity).
(defn create-file-media-object
[{:keys [storage pool executors] :as cfg} {:keys [id file-id is-local name content] :as params}]
[{:keys [storage pool semaphores] :as cfg}
{:keys [id file-id is-local name content] :as params}]
(letfn [;; Function responsible to retrieve the file information, as
;; it is synchronous operation it should be wrapped into
;; with-dispatch macro.
(get-info [content]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(media/run {:cmd :info :input content})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data. Even though it uses the hight
;; performance BLAKE2b algorithm, we prefer to schedule it
;; to be executed on the blocking executor.
;; the provided data.
(calculate-hash [data]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(sto/calculate-hash data)))
;; Function responsible of generating thumnail. As it is synchronous
;; opetation, it should be wrapped into with-dispatch macro
(generate-thumbnail [info]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(media/run (assoc thumbnail-options
:cmd :generic-thumbnail
:input info))))
@ -157,15 +154,14 @@
:bucket "file-media-object"})))
(insert-into-database [info image thumb]
(px/with-dispatch (:default executors)
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width info)
(:height info)
(:mtype info)])))]
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width info)
(:height info)
(:mtype info)]))]
(p/let [info (get-info content)
thumb (create-thumbnail info)
@ -181,7 +177,6 @@
:opt-un [::id ::name]))
(sv/defmethod ::create-file-media-object-from-url
{::rsem/permits (cf/get :rpc-semaphore-permits-image)}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(let [file (select-file pool file-id)
cfg (update cfg :storage media/configure-assets-storage)]

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.profile
(:require
@ -15,6 +15,7 @@
[app.loggers.audit :as audit]
[app.media :as media]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.doc :as-alias doc]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.semaphore :as rsem]
@ -87,7 +88,7 @@
(s/keys :req-un [::profile-id ::password ::old-password]))
(sv/defmethod ::update-profile-password
{::rsem/permits (cf/get :rpc-semaphore-permits-password)}
{::rsem/queue :auth}
[{:keys [pool] :as cfg} {:keys [password] :as params}]
(db/with-atomic [conn pool]
(let [profile (validate-password! conn params)
@ -130,7 +131,6 @@
(s/keys :req-un [::profile-id ::file]))
(sv/defmethod ::update-profile-photo
{::rsem/permits (cf/get :rpc-semaphore-permits-image)}
[cfg {:keys [file] :as params}]
;; Validate incoming mime type
(media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
@ -138,8 +138,8 @@
(update-profile-photo cfg params)))
(defn update-profile-photo
[{:keys [pool storage executors] :as cfg} {:keys [profile-id] :as params}]
(p/let [profile (px/with-dispatch (:default executors)
[{:keys [pool storage executor] :as cfg} {:keys [profile-id] :as params}]
(p/let [profile (px/with-dispatch executor
(db/get-by-id pool :profile profile-id))
photo (teams/upload-photo cfg params)]
@ -169,8 +169,7 @@
params (assoc params
:profile profile
:email (str/lower email))]
(if (or (cf/get :smtp-enabled)
(contains? cf/flags :smtp))
(if (contains? cf/flags :smtp)
(request-email-change cfg params)
(change-email-immediately cfg params)))))
@ -305,7 +304,10 @@
(s/def ::login ::cmd.auth/login-with-password)
(sv/defmethod ::login
{:auth false ::rsem/permits (cf/get :rpc-semaphore-permits-password)}
{:auth false
::rsem/queue :auth
::doc/added "1.0"
::doc/deprecated "1.15"}
[cfg params]
(cmd.auth/login-with-password cfg params))
@ -313,7 +315,10 @@
(s/def ::logout ::cmd.auth/logout)
(sv/defmethod ::logout {:auth false}
(sv/defmethod ::logout
{:auth false
::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [session] :as cfg} _]
(with-meta {}
{:transform-response (:delete session)}))
@ -323,7 +328,8 @@
(s/def ::recover-profile ::cmd.auth/recover-profile)
(sv/defmethod ::recover-profile
{:auth false ::rsem/permits (cf/get :rpc-semaphore-permits-password)}
{::doc/added "1.0"
::doc/deprecated "1.15"}
[cfg params]
(cmd.auth/recover-profile cfg params))
@ -331,7 +337,10 @@
(s/def ::prepare-register-profile ::cmd.auth/prepare-register-profile)
(sv/defmethod ::prepare-register-profile {:auth false}
(sv/defmethod ::prepare-register-profile
{:auth false
::doc/added "1.0"
::doc/deprecated "1.15"}
[cfg params]
(cmd.auth/prepare-register cfg params))
@ -340,7 +349,10 @@
(s/def ::register-profile ::cmd.auth/register-profile)
(sv/defmethod ::register-profile
{:auth false ::rsem/permits (cf/get :rpc-semaphore-permits-password)}
{:auth false
::rsem/queue :auth
::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(-> (assoc cfg :conn conn)
@ -350,6 +362,9 @@
(s/def ::request-profile-recovery ::cmd.auth/request-profile-recovery)
(sv/defmethod ::request-profile-recovery {:auth false}
(sv/defmethod ::request-profile-recovery
{:auth false
::doc/added "1.0"
::doc/deprecated "1.15"}
[cfg params]
(cmd.auth/request-profile-recovery cfg params))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.projects
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.share-link
"Share link related rpc mutation methods."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.teams
(:require
@ -290,7 +290,6 @@
(s/keys :req-un [::profile-id ::team-id ::file]))
(sv/defmethod ::update-team-photo
{::rsem/permits (cf/get :rpc-semaphore-permits-image)}
[cfg {:keys [file] :as params}]
;; Validate incoming mime type
(media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
@ -298,8 +297,8 @@
(update-team-photo cfg params)))
(defn update-team-photo
[{:keys [pool storage executors] :as cfg} {:keys [profile-id team-id] :as params}]
(p/let [team (px/with-dispatch (:default executors)
[{:keys [pool storage executor] :as cfg} {:keys [profile-id team-id] :as params}]
(p/let [team (px/with-dispatch executor
(teams/retrieve-team pool profile-id team-id))
photo (upload-photo cfg params)]
@ -316,13 +315,13 @@
(assoc team :photo-id (:id photo))))
(defn upload-photo
[{:keys [storage executors] :as cfg} {:keys [file]}]
[{:keys [storage semaphores] :as cfg} {:keys [file]}]
(letfn [(get-info [content]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(media/run {:cmd :info :input content})))
(generate-thumbnail [info]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(media/run {:cmd :profile-thumbnail
:format :jpeg
:quality 85
@ -331,11 +330,9 @@
:input info})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data. Even though it uses the hight
;; performance BLAKE2b algorithm, we prefer to schedule it
;; to be executed on the blocking executor.
;; the provided data.
(calculate-hash [data]
(px/with-dispatch (:blocking executors)
(rsem/with-dispatch (:process-image semaphores)
(sto/calculate-hash data)))]
(p/let [info (get-info file)
@ -343,11 +340,11 @@
hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
(sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)}))))
(rsem/with-dispatch (:process-image semaphores)
(sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)})))))
;; --- Mutation: Invite Member
@ -422,26 +419,51 @@
(ex/raise :type :validation
:code :member-is-muted
:email email
:hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
:hint "the profile has reported repeatedly as spam or has bounces"))
;; Secondly check if the invited member email is part of the global spam/bounce report.
(when (eml/has-bounce-reports? conn email)
(ex/raise :type :validation
:code :email-has-permanent-bounces
:email email
:hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
:hint "the email you invite has been repeatedly reported as spam or bounce"))
(db/exec-one! conn [sql:upsert-team-invitation
(:id team) (str/lower email) (name role) token-exp (name role) token-exp])
;; When we have email verification disabled and invitation user is
;; already present in the database, we proceed to add it to the
;; team as-is, without email roundtrip.
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
:public-uri (:public-uri cfg)
:to email
:invited-by (:fullname profile)
:team (:name team)
:token itoken
:extra-data ptoken})))
;; TODO: if member does not exists and email verification is
;; disabled, we should proceed to create the profile (?)
(if (and (not (contains? cf/flags :email-verification))
(some? member))
(let [params (merge {:team-id (:id team)
:profile-id (:id member)}
(role->params role))]
;; Insert the invited member to the team
(db/insert! conn :team-profile-rel params {:on-conflict-do-nothing true})
;; If profile is not yet verified, mark it as verified because
;; accepting an invitation link serves as verification.
(when-not (:is-active member)
(db/update! conn :profile
{:is-active true}
{:id (:id member)}))
(assoc member :is-active true))
(do
(db/exec-one! conn [sql:upsert-team-invitation
(:id team) (str/lower email) (name role)
token-exp (name role) token-exp])
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
:public-uri (:public-uri cfg)
:to email
:invited-by (:fullname profile)
:team (:name team)
:token itoken
:extra-data ptoken})))))
;; --- Mutation: Create Team & Invite Members

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.mutations.verify-token
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.permissions
"A permission checking helper factories."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.comments
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.files
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.fonts
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.profile
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.projects
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.share-link
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.teams
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.queries.viewer
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.retry
"A fault tolerance helpers. Allow retry some operations that we know

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.rlimit
"Rate limit strategies implementation for RPC services.

View file

@ -2,30 +2,45 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.rpc.semaphore
"Resource usage limits (in other words: semaphores)."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.util.locks :as locks]
[app.util.services :as-alias sv]
[app.util.time :as ts]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ASYNC SEMAPHORE IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol IAsyncSemaphore
(acquire! [_])
(release! [_]))
(release! [_ tp]))
(defn create
[& {:keys [permits metrics name]}]
(let [name (d/name name)
used (volatile! 0)
queue (volatile! (d/queue))
labels (into-array String [name])
lock (locks/create)]
[& {:keys [permits metrics name executor]}]
(let [used (volatile! 0)
queue (volatile! (d/queue))
labels (into-array String [(d/name name)])
lock (locks/create)
permits (or permits Long/MAX_VALUE)]
(when (>= permits Long/MAX_VALUE)
(l/warn :hint "permits value too hight" :permits permits :semaphore name))
^{::wrk/executor executor
::name name}
(reify IAsyncSemaphore
(acquire! [_]
(let [d (p/deferred)]
@ -36,12 +51,17 @@
(p/resolve! d))
(vswap! queue conj d)))
(mtx/run! metrics {:id :rpc-semaphore-used-permits :val @used :labels labels })
(mtx/run! metrics {:id :rpc-semaphore-queued-submissions :val (count @queue) :labels labels})
(mtx/run! metrics {:id :rpc-semaphore-acquires-total :inc 1 :labels labels})
(mtx/run! metrics
:id :semaphore-used-permits
:val @used
:labels labels)
(mtx/run! metrics
:id :semaphore-queued-submissions
:val (count @queue)
:labels labels)
d))
(release! [_]
(release! [_ tp]
(locks/locking lock
(if-let [item (peek @queue)]
(do
@ -50,19 +70,80 @@
(when (pos? @used)
(vswap! used dec))))
(mtx/run! metrics {:id :rpc-semaphore-used-permits :val @used :labels labels})
(mtx/run! metrics {:id :rpc-semaphore-queued-submissions :val (count @queue) :labels labels})))))
(mtx/run! metrics
:id :semaphore-timing
:val (inst-ms (tp))
:labels labels)
(mtx/run! metrics
:id :semaphore-used-permits
:val @used
:labels labels)
(mtx/run! metrics
:id :semaphore-queued-submissions
:val (count @queue)
:labels labels)))))
(defn semaphore?
[v]
(satisfies? IAsyncSemaphore v))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PREDEFINED SEMAPHORES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::semaphore semaphore?)
(s/def ::semaphores
(s/map-of ::us/keyword ::semaphore))
(defmethod ig/pre-init-spec ::rpc/semaphores [_]
(s/keys :req-un [::mtx/metrics]))
(defn- create-default-semaphores
[metrics executor]
[(create :permits (cf/get :semaphore-process-font)
:metrics metrics
:name :process-font
:executor executor)
(create :permits (cf/get :semaphore-update-file)
:metrics metrics
:name :update-file
:executor executor)
(create :permits (cf/get :semaphore-process-image)
:metrics metrics
:name :process-image
:executor executor)
(create :permits (cf/get :semaphore-auth)
:metrics metrics
:name :auth
:executor executor)])
(defmethod ig/init-key ::rpc/semaphores
[_ {:keys [metrics executor]}]
(->> (create-default-semaphores metrics executor)
(d/index-by (comp ::name meta))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro with-dispatch
[queue & body]
`(let [tpoint# (ts/tpoint)
queue# ~queue
executor# (-> queue# meta ::wrk/executor)]
(-> (acquire! queue#)
(p/then (fn [_#] ~@body) executor#)
(p/finally (fn [_# _#]
(release! queue# tpoint#))))))
(defn wrap
[{:keys [metrics executors] :as cfg} f mdata]
(if-let [permits (::permits mdata)]
(let [sem (create {:permits permits
:metrics metrics
:name (::sv/name mdata)})]
(l/debug :hint "wrapping semaphore" :handler (::sv/name mdata) :permits permits)
[{:keys [semaphores]} f {:keys [::queue]}]
(let [queue' (get semaphores queue)]
(if (semaphore? queue')
(fn [cfg params]
(-> (acquire! sem)
(p/then (fn [_] (f cfg params)) (:default executors))
(p/finally (fn [_ _] (release! sem))))))
f))
(with-dispatch queue'
(f cfg params)))
(do
(when (some? queue)
(l/warn :hint "undefined semaphore" :name queue))
f))))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.setup
"Initial data setup of instance."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.setup.builtin-templates
"A service/module that is reponsible for download, load & internally

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.setup.keys
"Keys derivation service."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.srepl
"Server Repl."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.srepl.fixes
"A collection of adhoc fixes scripts."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.srepl.helpers
"A main namespace for server repl."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.srepl.main
"A collection of adhoc fixes scripts."
@ -10,18 +10,21 @@
(:require
[app.common.logging :as l]
[app.common.pprint :as p]
[app.common.spec :as us]
[app.db :as db]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.queries.profile :as profile]
[app.srepl.fixes :as f]
[app.srepl.helpers :as h]
[clojure.pprint :refer [pprint]]))
;; Empty namespace as main entry point for Server REPL
[app.util.time :as dt]
[clojure.pprint :refer [pprint]]
[cuerdas.core :as str]))
(defn print-available-tasks
[system]
(let [tasks (:app.worker/registry system)]
(p/pprint (keys tasks) :level 200)))
(defn run-task!
([system name]
(run-task! system name {}))
@ -29,4 +32,57 @@
(let [tasks (:app.worker/registry system)]
(if-let [task-fn (get tasks name)]
(task-fn params)
(l/warn :hint "no task found" :name name)))))
(println (format "no task '%s' found" name))))))
(defn send-test-email!
[system destination]
(us/verify!
:expr (some? system)
:hint "system should be provided")
(us/verify!
:expr (string? destination)
:hint "destination should be provided")
(let [handler (:app.emails/sendmail system)]
(handler {:body "test email"
:subject "test email"
:to [destination]})))
(defn resend-email-verification-email!
[system email]
(us/verify!
:expr (some? system)
:hint "system should be provided")
(let [sprops (:app.setup/props system)
pool (:app.db/pool system)
profile (profile/retrieve-profile-data-by-email pool email)]
(cmd.auth/send-email-verification! pool sprops profile)
:email-sent))
(defn update-profile
"Update a limited set of profile attrs."
[system & {:keys [email id active? deleted?]}]
(us/verify!
:expr (some? system)
:hint "system should be provided")
(us/verify!
:expr (or (string? email) (uuid? id))
:hint "email or id should be provided")
(let [pool (:app.db/pool system)
params (cond-> {}
(true? active?) (assoc :is-active true)
(false? active?) (assoc :is-active false)
(true? deleted?) (assoc :deleted-at (dt/now)))
opts (cond-> {}
(some? email) (assoc :email (str/lower email))
(some? id) (assoc :id id))]
(some-> (db/update! pool :profile params opts)
(profile/decode-profile-row))))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.storage
"Objects storage abstraction layer."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.storage.fs
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.storage.impl
"Storage backends abstraction layer."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.storage.s3
"S3 Storage backend implementation."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.storage.tmp
"Temporal files service all created files will be tried to clean after

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tasks.file-gc
"A maintenance task that is responsible of: purge unused file media,

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tasks.file-xlog-gc
"A maintenance task that performs a garbage collection of the file

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tasks.objects-gc
"A maintenance task that performs a general purpose garbage collection

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tasks.tasks-gc
"A maintenance task that performs a cleanup of already executed tasks

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tasks.telemetry
"A task that is responsible to collect anonymous statistical

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.tokens
"Tokens generation API."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.async
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.blob
"A generic blob storage encoding. Mainly used for page data, page

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.closeable
"A closeable abstraction. A drop in replacement for

View file

@ -1,252 +0,0 @@
;; 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) UXBOX Labs SL
(ns app.util.emails
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.util.template :as tmpl]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str])
(:import
java.util.Properties
jakarta.mail.Message$RecipientType
jakarta.mail.Session
jakarta.mail.Transport
jakarta.mail.internet.InternetAddress
jakarta.mail.internet.MimeBodyPart
jakarta.mail.internet.MimeMessage
jakarta.mail.internet.MimeMultipart))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Email Building
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- parse-address
[v]
(InternetAddress/parse ^String v))
(defn- resolve-recipient-type
^Message$RecipientType
[type]
(case type
:to Message$RecipientType/TO
:cc Message$RecipientType/CC
:bcc Message$RecipientType/BCC))
(defn- assign-recipient
[^MimeMessage mmsg type address]
(if (sequential? address)
(reduce #(assign-recipient %1 type %2) mmsg address)
(let [address (parse-address address)
type (resolve-recipient-type type)]
(.addRecipients mmsg type address)
mmsg)))
(defn- assign-recipients
[mmsg {:keys [to cc bcc] :as params}]
(cond-> mmsg
(some? to) (assign-recipient :to to)
(some? cc) (assign-recipient :cc cc)
(some? bcc) (assign-recipient :bcc bcc)))
(defn- assign-from
[mmsg {:keys [default-from]} {:keys [from] :as props}]
(let [from (or from default-from)]
(when from
(let [from (parse-address from)]
(.addFrom ^MimeMessage mmsg from)))))
(defn- assign-reply-to
[mmsg {:keys [default-reply-to] :as cfg} {:keys [reply-to] :as params}]
(let [reply-to (or reply-to default-reply-to)]
(when reply-to
(let [reply-to (parse-address reply-to)]
(.setReplyTo ^MimeMessage mmsg reply-to)))))
(defn- assign-subject
[mmsg {:keys [subject charset] :or {charset "utf-8"}}]
(assert (string? subject) "subject is mandatory")
(.setSubject ^MimeMessage mmsg
^String subject
^String charset))
(defn- assign-extra-headers
[^MimeMessage mmsg {:keys [headers extra-data] :as params}]
(let [headers (assoc headers "X-Penpot-Data" extra-data)]
(reduce-kv (fn [^MimeMessage mmsg k v]
(doto mmsg
(.addHeader (name k) (str v))))
mmsg
headers)))
(defn- assign-body
[^MimeMessage mmsg {:keys [body charset] :or {charset "utf-8"}}]
(let [mpart (MimeMultipart. "mixed")]
(cond
(string? body)
(let [bpart (MimeBodyPart.)]
(.setContent bpart ^String body (str "text/plain; charset=" charset))
(.addBodyPart mpart bpart))
(vector? body)
(let [mmp (MimeMultipart. "alternative")
mbp (MimeBodyPart.)]
(.addBodyPart mpart mbp)
(.setContent mbp mmp)
(doseq [item body]
(let [mbp (MimeBodyPart.)]
(.setContent mbp
^String (:content item)
^String (str (:type item "text/plain") "; charset=" charset))
(.addBodyPart mmp mbp))))
(map? body)
(let [bpart (MimeBodyPart.)]
(.setContent bpart
^String (:content body)
^String (str (:type body "text/plain") "; charset=" charset))
(.addBodyPart mpart bpart))
:else
(throw (ex-info "Unsupported type" {:body body})))
(.setContent mmsg mpart)
mmsg))
(defn- build-message
[cfg session params]
(let [mmsg (MimeMessage. ^Session session)]
(assign-recipients mmsg params)
(assign-from mmsg cfg params)
(assign-reply-to mmsg cfg params)
(assign-subject mmsg params)
(assign-extra-headers mmsg params)
(assign-body mmsg params)
(.saveChanges mmsg)
mmsg))
(defn- opts->props
[{:keys [username tls host port timeout default-from]
:or {timeout 30000}
:as opts}]
(reduce-kv
(fn [^Properties props k v]
(if (nil? v)
props
(doto props (.put ^String k ^String (str v)))))
(Properties.)
{"mail.user" username
"mail.host" host
"mail.from" default-from
"mail.smtp.auth" (boolean username)
"mail.smtp.starttls.enable" tls
"mail.smtp.starttls.required" tls
"mail.smtp.host" host
"mail.smtp.port" port
"mail.smtp.user" username
"mail.smtp.timeout" timeout
"mail.smtp.connectiontimeout" timeout}))
(defn smtp-session
[{:keys [debug] :or {debug false} :as opts}]
(let [props (opts->props opts)
session (Session/getInstance props)]
(.setDebug session debug)
session))
(defn smtp-message
^MimeMessage
[cfg message]
(let [^Session session (smtp-session cfg)]
(build-message cfg session message)))
;; TODO: specs for smtp config
(defn send!
[cfg message]
(let [^MimeMessage message (smtp-message cfg message)]
(Transport/send message
(:username cfg)
(:password cfg))
nil))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Template Email Building
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private email-path "app/emails/%(id)s/%(lang)s.%(type)s")
(defn- render-email-template-part
[type id context]
(let [lang (:lang context :en)
path (str/format email-path {:id (name id)
:lang (name lang)
:type (name type)})]
(some-> (io/resource path)
(tmpl/render context))))
(defn- build-email-template
[id context]
(let [subj (render-email-template-part :subj id context)
text (render-email-template-part :txt id context)
html (render-email-template-part :html id context)]
(when (or (not subj)
(and (not text)
(not html)))
(ex/raise :type :internal
:code :missing-email-templates))
{:subject subj
:body (into
[{:type "text/plain"
:content text}]
(when html
[{:type "text/html"
:content html}]))}))
(s/def ::priority #{:high :low})
(s/def ::to (s/or :single ::us/email
:multi (s/coll-of ::us/email)))
(s/def ::from ::us/email)
(s/def ::reply-to ::us/email)
(s/def ::lang string?)
(s/def ::extra-data ::us/string)
(s/def ::context
(s/keys :req-un [::to]
:opt-un [::reply-to ::from ::lang ::priority ::extra-data]))
(defn template-factory
([id] (template-factory id {}))
([id extra-context]
(s/assert keyword? id)
(fn [context]
(us/verify ::context context)
(when-let [spec (s/get-spec id)]
(s/assert spec context))
(let [context (merge (if (fn? extra-context)
(extra-context)
extra-context)
context)
email (build-email-template id context)]
(when-not email
(ex/raise :type :internal
:code :email-template-does-not-exists
:hint "seems like the template is wrong or does not exists."
:context {:id id}))
(cond-> (assoc email :id (name id))
(:extra-data context)
(assoc :extra-data (:extra-data context))
(:from context)
(assoc :from (:from context))
(:reply-to context)
(assoc :reply-to (:reply-to context))
(:to context)
(assoc :to (:to context)))))))

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.fressian
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.json
(:refer-clojure :exclude [read])

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.locks
"A syntactic helpers for using locks."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.migrations
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.services
"A helpers and macros for define rpc like registry based services."

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.svg
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.template
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.time
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.transit
(:require

View file

@ -2,7 +2,7 @@
;; 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) UXBOX Labs SL
;; Copyright (c) KALEIDOS INC
(ns app.util.websocket
"A general protocol implementation on top of websockets."

Some files were not shown because too many files have changed in this diff Show more