Meh: A clojure macro for clj-rethinkdb

meh-macro

(ns db.meh
  (:use
    [clojure.pprint]
    [slingshot.slingshot :only [throw+ try+]])
  (:require
    [clojure.set :as set]
    [taoensso.timbre :as timbre]))

;; Parse
;; -----

(defn empty-component [id]
  {:id id :required [] :fields {} :definitions (array-map) :functions []
   :suffix identity})

(defn parse-fields [[fields & tail] r]
  [tail (assoc r :fields (apply hash-map fields))])

(defn parse-define [[id f & tail] r]
  [tail (assoc-in r [:definitions id] f)])

(defn parse-simple
  "assoc in r - rkey the head of the first input"
  [[v & tail] r rkey]
  [tail (assoc r rkey v)])

(defn empty-def [id params]
  {:symbol id :params params :raw (gensym)})

(defn add-raw [body fdef]
  (if (= :raw (first body))
    (assoc fdef :raw (second body) :body (rest (rest body)))
    (assoc fdef :body body)))

(defn parse-def [[id params & tail] r]
  (->> (empty-def id params)
       (add-raw tail)
       (update-in r [:functions] conj)))

(defn parse-item [[head & tail] r]
  (case head
    :fields (parse-fields tail r)
    :define (parse-define tail r)
    :required (parse-simple tail r :required)
    :suffix (parse-simple tail r :suffix)
    [tail (parse-def head r)]))

;; Return
;; {
;;  :id id
;;  :required [fields-list]
;;  :fields {key -> symbol}
;;  :definitions {symbol -> function}
;;  :functions [{symbol params raw body}]
;;  }
(defn parse
  "Parse a with-component definition"
  [id body]
  (loop [body body r (empty-component id)]
    (if (empty? body)
      (update-in r [:definitions] identity)
      (let [[then r] (parse-item body r)]
        (recur then r)))))


;; Produce
;; -------

(defn make-body [item]
  (:body item))

(defn build-definition [c parsed]
  (let [defs (:definitions parsed)
        wrapped (map (fn [[id f]] [id `(~f ~c)]) defs)]
    (reduce #(concat %1 %2) [] wrapped)))


(defn wrap-definition [body c parsed]
  `(let [~@(build-definition c parsed)]
     ~@body))

(defn build-fields [c parsed]
  (let [fields (:fields parsed)
        wrapped (map (fn [[k sym]] [sym `(~k ~c)]) fields)]
    (reduce #(concat %1 %2) [] wrapped)))

(defn wrap-fields [body c parsed]
  `(let [~@(build-fields c parsed)]
    ~body))

(defn check-required [actual expected]
  (let [diff (set/difference (set expected) (set actual))]
    (when (not (empty? diff))
      (throw+ "Missing fields in component:"
              diff))))

(defn wrap-required [body c parsed]
  `(do (check-required (keys ~c) ~(:required parsed))
       ~body))

(defn wrap-raw-definition [body item parsed]
  `(defn ~(:raw item) ~(:params item)
     ~body))

(defn c-param [item]
  (first (:params item)))

(defn make-raw [item parsed]
  (let [c (c-param item)]
    (-> (make-body item)
        (wrap-definition c parsed)
        (wrap-fields c parsed)
        (wrap-required c parsed)
        (wrap-raw-definition item parsed))))

(defn make-body-full [item parsed]
  `(~(:suffix parsed) (~(:raw item) ~@(:params item))))

(defn make-full-header [body item parsed]
  `(defn ~(:symbol item) ~(:params item)
     ~body))

(defn make-full [item parsed]
  (let [c (c-param item)]
  (-> (make-body-full item parsed)
      (wrap-fields c parsed)
      (make-full-header item parsed))))

(defn produce [parsed]
  (concat (map #(make-raw % parsed) (:functions parsed))
          (map #(make-full % parsed) (:functions parsed))))

(defmacro with-component [id & body]
  (let [parsed (parse id body)]
    `(do ~@(produce parsed))))

(defmacro pprint-definition [id & body]
  (pprint (parse id body)))

(defmacro pprint-production [id & body]
  (let [parsed (parse id body)]
    (pprint (produce parsed))))

meh-usage-db-profiles

(ns db.profiles
  (:use
    [slingshot.slingshot :only [throw+ try+]])
  (:require
    [db.meh :as meh]
    [db.fast :as fast]
    [rethinkdb.query :as r]))

(meh/with-component profile-component
  :required [:db :table :version :ip :port]
  :fields [:version version :ip ip :port port]
  :define db
  (fn [c]
    (r/db (:db c)))
  :define table
  (fn [c]
    (r/table db (:table c)))
  :suffix
  (fn [r]
    (fast/send r :ip ip :port port))

  (ls
    [c]
    :raw >ls
    table)

  (find-all
    [c login]
    :raw >find-all
    (-> table (r/get-all [login] {:index "login"})))

  (has?
    [c login]
    :raw >has?
    (r/gt (r/count (>find-all c login)) 0))

  (has-branch
    [c login truthy falsey]
    :raw >has-branch
    (-> (r/branch (r/eq true (>has? c login))
                  truthy
                  falsey)))

  (create-
    [c login password]
    (>has-branch c login
                 nil
                 (r/insert table {:version version
                                  :login login :password password})))

  (get
    [c login]
    :raw >get
    (>has-branch c login
                 (r/nth (>find-all c login) 0)
                 nil))

  (identify
    [c login password]
    (>has-branch c login
                 (r/branch (r/eq password
                                 (r/get-field (>get c login) "password"))
                           (>get c login)
                           nil)
                 nil))

  (delete
    [c login]
    (>has-branch c login
                 (r/delete (>get c login))
                 nil)))