(ns postal.client
  (:require [cognitect.transit :as t]
            [promesa.core :as p]
            [beicon.core :as s]
            [goog.crypt.base64 :as b64]
            [goog.events :as events]
            [httpurr.client :as http]
            [httpurr.status :as http-status]
            [httpurr.client.xhr :as xhr])
  (:import [goog.net WebSocket]
           [goog.net.WebSocket EventType]
           [goog.Uri QueryData]
           [goog Uri Timer]))

(def ^:private
  +default-headers+
  {"content-type" "application/transit+json"})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data encoding/decoding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn decode
  [data]
  (let [r (t/reader :json {:handlers {"u" ->UUID}})]
    (t/read r data)))

(defn encode
  [data]
  (let [w (t/writer :json)]
    (t/write w data)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation Details
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- process-response
  [response]
  (if (http-status/success? response)
    (let [message (decode (:body response))]
      (if (identical? (:type message) :error)
        (p/rejected message)
        (p/resolved message)))
    (p/rejected (ex-info "Unexpected" response))))

(defn- prepare-request
  ([client data]
   (prepare-request client data (:method client) {}))
  ([client data method params]
   (let [req {:headers (merge +default-headers+ @(:headers client))
              :method method
              :url (:url client)}]
     (if (= method :get)
       (let [pd (.clone (:params client))]
         (when-not (empty? params)
           (.extend pd (clj->js params)))
         (.set pd "d" (b64/encodeString data true))
         (merge req {:query-string (.toString pd)}))
       (if (empty? params)
         (let [pd (:params client)]
           (merge req {:body data :query-string (.toString pd)}))
         (let [pd (.clone (:params client))]
           (.extend pd (clj->js params))
           (merge req {:body data :query-string (.toString pd)})))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The basic client interface.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defrecord Client [headers method url params])

(defn client
  "Creates a new client instance from socket."
  ([url]
   (client url {}))
  ([url {:keys [headers method params]
         :or {headers {} method :put params {}}}]
   (let [paramsdata (QueryData.)]
     (.extend paramsdata (clj->js params))
     (Client. (atom headers) method url paramsdata))))

(defn client?
  "Return true if a privided client is instance
  of Client type."
  [client]
  (instance? Client client))

(defn update-headers!
  "Update the headers on the client instance."
  [c headers]
  {:pre [(client? c)]}
  (let [ha (:headers c)]
    (swap! ha merge headers)))

(defn reset-headers!
  "Reset the headers on the client instance."
  [c headers]
  {:pre [(client? c)]}
  (let [ha (:headers c)]
    (reset! ha headers)))

(defn send!
  [client {:keys [type dest data headers] :as opts}]
  {:pre [(or (map? data)
             (nil? data))
         (keyword? dest)
         (client? client)]}
  (let [data (encode {:data data :dest dest :type type})
        req (prepare-request client data)]
    (-> (http/send! xhr/client req)
        (p/then process-response))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reques/Reply Pattern
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn query
  "Sends a query message to a server."
  ([client dest]
   (query client dest nil {}))
  ([client dest data]
   (query client dest data {}))
  ([client dest data opts]
   (send! client (merge {:type :query
                         :dest dest
                         :data data}
                        opts))))

(defn novelty
  "Sends a novelty message to a server."
  ([client dest]
   (query client dest nil {}))
  ([client dest data]
   (query client dest data {}))
  ([client dest data opts]
   (send! client (merge {:type :novelty
                         :dest dest
                         :data data}
                        opts))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EventSource
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn socket
  ([client dest]
   (socket client dest nil nil))
  ([client dest data]
   (socket client dest data nil))
  ([client dest data {:keys [params] :or {params {}}}]
   (let [req (prepare-request client data :get params)
         uri (Uri. (:url req))]
     (.setQuery uri (:query-string req))
     (.setScheme uri (if (= (.getScheme uri) "http") "ws" "wss"))
     (let [ws (WebSocket. (.toString uri))
           timer (Timer. 5000)
           busin (s/bus)
           streamin (s/filter #(not= (:type %) :ping) busin)
           busout (s/bus)]
       (letfn [(on-ws-message [event]
                 (let [frame (decode (.-data event))]
                   (s/push! busin frame)))
               (on-ws-error [event]
                 (s/error! busin event)
                 (.close ws))
               (on-timer-tick [_]
                 (let [frame {:type :ping}]
                   (s/push! busout frame)))
               (on-busout-value [msg]
                 (let [data (encode msg)]
                   (.send ws data)))
               (on-busout-end []
                 (.close ws))]
         (s/on-end busout on-busout-end)
         (s/on-value busout on-busout-value)

         (events/listen ws EventType.MESSAGE on-ws-message)
         (events/listen ws EventType.ERROR on-ws-error)
         (events/listen timer Timer.TICK on-timer-tick)

         [streamin busout])))))

(defn subscribe
  ([client dest]
   (subscribe client dest nil nil))
  ([client dest data]
   (subscribe client dest data nil))
  ([client dest data {:keys [params] :or {params {}} :as opts}]
   (let [[in out] (socket client dest data opts)
         bus (s/bus)]
     (s/subscribe in #(s/push! bus %) #(s/error! bus %) #(s/end! bus))
     (s/on-end bus #(s/end! out))
     bus)))

(ns postal.client
  (:require [cognitect.transit :as t]
            [promesa.core :as p]
            [beicon.core :as s]
            [goog.crypt.base64 :as b64]
            [goog.events :as events]
            [httpurr.client :as http]
            [httpurr.status :as http-status]
            [httpurr.client.xhr :as xhr])
  (:import [goog.net WebSocket]
           [goog.net.WebSocket EventType]
           [goog.Uri QueryData]
           [goog Uri Timer]))

(def ^:private
  +default-headers+
  {"content-type" "application/transit+json"})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data encoding/decoding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn decode
  [data]
  (let [r (t/reader :json {:handlers {"u" ->UUID}})]
    (t/read r data)))

(defn encode
  [data]
  (let [w (t/writer :json)]
    (t/write w data)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation Details
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- process-response
  [response]
  (if (http-status/success? response)
    (let [message (decode (:body response))]
      (if (identical? (:type message) :error)
        (p/rejected message)
        (p/resolved message)))
    (p/rejected (ex-info "Unexpected" response))))

(defn- prepare-request
  ([client data]
   (prepare-request client data (:method client) {}))
  ([client data method params]
   (let [req {:headers (merge +default-headers+ @(:headers client))
              :method method
              :url (:url client)}]
     (if (= method :get)
       (let [pd (.clone (:params client))]
         (when-not (empty? params)
           (.extend pd (clj->js params)))
         (.set pd "d" (b64/encodeString data true))
         (merge req {:query-string (.toString pd)}))
       (if (empty? params)
         (let [pd (:params client)]
           (merge req {:body data :query-string (.toString pd)}))
         (let [pd (.clone (:params client))]
           (.extend pd (clj->js params))
           (merge req {:body data :query-string (.toString pd)})))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The basic client interface.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defrecord Client [headers method url params])

(defn client
  "Creates a new client instance from socket."
  ([url]
   (client url {}))
  ([url {:keys [headers method params]
         :or {headers {} method :put params {}}}]
   (let [paramsdata (QueryData.)]
     (.extend paramsdata (clj->js params))
     (Client. (atom headers) method url paramsdata))))

(defn client?
  "Return true if a privided client is instance
  of Client type."
  [client]
  (instance? Client client))

(defn update-headers!
  "Update the headers on the client instance."
  [c headers]
  {:pre [(client? c)]}
  (let [ha (:headers c)]
    (swap! ha merge headers)))

(defn reset-headers!
  "Reset the headers on the client instance."
  [c headers]
  {:pre [(client? c)]}
  (let [ha (:headers c)]
    (reset! ha headers)))

(defn send!
  [client {:keys [type dest data headers] :as opts}]
  {:pre [(or (map? data)
             (nil? data))
         (keyword? dest)
         (client? client)]}
  (let [data (encode {:data data :dest dest :type type})
        req (prepare-request client data)]
    (-> (http/send! xhr/client req)
        (p/then process-response))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reques/Reply Pattern
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn query
  "Sends a query message to a server."
  ([client dest]
   (query client dest nil {}))
  ([client dest data]
   (query client dest data {}))
  ([client dest data opts]
   (send! client (merge {:type :query
                         :dest dest
                         :data data}
                        opts))))

(defn novelty
  "Sends a novelty message to a server."
  ([client dest]
   (query client dest nil {}))
  ([client dest data]
   (query client dest data {}))
  ([client dest data opts]
   (send! client (merge {:type :novelty
                         :dest dest
                         :data data}
                        opts))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Socket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn socket
  ([client dest]
   (socket client dest nil nil))
  ([client dest data]
   (socket client dest data nil))
  ([client dest data {:keys [params _type] :or {params {} _type :socket}}]
   (let [frame (encode {:data data :dest dest :type _type})
         req (prepare-request client frame :get params)
         uri (Uri. (:url req))]
     (.setQuery uri (:query-string req))
     (.setScheme uri (if (= (.getScheme uri) "http") "ws" "wss"))
     (let [ws (WebSocket. false)
           timer (Timer. 5000)
           busin (s/bus)
           streamin (s/filter #(not= (:type %) :ping) busin)
           busout (s/bus)]
       (letfn [(on-ws-message [event]
                 (let [frame (decode (.-message event))]
                   (s/push! busin frame)))
               (on-ws-error [event]
                 (s/error! busin event)
                 (.close ws))
               (on-ws-closed [event]
                 (s/end! busout)
                 (s/end! busin))
               (on-timer-tick [_]
                 (let [frame {:type :ping}]
                   (s/push! busout frame)))
               (on-busout-value [msg]
                 (let [data (encode msg)]
                   (.send ws data)))
               (on-busout-end []
                 (.close ws))]

         (s/on-end busout on-busout-end)
         (s/on-value busout on-busout-value)

         (events/listen ws EventType.MESSAGE on-ws-message)
         (events/listen ws EventType.ERROR on-ws-error)
         (events/listen ws EventType.CLOSED on-ws-closed)
         (events/listen timer Timer.TICK on-timer-tick)

         (.start timer)
         (.open ws (.toString uri))

         [streamin busout])))))

(defn subscribe
  ([client dest]
   (subscribe client dest nil nil))
  ([client dest data]
   (subscribe client dest data nil))
  ([client dest data {:keys [params] :or {params {}} :as opts}]
   (let [[in out] (socket client dest data (assoc opts :_type :subscribe))
         bus (s/bus)]
     (s/subscribe in #(s/push! bus %) #(s/error! bus %) #(s/end! bus))
     (s/on-end bus #(s/end! out))
     bus)))

Fix bugs on socket and subscribe functions.


(ns pump.template
  (:require [clojure.string :as string]))

(declare elem-factory)

(let [cache (js/Object.)]
  (defn dash-to-camel-name
    [k]
    (or (aget cache k)
        (let [words (string/split (name k) #"-")
              camels (map string/capitalize (rest words))
              complete (keyword (apply str (first words) camels))]
          (aset cache k complete)
          complete))))

(defn as-content
  [content]
  (for [c content]
    (cond (nil? c) nil
          (map? c) (throw "Maps cannot be used as content")
          (string? c) c
          (vector? c) (elem-factory c)
          (seq? c) (as-content c)
          :else (str c))))

;; From Weavejester's Hiccup: https://github.com/weavejester/hiccup/blob/master/src/hiccup/compiler.clj#L32
(def ^{:doc "Regular expression that parses a CSS-style id and class from a tag name."
       :private true}
  re-tag #"([^\s\.#]+)(?:#([^\s\.#]+))?(?:\.([^\s#]+))?")

(defn parse-tag
  [tag]
  (if (fn? tag)
    [:custom tag nil nil]
    (let [[tag id class] (next (re-matches re-tag (name tag)))]
      [:vanilla (aget (.-DOM js/React) tag) id class])))

(def attr-mapping
  {:class :className
   :for :htmlFor})

(defn normalize-attributes
  [attrs]
  (into {} (map
            (fn [[k v]] [(dash-to-camel-name (attr-mapping k k)) v])
            attrs)))

(defn exclude-empty
  [attrs]
  (into {} (filter (fn [[k v]] v) attrs)))

(defn normalize-element
  "Ensure an element vector is of the form [tag-name attrs content]."
  [[tag & content]]
  (when (not (or (keyword? tag) (symbol? tag) (string? tag) (fn? tag)))
    (throw (str tag " is not a valid element name.")))
  (let [[tag-type tag id class] (parse-tag tag)
        tag-attrs      {:id (or id nil)
                        :className (if class (string/replace class #"\." " "))}
        map-attrs      (first content)]
    (if (map? map-attrs)
      [tag-type tag (merge tag-attrs (if (= tag-type :vanilla)
                                       (normalize-attributes map-attrs)
                                       map-attrs))
       (next content)]
      [tag-type tag tag-attrs content])))

(defn elem-factory
  [elem-def]
  (let [[tag-type tag-fn attrs content] (normalize-element elem-def)
        attrs (exclude-empty attrs)
        attrs (if (= tag-type :vanilla) (clj->js attrs) attrs)]
    (if (nil? tag-fn)
      (throw (str "Element definition '" (pr-str elem-def) "' could not be parsed")))
    (tag-fn attrs (clj->js (as-content content)))))

(defn html [& tags]
  (let [res (map elem-factory tags)]
    (if (second res)
      res
      (first res))))

(ns pump.template
  (:require [clojure.string :as string]))

(declare elem-factory)

(let [cache (js/Object.)]
  (defn dash-to-camel-name
    [k]
    (or (aget cache k)
        (let [words (string/split (name k) #"-")
              camels (map string/capitalize (rest words))
              complete (keyword (apply str (first words) camels))]
          (aset cache k complete)
          complete))))

(defn as-content
  [content]
  (for [c content]
    (cond (nil? c) nil
          (map? c) (throw "Maps cannot be used as content")
          (string? c) c
          (vector? c) (elem-factory c)
          (seq? c) (as-content c)
          :else (str c))))

;; From Weavejester's Hiccup: https://github.com/weavejester/hiccup/blob/master/src/hiccup/compiler.clj#L32
(def ^{:doc "Regular expression that parses a CSS-style id and class from a tag name."
       :private true}
  re-tag #"([^\s\.#]+)(?:#([^\s\.#]+))?(?:\.([^\s#]+))?")

(defn parse-tag
  [tag]
  (if (fn? tag)
    [:custom tag nil]
    (let [[tag id class] (next (re-matches re-tag (name tag)))]
      [:vanilla
       (aget (.-DOM js/React) tag)
       {:id (or id nil)
        :className (if class (string/replace class #"\." " "))}])))

(def attr-mapping
  {:class :className
   :for :htmlFor})

(defn normalize-into
  [tag-attrs attrs]
  (into tag-attrs (map
                   (fn [[k v]] [(dash-to-camel-name (attr-mapping k k)) v])
                   attrs)))

(defn exclude-empty
  [attrs]
  (into {} (filter (fn [[k v]] v) attrs)))

(defn normalize-element
  "Ensure an element vector is of the form [tag-name attrs content]."
  [[tag & content]]
  (when (not (or (keyword? tag) (symbol? tag) (string? tag) (fn? tag)))
    (throw (str tag " is not a valid element name.")))
  (let [[tag-type tag tag-attrs] (parse-tag tag)
        map-attrs      (first content)]
    (if (map? map-attrs)
      [tag-type tag (if (= tag-type :vanilla)
                      (normalize-into tag-attrs map-attrs)
                      map-attrs)
       (next content)]
      [tag-type tag tag-attrs content])))

(defn elem-factory
  [elem-def]
  (let [[tag-type tag-fn attrs content] (normalize-element elem-def)
        attrs (exclude-empty attrs)
        attrs (if (= tag-type :vanilla) (clj->js attrs) attrs)]
    (if (nil? tag-fn)
      (throw (str "Element definition '" (pr-str elem-def) "' could not be parsed")))
    (tag-fn attrs (clj->js (as-content content)))))

(defn html [& tags]
  (let [res (map elem-factory tags)]
    (if (second res)
      res
      (first res))))

Change normalise-element logic

Change normalise-element logic


(ns blocks.store.tests
  "Suite of tests to verify that a given block store implementation conforms to
  the spec."
  (:require
    [alphabase.bytes :as bytes]
    [alphabase.hex :as hex]
    [blocks.core :as block]
    [blocks.store.util :as util]
    [clojure.java.io :as io]
    [clojure.test :refer :all]
    [clojure.test.check :as check]
    [clojure.test.check.generators :as gen]
    [clojure.test.check.properties :as prop]
    [com.stuartsierra.component :as component]
    [multihash.core :as multihash]
    [multihash.digest :as digest])
  (:import
    blocks.data.PersistentBytes))

(defn random-block
  "Creates a new block with random content at most `max-size` bytes long."
  [max-size]
  (block/read!
    (bytes/random-bytes (inc (rand-int max-size)))
    (rand-nth (keys digest/functions))))

(defn generate-blocks!
  "Generates some test blocks and returns a map of the ids to the blocks."
  [n max-size]
  (->> (repeatedly #(random-block max-size))
       (take n)
       (map (juxt :id identity))
       (into (sorted-map))))

(defn populate-blocks!
  "Generates random blocks and puts them into the given store. Returns a map
  of multihash ids to blocks."
  [store & {:keys [n max-size], :or {n 10, max-size 1024}}]
  (let [blocks (generate-blocks! n max-size)]
    (block/put-batch! store (vals blocks))
    blocks))

;; ## Generators

(def gen-block
  "Generator which constructs blocks with random content and one of the
  available hashing functions."
  (gen/fmap
    (partial apply block/read!)
    (gen/tuple
      (gen/not-empty (gen/scale (partial * 10) gen/bytes))
      (gen/elements (keys digest/functions)))))

(defn- gen-list-opts
  "Generator for options maps to pass into a block/list call."
  [blocks]
  ; TODO: how to test permutations of these better?
  (let [gen-limit (gen/large-integer* {:min 1, :max (inc (count blocks))})]
    (gen/one-of
      [(gen/hash-map
         :algorithm (gen/elements (keys digest/functions))
         :limit gen-limit)
       (gen/hash-map
         :after (gen/fmap hex/encode (gen/not-empty gen/bytes))
         :limit gen-limit)])))

(defn- gen-store-op
  "Test generator which creates a single operation against the store."
  [blocks]
  (let [gen-op (fn [op-key gen-args] (gen/tuple (gen/return op-key) gen-args))
        gen-block-key (gen/elements (keys blocks))
        gen-block-val (gen/elements (vals blocks))]
    (gen/one-of
      [(gen-op :stat          gen-block-key)
       (gen-op :list          (gen-list-opts blocks))
       (gen-op :get           gen-block-key)
       (gen-op :put!          gen-block-val)
       (gen-op :delete!       gen-block-key)
       (gen-op :get-batch     (gen/not-empty (gen/set gen-block-key)))
       (gen-op :put-batch!    (gen/not-empty (gen/set gen-block-val)))
       (gen-op :delete-batch! (gen/not-empty (gen/set gen-block-key)))])))

;; ## Testing

(defn- apply-op!
  "Applies an operation to the store by using the op keyword to resolve a method
  in the `blocks.core` namespace. Returns the result of calling the method."
  [store [op-key args]]
  (let [var-name (symbol (name op-key))
        method (ns-resolve 'blocks.core var-name)
        form-str (pr-str (list (symbol "blocks" (str var-name)) 'store args))]
    ;(println ">>" form-str)
    (testing form-str
      (method store args))))

(defn- check-stat-result
  [block result]
  (if block
    (testing "stored block"
      (is (map? result))
      (is (= (:id block) (:id result)))
      (is (= (:size block) (:size result)))
      (is (some? (:stored-at result))))
    (testing "missing block"
      (is (nil? result)))))

(defn- check-op
  "Checks that the result of an operation matches the model of the store's
  contents. Returns true if the operation and model match."
  [model [op-key args] result]
  (case op-key
    :stat
      (check-stat-result (get model args) result)

    :list
      (let [{:keys [algorithm after limit]} args
            expected-ids
              (cond->> (keys model)
                after
                  (filter #(pos? (compare (multihash/hex %) after)))
                algorithm
                  (filter #(= algorithm (:algorithm %)))
                true
                  (sort)
                limit
                  (take limit))]
        (is (sequential? result))
        (is (= (count result) (count expected-ids)))
        (is (every?
               (fn [[id act]] (check-stat-result (get model id) act))
               (map vector expected-ids result))
            "all stat results are rturned"))

    :get
      (if-let [block (get model args)]
        (is (= block result))
        (is (nil? result)))

    :put!
      (do (is (= (:id result) (:id args)))
          (is (= (:size result) (:size args))))

    :delete!
      (if (contains? model args)
        (testing "stored block"
          (is (true? result)))
        (testing "missing block"
          (is (false? result))))

    :get-batch
      (let [expected-blocks (keep model args)]
        (is (coll? result))
        (is (= (set expected-blocks) (set result))))

    :put-batch!
      (is (= (set args) (set result)))

    :delete-batch!
      (let [contained-ids (keep (set args) (keys model))]
        (is (= (set contained-ids) result)))))

(defn- update-model
  [model [op-key args]]
  (case op-key
    :put! (assoc model (:id args) args)
    :delete! (dissoc model args)
    :put-batch! (into model (map (juxt :id identity) args))
    :delete-batch! (apply dissoc model args)
    model))

(defn- valid-op-seq?
  "Determines whether the given sequence of operations produces valid results
  when applied to the store."
  [store ops]
  (loop [model {}
         ops ops]
    (if (seq ops)
      (let [op (first ops)
            result (apply-op! store op)]
        (if (check-op model op result)
          (recur (update-model model op)
                 (rest ops))
          (do (println "ERROR: Illegal operation result:"
                       (pr-str op) "->" (pr-str result))
              false)))
      true)))

(defn check-store!
  [constructor & {:keys [blocks max-size iterations eraser]
                  :or {blocks 20, max-size 1024, iterations 100}}]
  {:pre [(some? constructor)]}
  (let [test-blocks (generate-blocks! blocks max-size)]
    (check/quick-check iterations
      (prop/for-all [ops (gen/list (gen-store-op test-blocks))]
        (let [store (constructor)]
          (component/start store)
          (try
            (when-not (empty? (block/list store))
              (throw (IllegalStateException.
                       (str "Cannot run integration test on " (pr-str store)
                            " as it already contains blocks!"))))
            (let [result (valid-op-seq? store ops)]
              (if eraser
                (eraser store)
                (block/delete-batch! store (set (keys test-blocks))))
              (is (empty? (block/list store)) "ends empty")
              result)
            (finally
              (try
                (component/stop store)
                (catch Exception ex
                  (println "Error stopping store:" ex))))))))))

#_
(defn test-put-attributes
  "The put! method in a store should return a block with an updated content or
  reader, but keep the same id, extra attributes, and any non-stat metadata."
  [store]
  (let [original (-> (random-block 512)
                     (assoc :foo "bar")
                     (vary-meta assoc ::thing :baz))
        stored (block/put! store original)]
    (is (= (:id original) (:id stored))
        "Stored block id should match original")
    (is (= (:size original) (:size stored))
        "Stored block size should match original")
    (is (= "bar" (:foo stored))
        "Stored block should retain extra attributes")
    (is (= :baz (::thing (meta stored)))
        "Stored block should retain extra metadata")
    (is (= original stored)
        "Stored block should test equal to original")
    (is (true? (block/delete! store (:id stored))))))

#_
(defn test-block
  "Determines whether the store contains the content for the given identifier."
  [store id content]
  (testing "block stats"
    (let [status (block/stat store id)]
      (is (= id (:id status))
          "should return the same multihash id")
      (is (= (count content) (:size status))
          "should return the content size")))
  (testing "block retrieval"
    (let [block (block/get store id)]
      (is (= id (:id block))
          "stored block has same id")
      (is (= (count content) (:size block))
          "block contains size info")
      (let [baos (java.io.ByteArrayOutputStream.)]
        (with-open [stream (block/open block)]
          (io/copy stream baos))
        (is (= (seq content) (seq (.toByteArray baos)))
            "stored content should match"))
      (is (= [:id :size] (keys block))
          "block only contains id and size"))))

#_
(defmacro ^:private test-section
  [title & body]
  `(do (printf "    * %s\n" ~title)
       (let [start# (System/nanoTime)
             result# (testing ~title
                       ~@body)]
         (printf "        %.3f ms\n"
                 (/ (double (- (System/nanoTime) start#)) 1000000.0))
         result#)))

#_
(defn test-block-store
  "Tests a block store implementation."
  [label store & {:keys [blocks max-size eraser]
                  :or {blocks 10, max-size 1024}}]
  (printf "  Beginning %s integration tests...\n" label)
  (testing (.getSimpleName (class store))
    (let [start-nano (System/nanoTime)
          store (test-section "starting store"
                  (component/start store))]
      (when-not (empty? (block/list store))
        (throw (IllegalStateException.
                 (str "Cannot run integration test on " (pr-str store)
                      " as it already contains blocks!"))))
      (test-section "querying non-existent block"
        (is (nil? (block/stat store (digest/sha1 "foo"))))
        (is (nil? (block/get store (digest/sha1 "bar")))))
      (test-section "ranged open"
        (let [block (block/store! store "012 345 678")]
          (is (= "345" (with-open [subrange (block/open block 4 7)]
                         (slurp subrange)))
              "subrange should return correct bytes")
          (is (true? (block/delete! store (:id block))))))
      (test-section "put attributes"
        (test-put-attributes store))
      (test-section "batch operations"
        (test-batch-ops store))
      (let [stored-content (test-section (str "populating " blocks " blocks")
                             (populate-blocks! store blocks max-size))]
        (test-section "list stats"
          (let [stats (block/list store)]
            (is (= (keys stored-content) (map :id stats))
                "enumerates all ids in sorted order")
            (is (every? #(= (:size %) (count (get stored-content (:id %)))) stats)
                "returns correct size for all blocks"))
          (test-list-stats store (keys stored-content) 10))
        (test-section "stored blocks"
          (doseq [[id content] stored-content]
            (test-block store id content)))
        (test-section "re-storing block"
          (let [[id content] (first (seq stored-content))]
            (test-restore-block store id content)))
        (test-section "erasing store"
          (if eraser
            (eraser store)
            (doseq [id (keys stored-content)]
              (is (true? (block/delete! store id)))))
          (is (empty? (block/list store)) "ends empty")))
      (printf "  Total time: %.3f ms\n"
              (/ (double (- (System/nanoTime) start-nano)) 1000000.0))
      (component/stop store))))

(ns blocks.store.tests
  "Suite of tests to verify that a given block store implementation conforms to
  the spec."
  (:require
    [alphabase.bytes :refer [random-bytes]]
    [alphabase.hex :as hex]
    [blocks.core :as block]
    [blocks.store.util :as util]
    [byte-streams :as bytes :refer [bytes=]]
    [clojure.java.io :as io]
    [clojure.test :refer :all]
    [clojure.test.check :as check]
    [clojure.test.check.generators :as gen]
    [clojure.test.check.properties :as prop]
    [com.stuartsierra.component :as component]
    [multihash.core :as multihash]
    [multihash.digest :as digest])
  (:import
    blocks.data.PersistentBytes))

(defn random-block
  "Creates a new block with random content at most `max-size` bytes long."
  [max-size]
  (block/read!
    (random-bytes (inc (rand-int max-size)))
    (rand-nth (keys digest/functions))))

(defn generate-blocks!
  "Generates some test blocks and returns a map of the ids to the blocks."
  [n max-size]
  (->> (repeatedly #(random-block max-size))
       (take n)
       (map (juxt :id identity))
       (into (sorted-map))))

(defn populate-blocks!
  "Generates random blocks and puts them into the given store. Returns a map
  of multihash ids to blocks."
  [store & {:keys [n max-size], :or {n 10, max-size 1024}}]
  (let [blocks (generate-blocks! n max-size)]
    (block/put-batch! store (vals blocks))
    blocks))

;; ## Generators

(def gen-block
  "Generator which constructs blocks with random content and one of the
  available hashing functions."
  (gen/fmap
    (partial apply block/read!)
    (gen/tuple
      (gen/not-empty (gen/scale (partial * 10) gen/bytes))
      (gen/elements (keys digest/functions)))))

(defn- gen-list-opts
  "Generator for options maps to pass into a block/list call."
  [blocks]
  ; TODO: how to test permutations of these better?
  (let [gen-limit (gen/large-integer* {:min 1, :max (inc (count blocks))})]
    (gen/one-of
      [(gen/hash-map
         :algorithm (gen/elements (keys digest/functions))
         :limit gen-limit)
       (gen/hash-map
         :after (gen/fmap hex/encode (gen/not-empty gen/bytes))
         :limit gen-limit)])))

(defn- gen-store-op
  "Test generator which creates a single operation against the store."
  [blocks]
  (let [gen-op (fn [op-key gen-args] (gen/tuple (gen/return op-key) gen-args))
        gen-block-key (gen/elements (keys blocks))
        gen-block-val (gen/elements (vals blocks))]
    (gen/one-of
      [(gen-op :stat             gen-block-key)
       (gen-op :list             (gen-list-opts blocks))
       (gen-op :get              gen-block-key)
       (gen-op :put!             gen-block-val)
       (gen-op :delete!          gen-block-key)
       (gen-op :get-batch        (gen/not-empty (gen/set gen-block-key)))
       (gen-op :put-batch!       (gen/not-empty (gen/set gen-block-val)))
       (gen-op :delete-batch!    (gen/not-empty (gen/set gen-block-key)))
       (gen-op :open-block       gen-block-key)
       (gen-op :open-block-range (gen/fmap
                                   (fn [[id a b]]
                                     (if (< a b)
                                       [id a b]
                                       [id b a]))
                                   (gen/tuple gen-block-key
                                              gen/nat
                                              gen/nat)))])))

;; ## Testing

(defn- apply-op!
  "Applies an operation to the store by using the op keyword to resolve a method
  in the `blocks.core` namespace. Returns the result of calling the method."
  [store [op-key args]]
  ;(println ">>" op-key (pr-str args))
  (case op-key
    :open-block
      (block/get store args)

    :open-block-range
      (block/get store (first args))

    (let [var-name (symbol (name op-key))
          method (ns-resolve 'blocks.core var-name)]
      (method store args))))

(defn- check-stat-result
  [block result]
  (if block
    (testing "stored block"
      (is (map? result))
      (is (= (:id block) (:id result)))
      (is (= (:size block) (:size result)))
      (is (some? (:stored-at result))))
    (testing "missing block"
      (is (nil? result)))))

(defn- check-op
  "Checks that the result of an operation matches the model of the store's
  contents. Returns true if the operation and model match."
  [model [op-key args] result]
  (case op-key
    :stat
      (check-stat-result (get model args) result)

    :list
      (let [{:keys [algorithm after limit]} args
            expected-ids
              (cond->> (keys model)
                after
                  (filter #(pos? (compare (multihash/hex %) after)))
                algorithm
                  (filter #(= algorithm (:algorithm %)))
                true
                  (sort)
                limit
                  (take limit))]
        (is (sequential? result))
        (is (= (count result) (count expected-ids)))
        (is (every?
               (fn [[id act]] (check-stat-result (get model id) act))
               (map vector expected-ids result))
            "all stat results are rturned"))

    :get
      (if-let [block (get model args)]
        (is (= block result))
        (is (nil? result)))

    :put!
      (do (is (= (:id result) (:id args)))
          (is (= (:size result) (:size args))))

    :delete!
      (if (contains? model args)
        (testing "stored block"
          (is (true? result)))
        (testing "missing block"
          (is (false? result))))

    :get-batch
      (let [expected-blocks (keep model args)]
        (is (coll? result))
        (is (= (set expected-blocks) (set result))))

    :put-batch!
      (is (= (set args) (set result)))

    :delete-batch!
      (let [contained-ids (keep (set args) (keys model))]
        (is (= (set contained-ids) result)))

    :open-block
      (if-let [block (get model args)]
        (is (bytes= (.open (.content block)) (block/open result)))
        (is (nil? result)))

    :open-block-range
      (let [[id start end] args]
        (if-let [block (get model id)]
          (is (bytes= (@#'blocks.core/bounded-input-stream
                        (.open (.content block)) start end)
                      (block/open result
                                  (min start (:size block))
                                  (min end   (:size block)))))
          (is (nil? result))))))

(defn- update-model
  [model [op-key args]]
  (case op-key
    :put! (assoc model (:id args) args)
    :delete! (dissoc model args)
    :put-batch! (into model (map (juxt :id identity) args))
    :delete-batch! (apply dissoc model args)
    model))

(defn- valid-op-seq?
  "Determines whether the given sequence of operations produces valid results
  when applied to the store."
  [store ops]
  (loop [model {}
         ops ops]
    (if (seq ops)
      (let [op (first ops)
            result (apply-op! store op)]
        (if (check-op model op result)
          (recur (update-model model op)
                 (rest ops))
          (do (println "ERROR: Illegal operation result:"
                       (pr-str op) "->" (pr-str result))
              false)))
      true)))

(defn check-store!
  [constructor & {:keys [blocks max-size iterations eraser]
                  :or {blocks 20, max-size 1024, iterations 100}}]
  {:pre [(some? constructor)]}
  (let [test-blocks (generate-blocks! blocks max-size)]
    (check/quick-check iterations
      (prop/for-all [ops (gen/list (gen-store-op test-blocks))]
        (let [store (constructor)]
          (component/start store)
          (try
            (when-not (empty? (block/list store))
              (throw (IllegalStateException.
                       (str "Cannot run integration test on " (pr-str store)
                            " as it already contains blocks!"))))
            (let [result (valid-op-seq? store ops)]
              (if eraser
                (eraser store)
                (block/delete-batch! store (set (keys test-blocks))))
              (is (empty? (block/list store)) "ends empty")
              result)
            (finally
              (try
                (component/stop store)
                (catch Exception ex
                  (println "Error stopping store:" ex))))))))))

#_
(defn test-put-attributes
  "The put! method in a store should return a block with an updated content or
  reader, but keep the same id, extra attributes, and any non-stat metadata."
  [store]
  (let [original (-> (random-block 512)
                     (assoc :foo "bar")
                     (vary-meta assoc ::thing :baz))
        stored (block/put! store original)]
    (is (= (:id original) (:id stored))
        "Stored block id should match original")
    (is (= (:size original) (:size stored))
        "Stored block size should match original")
    (is (= "bar" (:foo stored))
        "Stored block should retain extra attributes")
    (is (= :baz (::thing (meta stored)))
        "Stored block should retain extra metadata")
    (is (= original stored)
        "Stored block should test equal to original")
    (is (true? (block/delete! store (:id stored))))))

#_
(defn test-block
  "Determines whether the store contains the content for the given identifier."
  [store id content]
  (testing "block stats"
    (let [status (block/stat store id)]
      (is (= id (:id status))
          "should return the same multihash id")
      (is (= (count content) (:size status))
          "should return the content size")))
  (testing "block retrieval"
    (let [block (block/get store id)]
      (is (= id (:id block))
          "stored block has same id")
      (is (= (count content) (:size block))
          "block contains size info")
      (let [baos (java.io.ByteArrayOutputStream.)]
        (with-open [stream (block/open block)]
          (io/copy stream baos))
        (is (= (seq content) (seq (.toByteArray baos)))
            "stored content should match"))
      (is (= [:id :size] (keys block))
          "block only contains id and size"))))

#_
(defmacro ^:private test-section
  [title & body]
  `(do (printf "    * %s\n" ~title)
       (let [start# (System/nanoTime)
             result# (testing ~title
                       ~@body)]
         (printf "        %.3f ms\n"
                 (/ (double (- (System/nanoTime) start#)) 1000000.0))
         result#)))

#_
(defn test-block-store
  "Tests a block store implementation."
  [label store & {:keys [blocks max-size eraser]
                  :or {blocks 10, max-size 1024}}]
  (printf "  Beginning %s integration tests...\n" label)
  (testing (.getSimpleName (class store))
    (let [start-nano (System/nanoTime)
          store (test-section "starting store"
                  (component/start store))]
      (when-not (empty? (block/list store))
        (throw (IllegalStateException.
                 (str "Cannot run integration test on " (pr-str store)
                      " as it already contains blocks!"))))
      (test-section "querying non-existent block"
        (is (nil? (block/stat store (digest/sha1 "foo"))))
        (is (nil? (block/get store (digest/sha1 "bar")))))
      (test-section "ranged open"
        (let [block (block/store! store "012 345 678")]
          (is (= "345" (with-open [subrange (block/open block 4 7)]
                         (slurp subrange)))
              "subrange should return correct bytes")
          (is (true? (block/delete! store (:id block))))))
      (test-section "put attributes"
        (test-put-attributes store))
      (test-section "batch operations"
        (test-batch-ops store))
      (let [stored-content (test-section (str "populating " blocks " blocks")
                             (populate-blocks! store blocks max-size))]
        (test-section "list stats"
          (let [stats (block/list store)]
            (is (= (keys stored-content) (map :id stats))
                "enumerates all ids in sorted order")
            (is (every? #(= (:size %) (count (get stored-content (:id %)))) stats)
                "returns correct size for all blocks"))
          (test-list-stats store (keys stored-content) 10))
        (test-section "stored blocks"
          (doseq [[id content] stored-content]
            (test-block store id content)))
        (test-section "re-storing block"
          (let [[id content] (first (seq stored-content))]
            (test-restore-block store id content)))
        (test-section "erasing store"
          (if eraser
            (eraser store)
            (doseq [id (keys stored-content)]
              (is (true? (block/delete! store id)))))
          (is (empty? (block/list store)) "ends empty")))
      (printf "  Total time: %.3f ms\n"
              (/ (double (- (System/nanoTime) start-nano)) 1000000.0))
      (component/stop store))))

Add property tests for opening blocks.

Add property tests for opening blocks.


(ns catalog.validation
  "Validation for catalog data

  Items come from the library system and are converted into clj data
  structures from XML. This tree is then validated."
  (:require [catalog.vubis :as vubis]
            [schema.core :as s]
            [schema.experimental.abstract-map :as abstract-map]))

(def Language
  (apply s/enum (conj (vals vubis/iso-639-2-to-iso-639-1) "und")))

(def Genre
  (apply s/enum (vals vubis/genre-raw-to-genre)))

(def LudoGenre
  (apply s/enum (vals vubis/genre-raw-to-ludo-genre)))

(def SubGenre
  (apply s/enum (vals vubis/genre-raw-to-subgenre)))

(def ProducerBrief
  (apply s/enum (set (vals vubis/producer-raw-to-producer))))

(def BrailleGrade (s/enum :kurzschrift :vollschrift :schwarzschrift))

(def SignatureRE #"(DS |GDB |BG |ED |BM |BK |PS|DY|GD)\d{4,6}|LUD \d{1,3}|BK \d{3}|VI \d{1,3}")

(def SignatureTuple
  [(s/one SignatureRE "signature")
   (s/one (s/maybe BrailleGrade) "grade")
   (s/one (s/maybe s/Int) "volumes")
   (s/one (s/maybe s/Bool) "double-spaced?")
   (s/one (s/maybe s/Str) "accompanying-material")])

(def SignatureKey
  [(s/one (s/maybe BrailleGrade) "grade")
   (s/one s/Bool "double-spaced?")])

(def LibrarySignature
  (s/if map? {SignatureKey [SignatureTuple]} SignatureRE))

(s/defschema CatalogItem
  (abstract-map/abstract-map-schema
   :format
   {:record-id s/Str
    (s/optional-key :creator) s/Str
    :title s/Str
    (s/optional-key :subtitles) [s/Str]
    (s/optional-key :name-of-part) s/Str
    (s/optional-key :source) s/Str
    (s/optional-key :description) s/Str
    :library-signature LibrarySignature
    (s/optional-key :product-number) LibrarySignature
    (s/optional-key :price) s/Str
    (s/optional-key :price-on-request?) s/Bool
    (s/optional-key :language) Language
    }))

(abstract-map/extend-schema
 Hörbuch CatalogItem [:hörbuch]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :duration s/Int
  :narrators [s/Str]
  :produced-commercially? s/Bool})

(abstract-map/extend-schema
 Braille CatalogItem [:braille]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :rucksackbuch? s/Bool
  (s/optional-key :rucksackbuch-number) s/Int})

(abstract-map/extend-schema
 Taktil CatalogItem [:taktilesbuch]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief})

(abstract-map/extend-schema
 Musiknoten CatalogItem [:musiknoten]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre-text s/Str
  (s/optional-key :volumes) s/Int})

(abstract-map/extend-schema
 Grossdruck CatalogItem [:grossdruck]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :volumes s/Int})

(abstract-map/extend-schema
 E-book CatalogItem [:e-book]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str})

(abstract-map/extend-schema
 Hörfilm CatalogItem [:hörfilm]
 {:genre (apply s/enum (vals vubis/genre-code-to-genre))
  :genre-text s/Str
  :producer s/Str
  :directed-by [s/Str]
  :actors [s/Str]
  :personel-text s/Str
  :movie_country s/Str})

(abstract-map/extend-schema
 Spiel CatalogItem [:ludo]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre LudoGenre
  :genre-text s/Str
  (s/optional-key :accompanying-material) s/Str
  :game-description s/Str})

(defn distinct-titles? [items]
  (and (> (count items) 1)
       (->> items
            (map :title)
            (apply distinct?))))

(ns catalog.validation
  "Validation for catalog data

  Items come from the library system and are converted into clj data
  structures from XML. This tree is then validated."
  (:require [catalog.vubis :as vubis]
            [schema.core :as s]
            [schema.experimental.abstract-map :as abstract-map]))

(def Language
  (apply s/enum (conj (vals vubis/iso-639-2-to-iso-639-1) "und")))

(def Genre
  (apply s/enum (vals vubis/genre-raw-to-genre)))

(def LudoGenre
  (apply s/enum (vals vubis/genre-raw-to-ludo-genre)))

(def SubGenre
  (apply s/enum (vals vubis/genre-raw-to-subgenre)))

(def ProducerBrief
  (apply s/enum (set (vals vubis/producer-raw-to-producer))))

(def BrailleGrade (s/enum :kurzschrift :vollschrift :schwarzschrift))

(def SignatureRE #"(DS |GDB |BG |ED |BM |BK |PS|DY|GD)\d{4,6}|LUD \d{1,3}|BK \d{3}|VI \d{1,3}|TB \d{1,3}")

(def SignatureTuple
  [(s/one SignatureRE "signature")
   (s/one (s/maybe BrailleGrade) "grade")
   (s/one (s/maybe s/Int) "volumes")
   (s/one (s/maybe s/Bool) "double-spaced?")
   (s/one (s/maybe s/Str) "accompanying-material")])

(def SignatureKey
  [(s/one (s/maybe BrailleGrade) "grade")
   (s/one s/Bool "double-spaced?")])

(def LibrarySignature
  (s/if map? {SignatureKey [SignatureTuple]} SignatureRE))

(s/defschema CatalogItem
  (abstract-map/abstract-map-schema
   :format
   {:record-id s/Str
    (s/optional-key :creator) s/Str
    :title s/Str
    (s/optional-key :subtitles) [s/Str]
    (s/optional-key :name-of-part) s/Str
    (s/optional-key :source) s/Str
    (s/optional-key :description) s/Str
    :library-signature LibrarySignature
    (s/optional-key :product-number) LibrarySignature
    (s/optional-key :price) s/Str
    (s/optional-key :price-on-request?) s/Bool
    (s/optional-key :language) Language
    }))

(abstract-map/extend-schema
 Hörbuch CatalogItem [:hörbuch]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :duration s/Int
  :narrators [s/Str]
  :produced-commercially? s/Bool})

(abstract-map/extend-schema
 Braille CatalogItem [:braille]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :rucksackbuch? s/Bool
  (s/optional-key :rucksackbuch-number) s/Int})

(abstract-map/extend-schema
 Taktil CatalogItem [:taktilesbuch]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief})

(abstract-map/extend-schema
 Musiknoten CatalogItem [:musiknoten]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre-text s/Str
  (s/optional-key :volumes) s/Int})

(abstract-map/extend-schema
 Grossdruck CatalogItem [:grossdruck]
 {:source-publisher s/Str
  :source-date s/Inst
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str
  :producer-brief ProducerBrief
  :volumes s/Int})

(abstract-map/extend-schema
 E-book CatalogItem [:e-book]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre Genre
  :sub-genre SubGenre
  :genre-text s/Str})

(abstract-map/extend-schema
 Hörfilm CatalogItem [:hörfilm]
 {:genre (apply s/enum (vals vubis/genre-code-to-genre))
  :genre-text s/Str
  :producer s/Str
  :directed-by [s/Str]
  :actors [s/Str]
  :personel-text s/Str
  :movie_country s/Str})

(abstract-map/extend-schema
 Spiel CatalogItem [:ludo]
 {:source-publisher s/Str
  :source-date s/Inst
  :producer-brief ProducerBrief
  :genre LudoGenre
  :genre-text s/Str
  (s/optional-key :accompanying-material) s/Str
  :game-description s/Str})

(defn distinct-titles? [items]
  (and (> (count items) 1)
       (->> items
            (map :title)
            (apply distinct?))))

Allow TB signature

Allow TB signature

for tactile books


(ns chat.server.invite
  (:require [org.httpkit.client :as http]
            [ring.middleware.anti-forgery :refer [*anti-forgery-token*]]
            [taoensso.carmine :as car]
            [clojure.string :as string]
            [taoensso.timbre :as timbre]
            [environ.core :refer [env]]
            [aws.sdk.s3 :as s3])
  (:import java.security.SecureRandom
           javax.crypto.Mac
           javax.crypto.spec.SecretKeySpec
           [org.apache.commons.codec.binary Base64]))

(defn random-nonce
  "url-safe random nonce"
  [size]
  (let [rand-bytes (let [seed (byte-array size)]
                     (.nextBytes (SecureRandom. ) seed)
                     seed)]
    (-> rand-bytes
        Base64/encodeBase64
        String.
        (string/replace "+" "-")
        (string/replace "/" "_")
        (string/replace "=" ""))))

(defn hmac
  [hmac-key data]
  (let [key-bytes (.getBytes hmac-key "UTF-8")
        data-bytes (.getBytes data "UTF-8")
        algo "HmacSHA256"]
    (->>
      (doto (Mac/getInstance algo)
        (.init (SecretKeySpec. key-bytes algo)))
      (#(.doFinal % data-bytes))
      (map (partial format "%02x"))
      (apply str))))

(defn constant-comp
  "Compare two strings in constant time"
  [a b]
  (loop [a a b b match (= (count a) (count b))]
    (if (and (empty? a) (empty? b))
      match
      (recur
        (rest a)
        (rest b)
        (and match (= (first a) (first b)))))))

(defn verify-hmac
  [mac data]
  (constant-comp
    mac
    (hmac (env :hmac-secret) data)))

; same as conf in handler, but w/e
(def redis-conn {:pool {}
                 :spec {:host "127.0.0.1"
                        :port 6379}})

(defmacro wcar* [& body] `(car/wcar redis-conn ~@body))

(defn make-invite-link
  [invite]
  (let [secret-nonce (random-nonce 20)]
    (wcar* (car/set (str (invite :id)) secret-nonce))
    (str (env :site-url)
         "/accept?tok=" secret-nonce
         "&invite=" (invite :id))))

(defn verify-invite-nonce
  "Verify that the given nonce is valid for the invite"
  [invite nonce]
  (if-let [stored-nonce (wcar* (car/get (str (invite :id))))]
    (if (constant-comp stored-nonce nonce)
      (do (wcar* (car/del (str (invite :id))))
          {:success true})
      {:error "Invalid token"})
    (do (timbre/warnf "Expired nonce %s for invite %s" nonce invite)
        {:error "Expired token"})))

(defn invite-message
  [invite]
  (let [accept-link ""]
    {:text (str (invite :inviter-email) " has invited to join the " (invite :group-name)
                " group on chat.leanpixel.com.\n\n"
                "Go to " accept-link " to accept.")
     :html (str ""
                (invite :inviter-email) " has invited to join the " (invite :group-name)
                " group on chat.leanpixel.com."
                "
"
                "Click here to accept."
                "")}))

(defn send-invite
  [invite]
  (http/post "https://api.mailgun.net/v3/chat.leanpixel.com/messages"
             {:basic-auth ["api" (env :mailgun-password)]
              :form-params (merge {:to (invite :invitee-email)}
                                  (invite-message invite))}))

(defn register-page
  [invite token]
  (let [now (.getTime (java.util.Date.))
        form-hmac (hmac (env :hmac-secret)
                        (str now token (invite :id) (invite :invitee-email)))]
    (str "<!DOCTYPE html>"
         ""
         "  "
         "   <title>Register for Chat</title>"
         "   <link href=\"/css/out/chat.css\" rel=\"stylesheet\" type=\"text/css\"></style>"
         "  "
         "  "
         "
Upload an avatar for " (invite :invitee-email) "
"
         "  <form action=\"/register\" method=\"POST\" enctype=\"multipart/form-data\">"
         "    <input type=\"hidden\" name=\"csrf-token\" value=\"" *anti-forgery-token* "\">"
         "    <input type=\"hidden\" name=\"token\" value=\"" token "\">"
         "    <input type=\"hidden\" name=\"invite_id\" value=\"" (invite :id) "\">"
         "    <input type=\"hidden\" name=\"email\" value=\"" (invite :invitee-email) "\">"
         "    <input type=\"hidden\" name=\"now\" value=\"" now "\">"
         "    <input type=\"hidden\" name=\"hmac\" value=\"" form-hmac "\">"
         "    <input type=\"file\" name=\"avatar\" size=\"20\">"
         "    Password: <input type=\"password\" name=\"password\">"
         "    <input type=\"submit\" value=\"Register\")>"
         "  </form>"
         "  "
         "")))

(defn verify-form-hmac
  [params]
  (constant-comp
    (params :hmac)
    (hmac (env :hmac-secret)
          (str (params :now) (params :token) (params :invite_id) (params :email)))))

(defn upload-avatar
  [f]
  ; TODO: resize avatar to something reasonable
  (let [creds {:access-key (env :aws-access-key)
               :secret-key (env :aws-secret-key)}
        ext (case (f :content-type)
              "image/jpeg" "jpg"
              "image/png" "png"
              ; TODO
              (last (string/split (f :filename) #"\.")))
        avatar-filename (str (java.util.UUID/randomUUID) "." ext)]
    (s3/put-object creds "chat.leanpixel.com" (str "avatars/" avatar-filename) (f :tempfile)
                   {:content-type (f :content-type)})
    (s3/update-object-acl creds "chat.leanpixel.com" (str "avatars/" avatar-filename) (s3/grant :all-users :read))
    (str "https://s3.amazonaws.com/chat.leanpixel.com/avatars/" avatar-filename)))

(ns chat.server.invite
  (:require [org.httpkit.client :as http]
            [ring.middleware.anti-forgery :refer [*anti-forgery-token*]]
            [taoensso.carmine :as car]
            [clojure.string :as string]
            [taoensso.timbre :as timbre]
            [environ.core :refer [env]]
            [aws.sdk.s3 :as s3])
  (:import java.security.SecureRandom
           javax.crypto.Mac
           javax.crypto.spec.SecretKeySpec
           [org.apache.commons.codec.binary Base64]))

(defn random-nonce
  "url-safe random nonce"
  [size]
  (let [rand-bytes (let [seed (byte-array size)]
                     (.nextBytes (SecureRandom. ) seed)
                     seed)]
    (-> rand-bytes
        Base64/encodeBase64
        String.
        (string/replace "+" "-")
        (string/replace "/" "_")
        (string/replace "=" ""))))

(defn hmac
  [hmac-key data]
  (let [key-bytes (.getBytes hmac-key "UTF-8")
        data-bytes (.getBytes data "UTF-8")
        algo "HmacSHA256"]
    (->>
      (doto (Mac/getInstance algo)
        (.init (SecretKeySpec. key-bytes algo)))
      (#(.doFinal % data-bytes))
      (map (partial format "%02x"))
      (apply str))))

(defn constant-comp
  "Compare two strings in constant time"
  [a b]
  (loop [a a b b match (= (count a) (count b))]
    (if (and (empty? a) (empty? b))
      match
      (recur
        (rest a)
        (rest b)
        (and match (= (first a) (first b)))))))

(defn verify-hmac
  [mac data]
  (constant-comp
    mac
    (hmac (env :hmac-secret) data)))

; same as conf in handler, but w/e
(def redis-conn {:pool {}
                 :spec {:host "127.0.0.1"
                        :port 6379}})

(defmacro wcar* [& body] `(car/wcar redis-conn ~@body))

(defn make-invite-link
  [invite]
  (let [secret-nonce (random-nonce 20)]
    (wcar* (car/set (str (invite :id)) secret-nonce))
    (str (env :site-url)
         "/accept?tok=" secret-nonce
         "&invite=" (invite :id))))

(defn verify-invite-nonce
  "Verify that the given nonce is valid for the invite"
  [invite nonce]
  (if-let [stored-nonce (wcar* (car/get (str (invite :id))))]
    (if (constant-comp stored-nonce nonce)
      (do (wcar* (car/del (str (invite :id))))
          {:success true})
      {:error "Invalid token"})
    (do (timbre/warnf "Expired nonce %s for invite %s" nonce invite)
        {:error "Expired token"})))

(defn invite-message
  [invite]
  (let [accept-link (make-invite-link invite)]
    {:text (str (invite :inviter-email) " has invited to join the " (invite :group-name)
                " group on chat.leanpixel.com.\n\n"
                "Go to " accept-link " to accept.")
     :html (str ""
                (invite :inviter-email) " has invited to join the " (invite :group-name)
                " group on chat.leanpixel.com."
                "
"
                "Click here to accept."
                "")}))

(defn send-invite
  [invite]
  (http/post "https://api.mailgun.net/v3/chat.leanpixel.com/messages"
             {:basic-auth ["api" (env :mailgun-password)]
              :form-params (merge {:to (invite :invitee-email)
                                   :from "noreply@chat.leanpixel.com"
                                   :subject "Join the conversation"}
                                  (invite-message invite))}))

(defn register-page
  [invite token]
  (let [now (.getTime (java.util.Date.))
        form-hmac (hmac (env :hmac-secret)
                        (str now token (invite :id) (invite :invitee-email)))]
    (str "<!DOCTYPE html>"
         ""
         "  "
         "   <title>Register for Chat</title>"
         "   <link href=\"/css/out/chat.css\" rel=\"stylesheet\" type=\"text/css\"></style>"
         "  "
         "  "
         "
Upload an avatar for " (invite :invitee-email) "
"
         "  <form action=\"/register\" method=\"POST\" enctype=\"multipart/form-data\">"
         "    <input type=\"hidden\" name=\"csrf-token\" value=\"" *anti-forgery-token* "\">"
         "    <input type=\"hidden\" name=\"token\" value=\"" token "\">"
         "    <input type=\"hidden\" name=\"invite_id\" value=\"" (invite :id) "\">"
         "    <input type=\"hidden\" name=\"email\" value=\"" (invite :invitee-email) "\">"
         "    <input type=\"hidden\" name=\"now\" value=\"" now "\">"
         "    <input type=\"hidden\" name=\"hmac\" value=\"" form-hmac "\">"
         "    <input type=\"file\" name=\"avatar\" size=\"20\">"
         "    Password: <input type=\"password\" name=\"password\">"
         "    <input type=\"submit\" value=\"Register\")>"
         "  </form>"
         "  "
         "")))

(defn verify-form-hmac
  [params]
  (constant-comp
    (params :hmac)
    (hmac (env :hmac-secret)
          (str (params :now) (params :token) (params :invite_id) (params :email)))))

(defn upload-avatar
  [f]
  ; TODO: resize avatar to something reasonable
  (let [creds {:access-key (env :aws-access-key)
               :secret-key (env :aws-secret-key)}
        ext (case (f :content-type)
              "image/jpeg" "jpg"
              "image/png" "png"
              ; TODO
              (last (string/split (f :filename) #"\.")))
        avatar-filename (str (java.util.UUID/randomUUID) "." ext)]
    (s3/put-object creds "chat.leanpixel.com" (str "avatars/" avatar-filename) (f :tempfile)
                   {:content-type (f :content-type)})
    (s3/update-object-acl creds "chat.leanpixel.com" (str "avatars/" avatar-filename) (s3/grant :all-users :read))
    (str "https://s3.amazonaws.com/chat.leanpixel.com/avatars/" avatar-filename)))

fix email sending

fix email sending


(ns kmg.domain
  (:require
    [datomic.api :as d]
    )
  (:use carica.core
        clojure.data))

(def db-url (config :db :url))

(defn conn [] (d/connect db-url))
(defn db [] (d/db (conn)))

(defn every-first [v]
  (for [elem v] (first elem)))

(defn users []
  (->> (d/q '[:find ?username
         :where
         [_ :user/name ?username]]
       (db))
      every-first))
;;#((for [user %] (first user)))
;; (users)

;; (every-first #{["user2"] ["user1"]})

(defn sort-by-second
  ([coll] (sort-by-second - coll))
  ([order coll] (sort #(order (compare (last %1) (last %2))) coll)))
;; (sort-by-second + [[1 200] [3 400] [2 300]])

(defn recommendations-completed-by-user-dataset [db user]
  (d/q '[:find ?id ?timestamp
         :in $ ?uid
         :where
         ;;[?uid :user/name ?user]
         [?uid :user/goal ?sid]
         [?id :recommendation/specialization ?sid]
         [?id :recommendation/priority ?priority]
         [?id :recommendation/id ?rid]
         [?fid :feedback/user ?uid]
         [?fid :feedback/recommendation ?id]
         [?fid :feedback/complete true ?tx]
         [?tx :db/txInstant ?timestamp]]
       db [:user/name user]))

(defn recommendations-completed-by-user [db user]
  (->> (recommendations-completed-by-user-dataset db user)
       (sort-by-second -)
       (every-first)))

;; (recommendations-completed-by-user-dataset (db) "user2")
(defn recommendations-for-user [db user]
  (->> (d/q '[:find ?id ?priority
         :in $ ?uid
         :where
         [?uid :user/name ?user]
         [?uid :user/goal ?sid]
         [?id :recommendation/specialization ?sid]
         [?id :recommendation/priority ?priority]
         [?mid :media/id ?media_id]]
       db [:user/name user])
       (sort-by-second)
       (every-first)))

(defn recommendation-ids [db user]
  (let [recs (recommendations-for-user db user)
        completed (set (recommendations-completed-by-user db user))]
    (filter #(not (contains? completed %)) recs)))

;; (recommendation-ids (db) "user1")
;; (recommendation-ids (db) "user2")

(defn media-id-by-recommendation-id [db recommend-id]
  (ffirst (d/q '[:find ?mid
              :in $ ?rid
              :where
              [?rid :recommendation/media ?mid]]
            db recommend-id)))

;;(media-id-by-recommendation-id (db) 17592186045434)

(defn entity [db id]
  (d/touch (d/entity db id)))
;; (entity (db) 17592186045434)
;; (entity (db) 17592186045429)

(defn recommendation-data [db rid]
  {:recommendation (entity db rid) :media (entity db (media-id-by-recommendation-id db rid))})

(defn recommendations [user]
  (let [db (db)
        recommend-ids (take 4 (recommendation-ids db user))]
    (map #(recommendation-data db %) recommend-ids)))

(defn recommendations-completed [user]
  (let [db (db)
        recommend-ids (take 10 (recommendations-completed-by-user db user))]
    (map #(recommendation-data db %) recommend-ids)))

;;(recommendations "user1")
;;(recommendations "user2")

(defn- get-feedback
  [user recommendation]
  (->> (d/q '[:find ?fid
              :in $ ?user ?recommend
              :where
              [?uid :user/name ?user]
              [?rid :recommendation/id ?recommend]
              [?fid :feedback/user ?uid]
              [?fid :feedback/recommendation ?rid]]
            (db) user recommendation)
       ffirst
       (entity (db))))

;; (get-feedback "user1" "spec1_book4")

(defn create-feedback
  [user recommendation]
  [{:feedback/user [:user/name user]
   :feedback/recommendation [:recommendation/id recommendation]
   :feedback/complete true
   :db/id (d/tempid :db.part/user)}])

;; (create-feedback "user1" "spec1_book2")

(defn mark-as-completed [user recommendation]
  (let [db (db)
        feedback (create-feedback user recommendation)]
    @(d/transact (conn) feedback)))

;; (mark-as-completed "user1" "spec1_book4")

(ns kmg.domain
  (:require
    [datomic.api :as d]
    )
  (:use carica.core
        clojure.data))

(def db-url (config :db :url))

(defn conn [] (d/connect db-url))
(defn db [] (d/db (conn)))

(defn every-first [v]
  (for [elem v] (first elem)))

(defn users []
  (->> (d/q '[:find ?username
         :where
         [_ :user/name ?username]]
       (db))
      every-first))
;;#((for [user %] (first user)))
;; (users)

;; (every-first #{["user2"] ["user1"]})

(defn sort-by-second
  ([coll] (sort-by-second - coll))
  ([order coll] (sort #(order (compare (last %1) (last %2))) coll)))
;; (sort-by-second + [[1 200] [3 400] [2 300]])

(defn recommendations-completed-by-user-dataset [db user]
  (d/q '[:find ?id ?timestamp
         :in $ ?uid
         :where
         ;;[?uid :user/name ?user]
         [?uid :user/goal ?sid]
         [?id :recommendation/specialization ?sid]
         [?id :recommendation/priority ?priority]
         [?id :recommendation/id ?rid]
         [?fid :feedback/user ?uid]
         [?fid :feedback/recommendation ?id]
         [?fid :feedback/complete true ?tx]
         [?tx :db/txInstant ?timestamp]]
       db [:user/name user]))

(defn recommendations-completed-by-user [db user]
  (->> (recommendations-completed-by-user-dataset db user)
       (sort-by-second -)
       (every-first)))

;; (recommendations-completed-by-user-dataset (db) "user2")
(defn recommendations-for-user [db user]
  (->> (d/q '[:find ?id ?priority
         :in $ ?uid
         :where
         [?uid :user/name ?user]
         [?uid :user/goal ?sid]
         [?id :recommendation/specialization ?sid]
         [?id :recommendation/priority ?priority]
         [?mid :media/id ?media_id]]
       db [:user/name user])
       (sort-by-second)
       (every-first)))

(defn recommendation-ids [db user]
  (let [recs (recommendations-for-user db user)
        completed (set (recommendations-completed-by-user db user))]
    (filter #(not (contains? completed %)) recs)))

;; (recommendation-ids (db) "user1")
;; (recommendation-ids (db) "user2")

(defn media-id-by-recommendation-id [db recommend-id]
  (ffirst (d/q '[:find ?mid
              :in $ ?rid
              :where
              [?rid :recommendation/media ?mid]]
            db recommend-id)))

;;(media-id-by-recommendation-id (db) 17592186045434)

(defn entity [db id]
  (d/touch (d/entity db id)))
;; (entity (db) 17592186045434)
;; (entity (db) 17592186045429)

(defn recommendation-data [db rid]
  {:recommendation (entity db rid) :media (entity db (media-id-by-recommendation-id db rid))})

(defn with-syncronized-db-do [f]
  @(d/sync (conn))
  (f))

(defn recommendations [user]
  (with-syncronized-db-do
    (fn [] (let [db (db)
                 recommend-ids (take 4 (recommendation-ids db user))]
    (map #(recommendation-data db %) recommend-ids)))))

(defn recommendations-completed [user]
  (with-syncronized-db-do
    (fn [] (let [db (db)
                 recommend-ids (take 10 (recommendations-completed-by-user db user))]
    (map #(recommendation-data db %) recommend-ids)))))

;;(recommendations "user1")
;;(recommendations "user2")

(defn- get-feedback
  [user recommendation]
  (->> (d/q '[:find ?fid
              :in $ ?user ?recommend
              :where
              [?uid :user/name ?user]
              [?rid :recommendation/id ?recommend]
              [?fid :feedback/user ?uid]
              [?fid :feedback/recommendation ?rid]]
            (db) user recommendation)
       ffirst
       (entity (db))))

;; (get-feedback "user1" "spec1_book4")

(defn create-feedback
  [user recommendation]
  [{:feedback/user [:user/name user]
   :feedback/recommendation [:recommendation/id recommendation]
   :feedback/complete true
   :db/id (d/tempid :db.part/user)}])

;; (create-feedback "user1" "spec1_book2")

(defn mark-as-completed [user recommendation]
  (let [db (db)
        feedback (create-feedback user recommendation)]
    @(d/transact (conn) feedback)))

;; (mark-as-completed "user1" "spec1_book4")

Add db/sync to all read operations

Add db/sync to all read operations


(ns salava.core.ui.badge-grid
  (:require [salava.badge.ui.helper :as bh]
            [salava.core.ui.helper :as h :refer [unique-values navigate-to path-for js-navigate-to plugin-fun current-path current-route-path]]
            [salava.core.i18n :as i18n :refer [t]]
            [salava.admin.ui.admintool :refer [admin-gallery-badge]]
            [salava.core.ui.modal :as mo]
            [reagent-modals.modals :as m]
            [salava.admin.ui.helper :refer [admin?]]
            [salava.core.ui.ajax-utils :as ajax]
            [salava.social.ui.follow :refer [follow-badge]]
            [reagent.session :as session]
            #_[salava.metabadge.ui.metabadge :as mb]))

(defn num-days-left [timestamp]
  (int (/ (- timestamp (/ (.now js/Date) 1000)) 86400)))

(defn delete-badge [id state init-data]
  (ajax/DELETE
    (path-for (str "/obpv1/badge/" id))
    {:handler
     (fn []
       (init-data state)
       (navigate-to (str "/badge")))}))

(defn delete-badge-modal [id state init-data]
  [:div#delete-modal
   [:div.modal-header
    [:button {:type "button"
              :class "close"
              :data-dismiss "modal"
              :aria-label "OK"}
     [:span {:aria-hidden "true"
             :dangerouslySetInnerHTML {:__html "×"}}]]]
   [:div.modal-body
    [:div {:class (str "alert alert-warning")}
     (t :badge/Confirmdelete)]]
   [:div.modal-footer
    [:button {:type "button"
              :class "btn btn-primary"
              :data-dismiss "modal"}
     (t :core/Cancel)]
    [:button {:type "button"
              :class "btn btn-warning"
              :data-dismiss "modal"
              :on-click #(delete-badge id state init-data)}
     (t :core/Delete)]]])

(defn badge-grid-element [element-data state badge-type init-data]
  (let [{:keys [id image_file name description visibility expires_on revoked issuer_content_name issuer_content_url recipients badge_id assertion_url meta_badge meta_badge_req endorsement_count user_endorsements_count]} element-data
        expired? (bh/badge-expired? expires_on)
        obf_url (session/get :factory-url)
        metabadge-icon-fn (first (plugin-fun (session/get :plugins) "metabadge" "metabadge_icon"))]
    [:div {:class "media grid-container"}
     (cond
       (= "basic" badge-type) (if (or expired? revoked)
                                [:div {:class (str "media-content " (if expired? "media-expired") (if revoked " media-revoked"))}
                                 (cond
                                   revoked [:div.icons
                                            [:div.lefticon [:i {:class "fa fa-ban"}] (t :badge/Revoked)]
                                            [:a.righticon {:class "righticon revoked" :on-click (fn [] (m/modal! [delete-badge-modal id state init-data]
                                                                                {:size :lg})) :title (t :badge/Delete)} [:i {:class "fa fa-trash"}]]]
                                   expired? [:div.icons
                                             [:div.lefticon [:i {:class "fa fa-history"}] (t :badge/Expired)]
                                             [:a.righticon {:class "righticon expired" :on-click (fn [] (m/modal! [delete-badge-modal id state init-data]
                                                                                {:size :lg})) :title (t :badge/Delete)} [:i {:class "fa fa-trash"}]]])
                                 [:a {:href "#" :on-click #(do (.preventDefault %)(mo/open-modal [:badge :info] {:badge-id id} {:hide (fn [] (init-data state))}))}
                                  (if image_file
                                    [:div.media-left
                                     [:img.badge-img {:src (str "/" image_file)
                                                      :alt name}]])
                                  [:div.media-body
                                   [:div.media-heading
                                    [:p.heading-link name]]
                                   [:div.media-issuer
                                    [:p issuer_content_name]]]
                                  ]]
                                [:div {:class (str "media-content " (if expired? "media-expired") (if revoked " media-revoked"))}
                                 [:a {:href "#" :on-click #(do
                                                             (.preventDefault %)
                                                             (mo/open-modal [:badge :info] {:badge-id id} {
                                                                                :shown (fn [] (.replaceState js/history {} "Badge modal" (path-for (str "/badge?id=" id))))
                                                                                :hidden (fn []
                                                                                (do
                                                                                (if (clojure.string/includes? (str js/window.location.href) (path-for (str "/badge?id=" id)))
                                                                                (.replaceState js/history {} "Badge modal" (path-for "/badge"))
                                                                                (navigate-to (current-route-path)))
                                                                                (init-data state)))
                                                                                }))}
                                  [:div.icons
                                   [:div.visibility-icon.inline
                                    (case visibility
                                      "private" [:i {:class "fa fa-lock"}]
                                      "internal" [:i {:class "fa fa-group"}]
                                      "public" [:i {:class "fa fa-globe"}]
                                      nil)
                                    (if metabadge-icon-fn [:div.pull-right [metabadge-icon-fn id]])
                                    (when (or (pos? user_endorsements_count) (pos? endorsement_count)) [:span.badge-view [:i.fa.fa-handshake-o]])

                                    ]

                                   (if expires_on
                                     [:div.righticon
                                      [:i {:title (str (t :badge/Expiresin) " " (num-days-left expires_on) " " (t :badge/days))
                                           :class "fa fa-hourglass-half"}]])]

                                  (if image_file
                                    [:div.media-left
                                     [:img.badge-img {:src (str "/" image_file)
                                                      :alt name}]])
                                  [:div.media-body

                                   [:div.media-heading
                                    [:p.heading-link name]]
                                   [:div.media-issuer
                                    [:p issuer_content_name]]]
                                  ]])

       (= "profile" badge-type) [:div.media-content
                                 [:a {:href "#" :on-click #(mo/open-modal [:badge :info] {:badge-id id})}
                                  [:div.icons.col-xs-12 {:style {:min-height "15px"}}
                                   [:div.visibility-icon.inline
                                    ;(if metabadge-icon-fn [:div.pull-right [metabadge-icon-fn id]])
                                    (when (or (pos? user_endorsements_count) (pos? endorsement_count)) [:span.badge-view [:i.fa.fa-handshake-o]])

                                    ]]
                                  [:div.media-left
                                   (if image_file  [:img {:src (str "/" image_file) :alt name}])
                                   [:div.media-body
                                    [:div.media-heading name]
                                    [:div.media-issuer [:p issuer_content_name]]]
                                   ]]]

       (= "gallery" badge-type) [:div
                                 [:a {:href "#" :on-click #(mo/open-modal [:gallery :badges] {:badge-id badge_id})
                                      :title name}
                                  [:div.media-content
                                   (if image_file
                                     [:div.media-left
                                      [:img {:src (str "/" image_file)
                                             :alt name}]])
                                   [:div.media-body
                                    [:div.media-heading
                                     [:p.heading-link name]]
                                    [:div.media-issuer
                                     [:p issuer_content_name]]
                                    (if recipients
                                      [:div.media-recipients
                                       recipients " " (if (= recipients 1)
                                                        (t :gallery/recipient)
                                                        (t :gallery/recipients))])
                                    [:div.media-description description]]]]
                                 [:div.media-bottom
                                  [:div {:class "pull-left"}
                                   ]
                                  (admin-gallery-badge badge_id "badges" state init-data)]])]))

(ns salava.core.ui.badge-grid
  (:require [salava.badge.ui.helper :as bh]
            [salava.core.ui.helper :as h :refer [unique-values navigate-to path-for js-navigate-to plugin-fun current-path current-route-path]]
            [salava.core.i18n :as i18n :refer [t]]
            [salava.admin.ui.admintool :refer [admin-gallery-badge]]
            [salava.core.ui.modal :as mo]
            [reagent-modals.modals :as m]
            [salava.admin.ui.helper :refer [admin?]]
            [salava.core.ui.ajax-utils :as ajax]
            [salava.social.ui.follow :refer [follow-badge]]
            [reagent.session :as session]
            #_[salava.metabadge.ui.metabadge :as mb]))

(defn num-days-left [timestamp]
  (int (/ (- timestamp (/ (.now js/Date) 1000)) 86400)))

(defn delete-badge [id state init-data]
  (ajax/DELETE
    (path-for (str "/obpv1/badge/" id))
    {:handler
     (fn []
       (init-data state)
       (navigate-to (str "/badge")))}))

(defn delete-badge-modal [id state init-data]
  [:div#delete-modal
   [:div.modal-header
    [:button {:type "button"
              :class "close"
              :data-dismiss "modal"
              :aria-label "OK"}
     [:span {:aria-hidden "true"
             :dangerouslySetInnerHTML {:__html "×"}}]]]
   [:div.modal-body
    [:div {:class (str "alert alert-warning")}
     (t :badge/Confirmdelete)]]
   [:div.modal-footer
    [:button {:type "button"
              :class "btn btn-primary"
              :data-dismiss "modal"}
     (t :core/Cancel)]
    [:button {:type "button"
              :class "btn btn-warning"
              :data-dismiss "modal"
              :on-click #(delete-badge id state init-data)}
     (t :core/Delete)]]])

(defn badge-grid-element [element-data state badge-type init-data]
  (let [{:keys [id image_file name description visibility expires_on revoked issuer_content_name issuer_content_url recipients badge_id assertion_url meta_badge meta_badge_req endorsement_count user_endorsements_count]} element-data
        expired? (bh/badge-expired? expires_on)
        obf_url (session/get :factory-url)
        metabadge-icon-fn (first (plugin-fun (session/get :plugins) "metabadge" "metabadge_icon"))]
    [:div {:class "media grid-container"}
     (cond
       (= "basic" badge-type) (if (or expired? revoked)
                                [:div {:class (str "media-content " (if expired? "media-expired") (if revoked " media-revoked"))}
                                 (cond
                                   revoked [:div.icons
                                            [:div.lefticon [:i {:class "fa fa-ban"}] (t :badge/Revoked)]
                                            [:a.righticon {:class "righticon revoked" :on-click (fn [] (m/modal! [delete-badge-modal id state init-data]
                                                                                {:size :lg})) :title (t :badge/Delete)} [:i {:class "fa fa-trash"}]]]
                                   expired? [:div.icons
                                             [:div.lefticon [:i {:class "fa fa-history"}] (t :badge/Expired)]
                                             [:a.righticon {:class "righticon expired" :on-click (fn [] (m/modal! [delete-badge-modal id state init-data]
                                                                                {:size :lg})) :title (t :badge/Delete)} [:i {:class "fa fa-trash"}]]])
                                 [:a {:href "#" :on-click #(do (.preventDefault %)(mo/open-modal [:badge :info] {:badge-id id} {:hide (fn [] (init-data state))}))}
                                  (if image_file
                                    [:div.media-left
                                     [:img.badge-img {:src (str "/" image_file)
                                                      :alt name}]])
                                  [:div.media-body
                                   [:div.media-heading
                                    [:p.heading-link name]]
                                   [:div.media-issuer
                                    [:p issuer_content_name]]]
                                  ]]
                                [:div {:class (str "media-content " (if expired? "media-expired") (if revoked " media-revoked"))}
                                 [:a {:href "#" :on-click #(do
                                                             (.preventDefault %)
                                                             (mo/open-modal [:badge :info] {:badge-id id} {:shown (fn [] (.replaceState js/history {} "Badge modal" (path-for (str "/badge?id=" id))))
                                                                                :hidden (fn []
                                                                                (do
                                                                                (if (clojure.string/includes? (str js/window.location.href) (path-for (str "/badge?id=" id)))
                                                                                (.replaceState js/history {} "Badge modal" (path-for "/badge"))
                                                                                (navigate-to (current-route-path)))
                                                                                (init-data state)))
                                                                                }))}
                                  [:div.icons
                                   [:div.visibility-icon.inline
                                    (case visibility
                                      "private" [:i {:class "fa fa-lock"}]
                                      "internal" [:i {:class "fa fa-group"}]
                                      "public" [:i {:class "fa fa-globe"}]
                                      nil)
                                    (if metabadge-icon-fn [:div.pull-right [metabadge-icon-fn id]])
                                    (when (or (pos? user_endorsements_count) (pos? endorsement_count)) [:span.badge-view [:i.fa.fa-handshake-o]])]

                                   (if expires_on
                                     [:div.righticon
                                      [:i {:title (str (t :badge/Expiresin) " " (num-days-left expires_on) " " (t :badge/days))
                                           :class "fa fa-hourglass-half"}]])]

                                  (if image_file
                                    [:div.media-left
                                     [:img.badge-img {:src (str "/" image_file)
                                                      :alt name}]])
                                  [:div.media-body

                                   [:div.media-heading
                                    [:p.heading-link name]]
                                   [:div.media-issuer
                                    [:p issuer_content_name]]]
                                  ]])

       (= "profile" badge-type) [:div
                                 [:a {:href "#" :on-click #(mo/open-modal [:badge :info] {:badge-id id})}
                                 [:div.media-content

                                  [:div.icons.col-xs-12 {:style {:min-height "15px" :padding "0px"}}
                                   [:div.visibility-icon.inline
                                    ;(if metabadge-icon-fn [:div.pull-right [metabadge-icon-fn id]])
                                    (when (or (pos? user_endorsements_count) (pos? endorsement_count)) [:span.badge-view [:i.fa.fa-handshake-o]])

                                    ]]
                                  [:div.media-left
                                   (if image_file  [:img {:src (str "/" image_file) :alt name}])
                                   [:div.media-body
                                    [:div.media-heading name]
                                    [:div.media-issuer [:p issuer_content_name]]]
                                   ]]]]

       (= "gallery" badge-type) [:div
                                 [:a {:href "#" :on-click #(mo/open-modal [:gallery :badges] {:badge-id badge_id})
                                      :title name}
                                  [:div.media-content
                                   (if image_file
                                     [:div.media-left
                                      [:img {:src (str "/" image_file)
                                             :alt name}]])
                                   [:div.media-body
                                    [:div.media-heading
                                     [:p.heading-link name]]
                                    [:div.media-issuer
                                     [:p issuer_content_name]]
                                    (if recipients
                                      [:div.media-recipients
                                       recipients " " (if (= recipients 1)
                                                        (t :gallery/recipient)
                                                        (t :gallery/recipients))])
                                    [:div.media-description description]]]]
                                 [:div.media-bottom
                                  [:div {:class "pull-left"}
                                   ]
                                  (admin-gallery-badge badge_id "badges" state init-data)]])]))

apply small fix to badge grid element

apply small fix to badge grid element


(ns triboard.logic.transition
  (:require
    [cljs.spec :as s :include-macros true]
    [triboard.logic.board :as board]
    [triboard.logic.constants :as cst]
    [triboard.logic.player :as player]
    [triboard.utils.algo :as algo]))

;; -----------------------------------------
;; Public Types
;; -----------------------------------------

(s/def ::destination ::board/coord)
(s/def ::taken (s/coll-of ::board/coord))
(s/def ::winner ::player/player)
(s/def ::looser ::player/playable-cell)
(s/def ::jump (s/keys :req-un [::destination ::taken ::winner ::looser]))
(s/def ::transition (s/every ::jump))
(s/def ::coord->transition (s/map-of ::destination ::transition))
(s/def ::all-transitions (s/map-of ::player/player ::coord->transition))

;; -----------------------------------------
;; Private
;; -----------------------------------------

(defn- ^boolean block-jump?
  [cell]
  (or (= cell :none) (= cell :wall)))

(defn- ^boolean is-source?
  [looser cell]
  (and looser (not= looser cell)))

(defn- ^boolean? in-board?
  [x y]
  (and (< -1 x board/width) (< -1 y board/height)))

(defn- seek-jump-source-toward
  "Starting from the destination of a jump (an empty cell):
   * Search for valid source for the jump
   * Collect the jumped cells along the way"                ;; TODO - Separate this? (could be faster)
  [board [x-init y-init :as destination] [dx dy]]
  (loop [x (+ x-init dx)
         y (+ y-init dy)
         looser nil
         taken []]
    (if (in-board? x y)
      (let [owner (aget board x y)]
        (cond
          (block-jump? owner) nil
          (is-source? looser owner) {:winner owner
                                     :looser looser
                                     :destination destination
                                     :taken taken}
          :else (recur
                  (+ x dx)
                  (+ y dy)
                  owner
                  (conj taken [x y])))
        ))))

(defn- available-jumps-at
  "Provides the list of moves that can be done from a cell"
  [board destination]
  (eduction
    (keep #(seek-jump-source-toward board destination %))
    cst/directions))

(defn- add-destination-jump
  "Create a move to take an empty cell"
  [player destination]
  {:destination destination
   :winner player
   :looser :none
   :taken [destination]})

(defn- apply-jump
  "Apply a move onto the board, yielding a new board"
  [board {:keys [winner taken]}]
  (reduce #(board/convert-cell %1 %2 winner) board taken))

(defn add-destination
  [jumps]
  (if-let [{:keys [winner destination]} (first jumps)]
    (conj jumps (add-destination-jump winner destination))
    jumps))

(defn- map-transition-tree
  [xf game-tree]
  (algo/map-values #(algo/map-values xf %) game-tree))

;; -----------------------------------------
;; Public API
;; -----------------------------------------

(s/fdef available-transitions
  :args (s/tuple ::board/board)
  :ret ::all-transitions)

(defn all-transitions
  [board]
  (let [aboard (board/board->array board)]
    (map-transition-tree
      add-destination
      (transduce
        (mapcat #(available-jumps-at aboard %))
        (algo/group-by-reducer :winner :destination)
        (board/empty-cells board)))))

(defn apply-transition
  [board transition]
  (reduce apply-jump board transition))

;; -----------------------------------------
;; TESTS
;; -----------------------------------------

(defonce benchmark-board (board/new-board))

(defn benchmark
  []
  (let [b benchmark-board
        t (all-transitions b)]
    (time (dotimes [i 100] (all-transitions b)))
    ;; TODO - 12300 turns in loop (55 ms for a transduce) => need better algo
    ;; The add-destination removal makes us gain around 50 ms
    ;; Getting rid of the systematic conj wins about 10 ms
    ;; One dimentional arrow could gain us only 2-3 ms
    ;; empty-cells is super slow: 36 ms.
    (time (dotimes [i 100]
            (doall
              (map
                #(apply-transition b (second %))
                (mapcat #(get t %) [:blue :red :green])
                ))
            ))
    ))

(ns triboard.logic.transition
  (:require
    [cljs.spec :as s :include-macros true]
    [triboard.logic.board :as board]
    [triboard.logic.constants :as cst]
    [triboard.logic.player :as player]
    [triboard.utils.algo :as algo]))

;; -----------------------------------------
;; Public Types
;; -----------------------------------------

(s/def ::destination ::board/coord)
(s/def ::taken (s/coll-of ::board/coord))
(s/def ::winner ::player/player)
(s/def ::looser ::player/playable-cell)
(s/def ::jump (s/keys :req-un [::destination ::taken ::winner ::looser]))
(s/def ::transition (s/every ::jump))
(s/def ::coord->transition (s/map-of ::destination ::transition))
(s/def ::all-transitions (s/map-of ::player/player ::coord->transition))

;; -----------------------------------------
;; Private
;; -----------------------------------------

(defn- ^boolean block-jump?
  [cell]
  (or (= cell :none) (= cell :wall)))

(defn- ^boolean is-source?
  [looser cell]
  (and looser (not= looser cell)))

(defn- ^boolean? in-board?
  [x y]
  (and (< -1 x board/width) (< -1 y board/height)))

(defn- seek-jump-source-toward
  "Starting from the destination of a jump (an empty cell):
   * Search for valid source for the jump
   * Collect the jumped cells along the way"                ;; TODO - Separate this? (could be faster)
  [board [x-init y-init :as destination] [dx dy]]
  (loop [x (+ x-init dx)
         y (+ y-init dy)
         looser nil
         taken []]
    (if (in-board? x y)
      (let [owner (aget board x y)]
        (cond
          (block-jump? owner) nil
          (is-source? looser owner) {:winner owner
                                     :looser looser
                                     :destination destination
                                     :taken taken}
          :else (recur
                  (+ x dx)
                  (+ y dy)
                  owner
                  (conj taken [x y])))
        ))))

(defn- available-jumps-at
  "Provides the list of moves that can be done from a cell"
  [board destination]
  (eduction
    (keep #(seek-jump-source-toward board destination %))
    cst/directions))

(defn- add-destination-jump
  "Create a move to take an empty cell"
  [player destination]
  {:destination destination
   :winner player
   :looser :none
   :taken [destination]})

(defn- apply-jump
  "Apply a move onto the board, yielding a new board"
  [board {:keys [winner taken]}]
  (reduce #(board/convert-cell %1 %2 winner) board taken))

(defn add-destination
  [jumps]
  (if-let [{:keys [winner destination]} (first jumps)]
    (conj jumps (add-destination-jump winner destination))
    jumps))

(defn- map-transition-tree
  [xf game-tree]
  (algo/map-values #(algo/map-values xf %) game-tree))

;; -----------------------------------------
;; Public API
;; -----------------------------------------

(s/fdef all-transitions
  :args (s/cat :board ::board/board)
  :ret ::all-transitions)

(defn all-transitions
  [board]
  (let [aboard (board/board->array board)]
    (map-transition-tree
      add-destination
      (transduce
        (mapcat #(available-jumps-at aboard %))
        (algo/group-by-reducer :winner :destination)
        (board/empty-cells board)))))

(defn apply-transition
  [board transition]
  (reduce apply-jump board transition))

;; -----------------------------------------
;; TESTS
;; -----------------------------------------

(defonce benchmark-board (board/new-board))

(defn benchmark
  []
  (let [b benchmark-board
        t (all-transitions b)]
    (time (dotimes [i 100] (all-transitions b)))
    ;; TODO - 12300 turns in loop (55 ms for a transduce) => need better algo
    ;; The add-destination removal makes us gain around 50 ms
    ;; Getting rid of the systematic conj wins about 10 ms
    ;; One dimentional arrow could gain us only 2-3 ms
    ;; empty-cells is super slow: 36 ms.
    (time (dotimes [i 100]
            (doall
              (map
                #(apply-transition b (second %))
                (mapcat #(get t %) [:blue :red :green])
                ))
            ))
    ))

fix spec

fix spec