1 files changed, 366 insertions, 0 deletions
diff --git a/users/aspen/bbbg/src/bbbg/db.clj b/users/aspen/bbbg/src/bbbg/db.clj
new file mode 100644
index 0000000000..5bbf88925a
--- /dev/null
+++ b/users/aspen/bbbg/src/bbbg/db.clj
@@ -0,0 +1,366 @@
+(ns bbbg.db
+  (:gen-class)
+  (:refer-clojure :exclude [get list count])
+  (:require [camel-snake-kebab.core :as csk :refer [->kebab-case ->snake_case]]
+            [bbbg.util.core :as u]
+            [clojure.set :as set]
+            [clojure.spec.alpha :as s]
+            [clojure.string :as str]
+            [com.stuartsierra.component :as component]
+            [config.core :refer [env]]
+            [honeysql.format :as hformat]
+            [migratus.core :as migratus]
+            [next.jdbc :as jdbc]
+            [next.jdbc.connection :as jdbc.conn]
+            next.jdbc.date-time
+            [next.jdbc.optional :as jdbc.opt]
+            [next.jdbc.result-set :as rs]
+            [next.jdbc.sql :as sql])
+  (:import [com.impossibl.postgres.jdbc PGSQLSimpleException]
+           com.zaxxer.hikari.HikariDataSource
+           [java.sql Connection ResultSet Types]
+           javax.sql.DataSource))
+
+(s/def ::host string?)
+(s/def ::database string?)
+(s/def ::user string?)
+(s/def ::password string?)
+
+(s/def ::config
+  (s/keys :opt [::host
+                ::database
+                ::user
+                ::password]))
+
+(s/fdef make-database
+  :args
+  (s/cat :config (s/keys :opt [::config])))
+
+(s/fdef env->config :ret ::config)
+
+(s/def ::db any?)
+
+;;;
+
+(def default-config
+  (s/assert
+   ::config
+   {::host "localhost"
+    ::database "bbbg"
+    ::user "bbbg"
+    ::password "password"}))
+
+(defn dev-config [] default-config)
+
+(defn env->config []
+  (->>
+   {::host (:pghost env)
+    ::database (:pgdatabase env)
+    ::user (:pguser env)
+    ::password (:pgpassword env)}
+   u/remove-nils
+   (s/assert ::config)))
+
+(defn ->db-spec [config]
+  (-> default-config
+      (merge config)
+      (set/rename-keys
+       {::host :host
+        ::database :dbname
+        ::user :username
+        ::password :password})
+      (assoc :dbtype "pgsql")))
+
+(defn connection
+  "Make a one-off connection from the given `::config` map, or the environment
+  if not provided"
+  ([] (connection (env->config)))
+  ([config]
+   (-> config
+       ->db-spec
+       (set/rename-keys {:username :user})
+       jdbc/get-datasource
+       jdbc/get-connection)))
+
+(defrecord Database [config]
+  component/Lifecycle
+  (start [this]
+    (assoc this :pool (jdbc.conn/->pool HikariDataSource (->db-spec config))))
+  (stop [this]
+    (some-> this :pool .close)
+    (dissoc this :pool))
+
+  clojure.lang.IFn
+  (invoke [this] (:pool this)))
+
+(defn make-database [config]
+  (map->Database {:config config}))
+
+(defn database? [x]
+  (or
+   (instance? Database x)
+   (and (map? x) (contains? x :pool))))
+
+;;;
+;;; Migrations
+;;;
+
+(defn migratus-config
+  [db]
+  {:store :database
+   :migration-dir "migrations/"
+   :migration-table-name "__migrations__"
+   :db
+   (let [db (if (ifn? db) (db) db)]
+     (cond
+       (.isInstance Connection db)
+       {:connection db}
+       (.isInstance DataSource db)
+       {:datasource db}
+       :else (throw
+              (ex-info "migratus-config called with value of unrecognized type"
+                       {:value db}))))})
+
+(defn generate-migration
+  ([db name] (generate-migration db name :sql))
+  ([db name type] (migratus/create (migratus-config db) name type)))
+
+(defn migrate!
+  [db] (migratus/migrate (migratus-config db)))
+
+(defn rollback!
+  [db] (migratus/rollback (migratus-config db)))
+
+;;;
+;;; Database interaction
+;;;
+
+(defn ->key-ns [tn]
+  (let [tn (name tn)
+        tn (if (str/starts-with? tn "public.")
+             (second (str/split tn #"\." 2))
+             tn)]
+    (str "bbbg." (->kebab-case tn))))
+
+(defn ->table-name [kns]
+  (let [kns (name kns)]
+    (->snake_case
+     (if (str/starts-with? kns "public.")
+       kns
+       (str "public." (last (str/split kns #"\.")))))))
+
+(defn ->column
+  ([col] (->column nil col))
+  ([table col]
+   (let [col-table (some-> col namespace ->table-name)
+         snake-col (-> col name ->snake_case (str/replace #"\?$" ""))]
+     (if (or (not (namespace col))
+             (not table)
+             (= (->table-name table) col-table))
+       snake-col
+       ;; different table, assume fk
+       (str
+        (str/replace-first col-table "public." "")
+        "_"
+        snake-col)))))
+
+(defn ->value [v]
+  (if (keyword? v)
+    (-> v name csk/->snake_case_string)
+    v))
+
+(defn process-key-map [table key-map]
+  (into {}
+        (map (fn [[k v]] [(->column table k)
+                          (->value v)]))
+        key-map))
+
+(defn fkize [col]
+  (if (str/ends-with? col "-id")
+    (let [table (str/join "-" (butlast (str/split (name col) #"-")))]
+      (keyword (->key-ns table) "id"))
+    col))
+
+(def ^:private enum-members-cache (atom {}))
+(defn- enum-members
+  "Returns a set of enum members as strings for the enum with the given name"
+  [db name]
+  (if-let [e (find @enum-members-cache name)]
+    (val e)
+    (let [r (try
+              (-> (jdbc/execute-one!
+                   (db)
+                   [(format "select enum_range(null::%s) as members" name)])
+                  :members
+                  .getArray
+                  set)
+              (catch PGSQLSimpleException _
+                nil))]
+      (swap! enum-members-cache assoc name r)
+      r)))
+
+(def ^{:private true
+       :dynamic true}
+  *meta-db*
+  "Database connection to use to query metadata"
+  nil)
+
+(extend-protocol rs/ReadableColumn
+  String
+  (read-column-by-label [x _] x)
+  (read-column-by-index [x rsmeta idx]
+    (if-not *meta-db*
+      x
+      (let [typ (.getColumnTypeName rsmeta idx)]
+        ;; TODO: Is there a better way to figure out if a type is an enum?
+        (if (enum-members *meta-db* typ)
+          (keyword (csk/->kebab-case-string typ)
+                   (csk/->kebab-case-string x))
+          x)))))
+
+(comment
+  (->key-ns :public.user)
+  (->key-ns :public.api-token)
+  (->key-ns :api-token)
+  (->table-name :api-token)
+  (->table-name :public.user)
+  (->table-name :bbbg.user)
+  )
+
+(defn as-fq-maps [^ResultSet rs _opts]
+  (let [qualify #(when (seq %) (str "bbbg." (->kebab-case %)))
+        rsmeta (.getMetaData rs)
+        cols (mapv
+              (fn [^Integer i]
+                (let [ty (.getColumnType rsmeta i)
+                      lab (.getColumnLabel rsmeta i)
+                      n (str (->kebab-case lab)
+                             (when (= ty Types/BOOLEAN) "?"))]
+                  (fkize
+                   (if-let [q (some-> rsmeta (.getTableName i) qualify not-empty)]
+                     (keyword q n)
+                     (keyword n)))))
+              (range 1 (inc (.getColumnCount rsmeta))))]
+    (jdbc.opt/->MapResultSetOptionalBuilder rs rsmeta cols)))
+
+(def jdbc-opts
+  {:builder-fn as-fq-maps
+   :column-fn ->snake_case
+   :table-fn ->snake_case})
+
+(defmethod hformat/fn-handler "count-distinct" [_ field]
+  (str "count(distinct " (hformat/to-sql field) ")"))
+
+(defn fetch
+  "Fetch a single row from the db matching the given `sql-map` or query"
+  [db sql-map & [opts]]
+  (s/assert
+   (s/nilable (s/keys))
+   (binding [*meta-db* db]
+     (jdbc/execute-one!
+      (db)
+      (if (map? sql-map)
+        (hformat/format sql-map)
+        sql-map)
+      (merge jdbc-opts opts)))))
+
+(defn get
+  "Retrieve a single record from the given table by ID"
+  [db table id & [opts]]
+  (when id
+    (fetch
+     db
+     {:select [:*]
+      :from [table]
+      :where [:= :id id]}
+     opts)))
+
+(defn list
+  "Returns a list of rows from the db matching the given sql-map, table or
+  query"
+  [db sql-map-or-table & [opts]]
+  (s/assert
+   (s/coll-of (s/keys))
+   (binding [*meta-db* db]
+     (jdbc/execute!
+      (db)
+      (cond
+        (map? sql-map-or-table)
+        (hformat/format sql-map-or-table)
+        (keyword? sql-map-or-table)
+        (hformat/format {:select [:*] :from [sql-map-or-table]})
+        :else
+        sql-map-or-table)
+      (merge jdbc-opts opts)))))
+
+(defn count
+  [db sql-map]
+  (binding [*meta-db* db]
+    (:count
+     (fetch db {:select [[:%count.* :count]], :from [[sql-map :sq]]}))))
+
+(defn exists?
+  "Returns true if the given sql query-map would return any results"
+  [db sql-map]
+  (binding [*meta-db* db]
+    (pos?
+     (count db sql-map))))
+
+(defn execute!
+  "Given a database and a honeysql query map, perform an operation on the
+  database and discard the results"
+  [db sql-map & [opts]]
+  (jdbc/execute!
+   (db)
+   (hformat/format sql-map)
+   (merge jdbc-opts opts)))
+
+(defn insert!
+  "Given a database, a table name, and a data hash map, inserts the
+  data as a single row in the database and attempts to return a map of generated
+  keys."
+  [db table key-map & [opts]]
+  (binding [*meta-db* db]
+    (sql/insert!
+     (db)
+     table
+     (process-key-map table key-map)
+     (merge jdbc-opts opts))))
+
+(defn update!
+  "Given a database, a table name, a hash map of columns and values
+  to set, and a honeysql predicate, perform an update on the table.
+  Will "
+  [db table key-map where-params & [opts]]
+  (binding [*meta-db* db]
+    (execute! db
+              {:update table
+               :set (u/map-keys keyword (process-key-map table key-map))
+               :where where-params
+               :returning [:id]}
+              opts)))
+
+(defn delete!
+  "Delete all rows from the given table matching the given where clause"
+  [db table where-clause]
+  (binding [*meta-db* db]
+    (sql/delete! (db) table (hformat/format-predicate where-clause))))
+
+(defmacro with-transaction [[sym db opts] & body]
+  `(jdbc/with-transaction
+     [tx# (~db) ~opts]
+     (let [~sym (constantly tx#)]
+       ~@body)))
+
+(defn -main [& args]
+  (let [db (component/start (make-database (env->config)))]
+    (case (first args)
+      "migrate" (migrate! db)
+      "rollback" (rollback! db))))
+
+(comment
+  (def db (:db bbbg.core/system))
+  (generate-migration db "add-attendee-unique-meetup-id")
+  (migrate! db)
+
+  )