feat(grfn/bbbg): Init

This will eventually become a signup sheet + no-show tracker for my
local board game meetup group

Change-Id: Id8d1d80d95d1e2fda5041275cff2fecfd6fa43f1

users/grfn/bbbg/src/bbbg/attendee.clj

@@ -0,0 +1,4 @@
+(ns bbbg.attendee
+  (:require [clojure.spec.alpha :as s]))
+
+(s/def ::id uuid?)

users/grfn/bbbg/src/bbbg/core.clj

@@ -0,0 +1,58 @@
+(ns bbbg.core
+  (:gen-class)
+  (:require
+   [bbbg.db :as db]
+   [bbbg.web :as web]
+   [clojure.spec.alpha :as s]
+   [clojure.spec.test.alpha :as stest]
+   [com.stuartsierra.component :as component]
+   [expound.alpha :as exp]))
+
+(s/def ::config
+  (s/merge
+   ::db/config
+   ::web/config))
+
+(defn make-system [config]
+  (component/system-map
+   :db (db/make-database config)
+   :web (web/make-server config)))
+
+(defn env->config []
+  (s/assert
+   ::config
+   (merge
+    (db/env->config)
+    (web/env->config))))
+
+(defn dev-config []
+  (s/assert
+   ::config
+   (merge
+    (db/dev-config)
+    (web/dev-config))))
+
+(defonce system nil)
+
+(defn init-dev []
+  (s/check-asserts true)
+  (set! s/*explain-out* exp/printer)
+  (stest/instrument))
+
+(defn run-dev []
+  (init-dev)
+  (alter-var-root
+   #'system
+   (fn [sys]
+     (when sys
+       (component/start sys))
+     (component/start (make-system (dev-config))))))
+
+(defn -main [& _args]
+  (alter-var-root
+   #'system
+   (constantly (component/start (make-system (env->config))))))
+
+(comment
+  (run-dev)
+  )

users/grfn/bbbg/src/bbbg/db.clj

@@ -0,0 +1,357 @@
+(ns bbbg.db
+  (:gen-class)
+  (:refer-clojure :exclude [get list])
+  (: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}))
+
+;;;
+;;; 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 exists?
+  "Returns true if the given sql query-map would return any results"
+  [db sql-map]
+  (binding [*meta-db* db]
+    (pos?
+     (:count
+      (fetch db {:select [[:%count.* :count]], :from [[sql-map :sq]]})))))
+
+(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 {::config (env->config)}))]
+    (case (first args)
+      "migrate" (migrate! db)
+      "rollback" (rollback! db))))
+
+(comment
+  (def db (:db bbbg.core/system))
+  (generate-migration db "init-schema")
+  (migrate! db)
+
+
+  )

users/grfn/bbbg/src/bbbg/db/attendee.clj

@@ -0,0 +1,29 @@
+(ns bbbg.db.attendee
+  (:require
+   [bbbg.db :as db]
+   honeysql-postgres.helpers
+   [honeysql.helpers :refer [merge-join merge-where]]))
+
+(defn search
+  ([query]
+   (cond->
+       {:select [:attendee.*]
+        :from [:attendee]}
+     query
+     (assoc
+      :where [:or
+              [:ilike :meetup_name (str "%" query "%")]
+              [:ilike :discord_name (str "%" query "%")]])))
+  ([db query]
+   (db/list db (search query))))
+
+(defn for-event
+  ([query event-id]
+   (-> query
+       (merge-join :event_attendee [:= :attendee.id :event_attendee.attendee_id])
+       (merge-where [:= :event_attendee.event_id event-id]))))
+
+(comment
+  (def db (:db bbbg.core/system))
+  (search db "gri")
+  )

users/grfn/bbbg/src/bbbg/db/event.clj

@@ -0,0 +1,50 @@
+(ns bbbg.db.event
+  (:require
+   [bbbg.attendee :as attendee]
+   [bbbg.db :as db]
+   [bbbg.event :as event]
+   [honeysql.helpers :refer [merge-group-by merge-join merge-select]]
+   [java-time :refer [local-date]]))
+
+(defn create! [db event]
+  (db/insert! db :event (select-keys event [::event/date])))
+
+(defn attended!
+  [db params]
+  (db/execute!
+   db
+   {:insert-into :event-attendee
+    :values [{:event_id (::event/id params)
+              :attendee_id (::attendee/id params)
+              :attended true}]
+    :upsert {:on-conflict [:event-id :attendee-id]
+             :do-update-set! {:attended true}}}))
+
+(defn on-day
+  ([day] {:select [:event.*]
+          :from [:event]
+          :where [:= :date (str day)]})
+  ([db day]
+   (db/list db (on-day day))))
+
+(defn today
+  ([] (on-day (local-date)))
+  ([db] (db/list db (today))))
+
+(defn with-attendee-counts
+  [query]
+  (-> query
+      (merge-join :event_attendee [:= :event.id :event_attendee.event-id])
+      (merge-select :%count.event_attendee.attendee_id)
+      (merge-group-by :event.id :event_attendee.event-id)))
+
+(comment
+  (def db (:db bbbg.core/system))
+  (db/list db (-> (today) (with-attendee-counts)))
+
+  (honeysql.format/format
+   (honeysql-postgres.helpers/upsert {:insert-into :foo
+                                      :values {:bar 1}}
+                                     (-> (honeysql-postgres.helpers/on-conflict :did)
+                                         (honeysql-postgres.helpers/do-update-set! [:did true]))))
+  )

users/grfn/bbbg/src/bbbg/event.clj

@@ -0,0 +1,4 @@
+(ns bbbg.event
+  (:require [clojure.spec.alpha :as s]))
+
+(s/def ::id uuid?)

users/grfn/bbbg/src/bbbg/event_attendee.clj

@@ -0,0 +1,4 @@
+(ns bbbg.event-attendee
+  (:require [clojure.spec.alpha :as s]))
+
+(s/def ::attended? boolean?)

users/grfn/bbbg/src/bbbg/handlers/attendees.clj

@@ -0,0 +1,40 @@
+(ns bbbg.handlers.attendees
+  (:require
+   [bbbg.attendee :as attendee]
+   [bbbg.db :as db]
+   [bbbg.db.attendee :as db.attendee]
+   [bbbg.db.event :as db.event]
+   [bbbg.event :as event]
+   [cheshire.core :as json]
+   [compojure.core :refer [GET POST routes]]
+   [honeysql.helpers :refer [merge-where]]
+   [ring.util.response :refer [content-type redirect response]]))
+
+(defn attendees-routes [{:keys [db]}]
+  (routes
+   (GET "/attendees.json" [q event_id attended]
+     (let [results
+           (db/list
+            db
+            (cond->
+                (if q
+                  (db.attendee/search q)
+                  {:select [:attendee.*] :from [:attendee]})
+              event_id (db.attendee/for-event event_id)
+              (some? attended) (merge-where [:= :attended (case attended
+                                                            "true" true
+                                                            "false" false)])))]
+       (-> {:results results}
+           json/generate-string
+           response
+           (content-type "application/json"))))
+
+   (POST "/event_attendees" [event_id attendee_id]
+     (if (and (db/exists? db {:select [:id] :from [:event] :where [:= :id event_id]})
+              (db/exists? db {:select [:id] :from [:attendee] :where [:= :id attendee_id]}))
+       (do
+         (db.event/attended! db {::event/id event_id
+                                 ::attendee/id attendee_id})
+         (-> (redirect (str "/signup-forms/" event_id))
+             (assoc :flash "Thank you for signing in! Enjoy the event.")))
+       (response "Something went wrong")))))

users/grfn/bbbg/src/bbbg/handlers/core.clj

@@ -0,0 +1,34 @@
+(ns bbbg.handlers.core
+  (:require
+   [hiccup.core :refer [html]]
+   [ring.util.response :refer [content-type response]]))
+
+(defn render-page [opts & body]
+  (let [[{:keys [title]} body]
+        (if (map? opts)
+          [opts body]
+          [{} (into [opts] body)])]
+    (html
+     [:html {:lang "en"}
+      [:head
+       [:meta {:charset "UTF-8"}]
+       [:title (if title
+                 (str title " - BBBG")
+                 "BBBG")]
+       [:link {:rel "stylesheet"
+               :type "text/css"
+               :href "/main.css"}]]
+      [:body
+       (into [:div.content] body)
+       [:script {:src "https://cdnjs.cloudflare.com/ajax/libs/tarekraafat-autocomplete.js/10.2.6/autoComplete.js"}]
+       [:script {:src "/main.js"}]]])))
+
+(defn page-response [& render-page-args]
+  (-> (apply render-page render-page-args)
+      response
+      (content-type "text/html")))
+
+(comment
+  (render-page
+   [:h1 "hi"])
+  )

users/grfn/bbbg/src/bbbg/handlers/events.clj

@@ -0,0 +1,44 @@
+(ns bbbg.handlers.events
+  (:require
+   [bbbg.db :as db]
+   [bbbg.db.event :as db.event]
+   [bbbg.event :as event]
+   [bbbg.handlers.core :refer [page-response]]
+   [compojure.core :refer [context GET POST]]
+   [ring.util.response :refer [redirect]]))
+
+(defn events-index [events]
+  [:ul.events-list
+   (for [event events]
+     [:li (::event/date event)])])
+
+(defn event-form
+  ([] (event-form {}))
+  ([event]
+   [:form {:method "POST" :action "/events"}
+    [:div.form-group
+     [:label "Date"
+      [:input {:type "date"
+               :id "date"
+               :name "date"
+               :value (str (::event/date event))}]]]
+    [:div.form-group
+     [:input {:type "submit"
+              :value "Create Event"}]]]))
+
+(defn events-routes [{:keys [db]}]
+  (context "/events" []
+    (GET "/" []
+      (let [events (db/list db :event)]
+        (events-index events)))
+
+    (GET "/new" [date]
+      (page-response
+       {:title "New Event"}
+       (event-form {::event/date date})))
+
+    (POST "/" [date]
+      (let [event (db.event/create! db {::event/date date})]
+        (-> (str "/signup-forms/" (::event/id event))
+            redirect
+            (assoc-in [:flash :message] "Event Created"))))))

users/grfn/bbbg/src/bbbg/handlers/home.clj

@@ -0,0 +1,17 @@
+(ns bbbg.handlers.home
+  (:require
+   [bbbg.handlers.core :refer [page-response]]
+   [compojure.core :refer [GET routes]]))
+
+(defn- home-page []
+  [:nav.home-nav
+   [:ul
+    [:li [:a {:href "/signup-forms"}
+          "Event Signup Form"]]
+    [:li [:a {:href "/login"}
+          "Sign In"]]]])
+
+(defn home-routes [_env]
+  (routes
+   (GET "/" []
+     (page-response (home-page)))))

users/grfn/bbbg/src/bbbg/handlers/signup_form.clj

@@ -0,0 +1,57 @@
+(ns bbbg.handlers.signup-form
+  (:require
+   [bbbg.db :as db]
+   [bbbg.db.event :as db.event]
+   [bbbg.event :as event]
+   [bbbg.handlers.core :refer [page-response]]
+   [compojure.core :refer [GET context]]
+   [java-time :refer [local-date]]
+   [ring.util.response :refer [redirect]]))
+
+(defn no-events-page []
+  [:div.no-events
+   [:p
+    "There are no events for today"]
+   [:p
+    [:a {:href (str "/events/new?date=" (str (local-date)))} "Create Event"]
+    [:a {:href "/events"} "All Events"]]])
+
+(defn signup-page [event]
+  [:div.signup-page
+   [:form#signup-form
+    {:method "POST"
+     :action "/event_attendees"
+     :disabled "disabled"}
+    [:input#event-id {:type "hidden" :name "event_id" :value (::event/id event)}]
+    [:input#attendee-id {:type "hidden" :name "attendee_id"}]
+    [:label "Name"
+     [:input#name-autocomplete
+      {:type "search"
+       :name "name"
+       :spellcheck "false"
+       :autocorrect "off"
+       :autocomplete "off"
+       :autocapitalize "off"
+       :maxlength "2048"}]]
+    [:input {:type "submit"
+             :value "Sign In"
+             :disabled "disabled"}]]])
+
+(defn event-not-found []
+  [:div.event-not-found
+   [:p "Event not found"]
+   [:p [:a {:href (str "/events/new")} "Create a new event"]]])
+
+;;;
+
+(defn signup-form-routes [{:keys [db]}]
+  (context "/signup-forms" []
+   (GET "/" []
+     (if-let [event (db/fetch db (db.event/today))]
+       (redirect (str "/signup-forms/" (::event/id event)))
+       (page-response (no-events-page))))
+
+   (GET "/:event-id" [event-id]
+     (if-let [event (db/get db :event event-id)]
+       (page-response (signup-page event))
+       (event-not-found)))))

users/grfn/bbbg/src/bbbg/styles.clj

@@ -0,0 +1,9 @@
+(ns bbbg.styles
+  (:require [garden.def :refer [defstyles]]
+            [garden.compiler :refer [compile-css]]))
+
+(defstyles styles
+  )
+
+(def stylesheet
+  (compile-css styles))

users/grfn/bbbg/src/bbbg/util/core.clj

@@ -0,0 +1,117 @@
+(ns bbbg.util.core
+  (:import java.util.UUID))
+
+(defn remove-nils
+  "Remove all keys with nil values from m"
+  [m]
+  (let [!m (transient m)]
+    (doseq [[k v] m]
+      (when (nil? v)
+        (dissoc! !m k)))
+    (persistent! !m)))
+
+
+(defn alongside
+  "Apply a pair of functions to the first and second element of a two element
+  vector, respectively. The two argument form partially applies, such that:
+
+  ((alongside f g) xy) ≡ (alongside f g xy)
+
+  This is equivalent to (***) in haskell's Control.Arrow"
+  ([f g] (partial alongside f g))
+  ([f g [x y]] [(f x) (g y)]))
+
+(defn map-kv
+  "Map a pair of functions over the keys and values of a map, respectively.
+  Preserves metadata on the incoming map.
+  The two argument form returns a transducer that yields map-entries.
+
+  (partial map-kv identity identity) ≡ identity"
+  ([kf vf]
+   (map (fn [[k v]]
+          ;; important to return a map-entry here so that callers down the road
+          ;; can use `key` or `val`
+          (first {(kf k) (vf v)}))))
+  ([kf vf m]
+   (into (empty m) (map-kv kf vf) m)))
+
+(defn filter-kv
+  "Returns a map containing the elements of m for which (f k v) returns logical
+  true. The one-argument form returns a transducer that yields map entries"
+  ([f] (filter (partial apply f)))
+  ([f m]
+   (into (empty m) (filter-kv f) m)))
+
+(defn map-keys
+  "Map f over the keys of m. Preserves metadata on the incoming map. The
+  one-argument form returns a transducer that yields map-entries."
+  ([f] (map-kv f identity))
+  ([f m] (map-kv f identity m)))
+
+(defn map-vals
+  "Map f over the values of m. Preserves metadata on the incoming map. The
+  one-argument form returns a transducer that yields map-entries."
+  ([f] (map-kv identity f))
+  ([f m] (map-kv identity f m)))
+
+(defn map-keys-recursive [f x]
+  (cond
+    (map? x) (map-kv f (partial map-keys-recursive f) x)
+    (sequential? x) (map (partial map-keys-recursive f) x)
+    :else x))
+
+(defn denamespace [x]
+  (if (keyword? x)
+    (keyword (name x))
+    (map-keys-recursive denamespace x)))
+
+(defn reverse-merge
+  "Like `clojure.core/merge`, except duplicate keys from maps earlier in the
+  argument list take precedence
+
+    => (merge {:x 1} {:x 2})
+    {:x 2}
+
+    => (sut/reverse-merge {:x 1} {:x 2})
+    {:x 1}"
+  [& ms]
+  (apply merge (reverse ms)))
+
+(defn invert-map
+  "Invert the keys and vals of m. Behavior with duplicate vals is undefined.
+
+  => (sut/invert-map {:x 1 :y 2})
+  {1 :x 2 :y}"
+  [m]
+  (into {} (map (comp vec reverse)) m))
+
+(defn ->uuid
+  "Converts x to uuid, returning nil if x is nil or empty"
+  [x]
+  (cond
+    (not x) nil
+    (uuid? x) x
+    (and (string? x) (seq x))
+    (UUID/fromString x)))
+
+(defn key-by
+  "Create a map from a seq obtaining keys via f
+
+    => (sut/key-by :x [{:x 1} {:x 2 :y 3}])
+    {1 {:x 1}, 2 {:x 2 :y 3}}"
+  [f l]
+  (into {} (map (juxt f identity)) l))
+
+(defn distinct-by
+  "Like clojure.core/distinct, but can take a function f by which
+  distinctiveness is calculated"
+  [distinction-fn coll]
+  (let [step (fn step [xs seen]
+               (lazy-seq
+                ((fn [[f :as xs] seen]
+                   (when-let [s (seq xs)]
+                     (if (contains? seen (distinction-fn f))
+                       (recur (rest s) seen)
+                       (cons f (step (rest s) (conj seen (distinction-fn f)))))))
+                 xs seen)))]
+    (step coll #{})))

users/grfn/bbbg/src/bbbg/web.clj

@@ -0,0 +1,77 @@
+(ns bbbg.web
+  (:require
+   [bbbg.handlers.attendees :as attendees]
+   [bbbg.handlers.events :as events]
+   [bbbg.handlers.home :as home]
+   [bbbg.handlers.signup-form :as signup-form]
+   [bbbg.styles :refer [stylesheet]]
+   [clojure.spec.alpha :as s]
+   [com.stuartsierra.component :as component]
+   [compojure.core :refer [GET routes]]
+   [config.core :refer [env]]
+   [org.httpkit.server :as http-kit]
+   [ring.middleware.flash :refer [wrap-flash]]
+   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
+   [ring.middleware.params :refer [wrap-params]]
+   [ring.util.response :refer [content-type response resource-response]]))
+
+(s/def ::port pos-int?)
+
+(s/def ::config
+  (s/keys :req [::port]))
+
+(s/fdef make-server
+  :args (s/cat :config ::config))
+
+(defn env->config []
+  (s/assert
+   ::config
+   {::port (:port env 8888)}))
+
+(defn dev-config []
+  (s/assert ::config {::port 8888}))
+
+;;;
+
+(defn app-routes [env]
+  (routes
+   (GET "/main.css" []
+     (-> (response stylesheet)
+         (content-type "text/css")))
+   (GET "/main.js" []
+     (-> (resource-response "main.js")
+         (content-type "text/javascript")))
+
+   (attendees/attendees-routes env)
+   (signup-form/signup-form-routes env)
+   (events/events-routes env)
+   (home/home-routes env)))
+
+(defn middleware [app]
+  (-> app
+      wrap-keyword-params
+      wrap-params
+      wrap-flash))
+
+(defn handler [this]
+  (middleware
+   (app-routes this)))
+
+(defrecord WebServer [port db]
+  component/Lifecycle
+  (start [this]
+    (assoc this
+           ::shutdown-fn
+           (http-kit/run-server
+            (fn [r] ((handler this) r))
+            {:port port})))
+  (stop [this]
+    (if-let [shutdown-fn (::shutdown-fn this)]
+      (do (shutdown-fn :timeout 100)
+          (dissoc this ::shutdown-fn))
+      this)))
+
+(defn make-server [{::keys [port]}]
+  (component/using
+   (map->WebServer {:port port})
+   [:db]))