;; Copyright (c) Daniel Borchmann. All rights reserved.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file LICENSE at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.

(ns conexp.fca.implications
  (:use conexp.base
        conexp.fca.contexts)
  (:import [java.util HashMap HashSet]))

(ns-doc "Implications for Formal Concept Analysis")

;;;

(deftype Implication [premise conclusion]
  Object
  (equals [this other]
    (generic-equals [this other] Implication [premise conclusion]))
  (hashCode [this]
    (hash-combine-hash Implication premise conclusion)))

(defmulti premise
  "Returns premise of given object."
  {:arglists '([thing])}
  type)

(defmethod premise Implication [^Implication impl]
  (.premise impl))

(defmulti conclusion
  "Returns conclusion of given object."
  {:arglists '([thing])}
  type)

(defmethod conclusion Implication [^Implication impl]
  (.conclusion impl))

(defmethod print-method Implication
  [impl out]
  (.write ^java.io.Writer out
          ^String (str "(" (premise impl) "  ==>  " (conclusion impl) ")")))

;;;

(defn make-implication
  "Creates an implication (premise => conclusion \\ premise)."
  [premise conclusion]
  (let [premise (set premise)
        conclusion (set conclusion)]
    (Implication. premise (difference conclusion premise))))

;;;

(defn respects?
  "Returns true iff set respects given implication impl."
  [set impl]
  (or (not (subset? (premise impl) set))
      (subset? (conclusion impl) set)))

(defn holds?
  "Returns true iff impl holds in given context ctx."
  [impl ctx]
  (forall [intent (intents ctx)]
    (respects? intent impl)))

(defn- add-immediate-elements
  "Adds all elements which follow from implications with premises in
  initial-set. Uses subset-test to dertermine whether a given
  implication can be used to extend a given set, i.e. an implication
  impl can be used to extend a set s if and only if

    (and (subset-test (premise impl) s)
         (not (subset? (conclusion impl) s)))

  is true."
  [implications initial-set subset-test]
  (loop [conclusions  [],
         impls        implications,
         unused-impls []]
    (if (empty? impls)
      [(apply union initial-set conclusions) unused-impls]
      (let [impl (first impls)]
        (if (and (subset-test (premise impl) initial-set)
                 (not (subset? (conclusion impl) initial-set)))
          (recur (conj conclusions (conclusion impl))
                 (rest impls)
                 unused-impls)
          (recur conclusions
                 (rest impls)
                 (conj unused-impls impl)))))))

(defn close-under-implications
  "Computes smallest superset of set being closed under given implications."
  [implications set]
  (assert (set? set))
  (loop [set   set,
         impls implications]
    (let [[new impls] (add-immediate-elements impls set subset?)]
      (if (= new set)
        new
        (recur new impls)))))

(defn clop-by-implications
  "Returns closure operator given by implications."
  [implications]
  (partial close-under-implications implications))

(defn pseudo-close-under-implications
  "Computes smallest superset of set being pseudo-closed under given
  implications."
  [implications set]
  (assert (set? set))
  (loop [set   set,
         impls implications]
    (let [[new impls] (add-immediate-elements impls set proper-subset?)]
      (if (= new set)
        new
        (recur new impls)))))

(defn pseudo-clop-by-implications
  "Returns for a given set of implications the corresponding closure
  operator whose closures are all closed and pseudo-closed sets."
  [implications]
  (partial pseudo-close-under-implications implications))

(defn follows-semantically?
  "Returns true iff implication follows semantically from given
  implications."
  [implication implications]
  (subset? (conclusion implication)
           (close-under-implications implications (premise implication))))

(defn equivalent-implications?
  "Returns true iff the two seqs of implications are equivalent."
  [impls-1 impls-2]
  (and (forall [impl impls-1] (follows-semantically? impl impls-2))
       (forall [impl impls-2] (follows-semantically? impl impls-1))))

(defn minimal-implication-set?
  "Checks whether given set of implications is minimal, i.e. no
  implication in this set follows from the others."
  [impl-set]
  (let [impl-set (set impl-set)]
    (forall [impl impl-set]
      (not (follows-semantically? impl (disj impl-set impl))))))

(defn sound-implication-set?
  "Checks whether given set of implications is sound, i.e. every
  implication holds in the given context."
  [ctx impl-set]
  (forall [impl impl-set]
    (holds? impl ctx)))

(defn complete-implication-set?
  "Checks wheter given set of implications is complete in context
  ctx."
  [ctx impl-set]
  (and (forall [impl impl-set]
         (and (subset? (premise impl) (attributes ctx))
              (subset? (conclusion impl) (attributes ctx))))
       (forall [A (subsets (attributes ctx))]
         (=> (forall [impl impl-set] (respects? A impl))
             (= A (context-attribute-closure ctx A))))))

;; Stem Base

(defn stem-base
  "Returns stem base of given context. Uses background-knowledge as
  starting set of implications, which will also be subtracted from the
  final result."
  ([ctx]
     (stem-base ctx #{}))
  ([ctx background-knowledge]
     (loop [implications background-knowledge,
            last         #{}]
       (let [conclusion-from-last (context-attribute-closure ctx last),
             implications         (if (not= last conclusion-from-last)
                                    (conj implications
                                          (make-implication last conclusion-from-last))
                                    implications),
             next                 (next-closed-set (attributes ctx)
                                                   (clop-by-implications implications)
                                                   last)]
         (if next
           (recur implications next)
           (difference implications background-knowledge))))))

(defn pseudo-intents
  "Returns the pseudo intents of the given context ctx."
  [ctx]
  (map premise (stem-base ctx)))

;;; Proper Premises

(defn- A-dot
  "Returns A-dot as in the definition of proper premises."
  [ctx A]
  (difference (context-attribute-closure ctx A)
              (reduce into
                      A
                      (map #(context-attribute-closure ctx (disj A %))
                           A))))

(defn proper-premise?
  "Returns true iff set A is a subset of the attributes of context ctx
  and is a proper premise in ctx."
  [ctx A]
  (and (subset? A (attributes ctx))
       (not (empty? (A-dot ctx A)))))

(defn- intersection-set?
  "Tests whether set has non-empty intersection with every set in sets."
  [set sets]
  (boolean
   (forall [other-set sets]
     (exists [x set]
       (contains? other-set x)))))

(defn- minimal-intersection-sets
  "Returns for a sequence set-sqn of sets all subsets of base-set which have non-empty intersection
  with all sets in set-sqn and are minimal with this property."
  [base-set set-sqn]
  (let [elements (seq base-set),
        result   (atom []),
        search   (fn search [rest-sets current rest-elements]
                   (cond
                    (exists [x current]
                      (intersection-set? (disj current x) set-sqn))
                    nil,
                    (intersection-set? current set-sqn)
                    (swap! result conj current),
                    :else
                    (when-let [x (first rest-elements)]
                      (when (exists [set rest-sets]
                              (contains? set x))
                        (search (remove #(contains? % x) rest-sets)
                                (conj current x)
                                (rest rest-elements)))
                      (search rest-sets
                              current
                              (rest rest-elements)))))]
    (search set-sqn #{} elements)
    @result))

(defn- proper-premises-for-attribute
  "Technical Helper. Returns in context ctx for the attribute m and the objects in objs,
  which must contain all objects g in ctx such that [g m] are in the downarrow relation, the proper
  premises for m."
  [ctx [m objs]]
  (minimal-intersection-sets (disj (attributes ctx) m)
                             (set-of (difference (attributes ctx) (oprime ctx #{g})) | g objs)))

(defn proper-premises
  "Returns the proper premises of the given context ctx as a lazy sequence."
  [ctx]
  (let [down-arrow-map (loop [arrows    (down-arrows ctx),
                              arrow-map {}]
                         (if-let [[g m] (first arrows)]
                           (recur (rest arrows)
                                  (update-in arrow-map [m] conj g))
                           arrow-map))]
    (distinct
     (mapcat #(proper-premises-for-attribute ctx %) down-arrow-map))))

(defn proper-premise-implications
  "Returns all implications based on the proper premises of the
  context ctx."
  [ctx]
  (set-of (make-implication A (context-attribute-closure ctx A))
          [A (proper-premises ctx)]))

;;;

(defn stem-base-from-base
  "For a given set of implications returns its stem-base."
  [implications]
  (loop [stem-base    #{},
         implications (map #(make-implication (premise %)
                                              (close-under-implications implications
                                                                        (union (premise %)
                                                                               (conclusion %))))
                           implications)]
    (if (empty? implications)
      stem-base
      (let [A->B         (first implications),
            implications (rest implications),
            A*           (close-under-implications (into stem-base implications)
                                                   (premise A->B)),
            new-impl     (make-implication A* (conclusion A->B))]
        (recur (if (not-empty (conclusion new-impl))
                 (conj stem-base
                       (make-implication A* (conclusion A->B)))
                 stem-base)
               implications)))))

;;;

nil

;; Copyright (c) Daniel Borchmann. All rights reserved.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file LICENSE at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.

(ns conexp.fca.implications
  (:use conexp.base
        conexp.fca.contexts)
  (:import [java.util HashMap HashSet]))

(ns-doc "Implications for Formal Concept Analysis")

;;;

(deftype Implication [premise conclusion]
  Object
  (equals [this other]
    (generic-equals [this other] Implication [premise conclusion]))
  (hashCode [this]
    (hash-combine-hash Implication premise conclusion)))

(defmulti premise
  "Returns premise of given object."
  {:arglists '([thing])}
  type)

(defmethod premise Implication [^Implication impl]
  (.premise impl))

(defmulti conclusion
  "Returns conclusion of given object."
  {:arglists '([thing])}
  type)

(defmethod conclusion Implication [^Implication impl]
  (.conclusion impl))

(defmethod print-method Implication
  [impl out]
  (.write ^java.io.Writer out
          ^String (str "(" (premise impl) "  ==>  " (conclusion impl) ")")))

;;;

(defn make-implication
  "Creates an implication (premise => conclusion \\ premise)."
  [premise conclusion]
  (let [premise (set premise)
        conclusion (set conclusion)]
    (Implication. premise (difference conclusion premise))))

;;;

(defn respects?
  "Returns true iff set respects given implication impl."
  [set impl]
  (or (not (subset? (premise impl) set))
      (subset? (conclusion impl) set)))

(defn holds?
  "Returns true iff impl holds in given context ctx."
  [impl ctx]
  (forall [intent (intents ctx)]
    (respects? intent impl)))

(defn- add-immediate-elements
  "Adds all elements which follow from implications with premises in
  initial-set. Uses subset-test to dertermine whether a given
  implication can be used to extend a given set, i.e. an implication
  impl can be used to extend a set s if and only if

    (and (subset-test (premise impl) s)
         (not (subset? (conclusion impl) s)))

  is true."
  [implications initial-set subset-test]
  (loop [conclusions  [],
         impls        implications,
         unused-impls []]
    (if (empty? impls)
      [(apply union initial-set conclusions) unused-impls]
      (let [impl (first impls)]
        (if (and (subset-test (premise impl) initial-set)
                 (not (subset? (conclusion impl) initial-set)))
          (recur (conj conclusions (conclusion impl))
                 (rest impls)
                 unused-impls)
          (recur conclusions
                 (rest impls)
                 (conj unused-impls impl)))))))

(defn close-under-implications
  "Computes smallest superset of set being closed under given implications."
  [implications set]
  (assert (set? set))
  (loop [set   set,
         impls implications]
    (let [[new impls] (add-immediate-elements impls set subset?)]
      (if (= new set)
        new
        (recur new impls)))))

(defn clop-by-implications
  "Returns closure operator given by implications."
  [implications]
  (partial close-under-implications implications))

(defn pseudo-close-under-implications
  "Computes smallest superset of set being pseudo-closed under given
  implications."
  [implications set]
  (assert (set? set))
  (loop [set   set,
         impls implications]
    (let [[new impls] (add-immediate-elements impls set proper-subset?)]
      (if (= new set)
        new
        (recur new impls)))))

(defn pseudo-clop-by-implications
  "Returns for a given set of implications the corresponding closure
  operator whose closures are all closed and pseudo-closed sets."
  [implications]
  (partial pseudo-close-under-implications implications))

(defn follows-semantically?
  "Returns true iff implication follows semantically from given
  implications."
  [implication implications]
  (subset? (conclusion implication)
           (close-under-implications implications (premise implication))))

(defn equivalent-implications?
  "Returns true iff the two seqs of implications are equivalent."
  [impls-1 impls-2]
  (and (forall [impl impls-1] (follows-semantically? impl impls-2))
       (forall [impl impls-2] (follows-semantically? impl impls-1))))

(defn minimal-implication-set?
  "Checks whether given set of implications is minimal, i.e. no
  implication in this set follows from the others."
  [impl-set]
  (let [impl-set (set impl-set)]
    (forall [impl impl-set]
      (not (follows-semantically? impl (disj impl-set impl))))))

(defn sound-implication-set?
  "Checks whether given set of implications is sound, i.e. every
  implication holds in the given context."
  [ctx impl-set]
  (forall [impl impl-set]
    (holds? impl ctx)))

(defn complete-implication-set?
  "Checks wheter given set of implications is complete in context
  ctx."
  [ctx impl-set]
  (and (forall [impl impl-set]
         (and (subset? (premise impl) (attributes ctx))
              (subset? (conclusion impl) (attributes ctx))))
       (forall [A (subsets (attributes ctx))]
         (=> (forall [impl impl-set] (respects? A impl))
             (= A (context-attribute-closure ctx A))))))

;; Stem Base

(defn stem-base
  "Returns stem base of given context. Uses background-knowledge as
  starting set of implications, which will also be subtracted from the
  final result."
  ([ctx]
     (stem-base ctx #{}))
  ([ctx background-knowledge]
     (loop [implications background-knowledge,
            last         #{}]
       (let [conclusion-from-last (context-attribute-closure ctx last),
             implications         (if (not= last conclusion-from-last)
                                    (conj implications
                                          (make-implication last conclusion-from-last))
                                    implications),
             next                 (next-closed-set (attributes ctx)
                                                   (clop-by-implications implications)
                                                   last)]
         (if next
           (recur implications next)
           (difference implications background-knowledge))))))

(defn pseudo-intents
  "Returns the pseudo intents of the given context ctx."
  [ctx]
  (map premise (stem-base ctx)))

;;; Proper Premises

(defn- A-dot
  "Returns A-dot as in the definition of proper premises."
  [ctx A]
  (difference (context-attribute-closure ctx A)
              (reduce into
                      A
                      (map #(context-attribute-closure ctx (disj A %))
                           A))))

(defn proper-premise?
  "Returns true iff set A is a subset of the attributes of context ctx
  and is a proper premise in ctx."
  [ctx A]
  (and (subset? A (attributes ctx))
       (not (empty? (A-dot ctx A)))))

(defn- intersection-set?
  "Tests whether set has non-empty intersection with every set in sets."
  [set sets]
  (boolean
   (forall [other-set sets]
     (exists [x set]
       (contains? other-set x)))))

(defn- minimal-intersection-sets
  "Returns for a sequence set-sqn of sets all subsets of base-set which have non-empty intersection
  with all sets in set-sqn and are minimal with this property."
  [base-set set-sqn]
  (let [elements (seq base-set),
        result   (atom []),
        search   (fn search [rest-sets current rest-elements]
                   (cond
                    (exists [x current]
                      (intersection-set? (disj current x) set-sqn))
                    nil,
                    (intersection-set? current set-sqn)
                    (swap! result conj current),
                    :else
                    (when-let [x (first rest-elements)]
                      (when (exists [set rest-sets]
                              (contains? set x))
                        (search (remove #(contains? % x) rest-sets)
                                (conj current x)
                                (rest rest-elements)))
                      (search rest-sets
                              current
                              (rest rest-elements)))))]
    (search set-sqn #{} elements)
    @result))

(defn- proper-premises-for-attribute
  "Technical Helper. Returns in context ctx for the attribute m and the objects in objs,
  which must contain all objects g in ctx such that [g m] are in the downarrow relation, the proper
  premises for m."
  [ctx [m objs]]
  (minimal-intersection-sets (disj (attributes ctx) m)
                             (set-of (difference (attributes ctx) (oprime ctx #{g})) | g objs)))

(defn proper-premises
  "Returns the proper premises of the given context ctx as a lazy sequence."
  [ctx]
  (let [down-arrow-map (loop [arrows    (down-arrows ctx),
                              arrow-map (map-by-fn (constantly #{}) (attributes ctx))]
                         (if-let [[g m] (first arrows)]
                           (recur (rest arrows)
                                  (update-in arrow-map [m] conj g))
                           arrow-map))]
    (distinct
     (mapcat #(proper-premises-for-attribute ctx %) down-arrow-map))))

(defn proper-premise-implications
  "Returns all implications based on the proper premises of the
  context ctx."
  [ctx]
  (set-of (make-implication A (context-attribute-closure ctx A))
          [A (proper-premises ctx)]))

;;;

(defn stem-base-from-base
  "For a given set of implications returns its stem-base."
  [implications]
  (loop [stem-base    #{},
         implications (map #(make-implication (premise %)
                                              (close-under-implications implications
                                                                        (union (premise %)
                                                                               (conclusion %))))
                           implications)]
    (if (empty? implications)
      stem-base
      (let [A->B         (first implications),
            implications (rest implications),
            A*           (close-under-implications (into stem-base implications)
                                                   (premise A->B)),
            new-impl     (make-implication A* (conclusion A->B))]
        (recur (if (not-empty (conclusion new-impl))
                 (conj stem-base
                       (make-implication A* (conclusion A->B)))
                 stem-base)
               implications)))))

;;;

nil

Fix bug in computing proper premises

Fix bug in computing proper premises

Signed-off-by: Daniel Borchmann <25857343a15bf1edafebc2912e82ecf775c585c1@mailbox.tu-dresden.de>


(ns ^:no-doc onyx.messaging.http-kit
    (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout close!]]
              [com.stuartsierra.component :as component]
              [org.httpkit.server :as server]
              [org.httpkit.client :as client]
              [taoensso.timbre :as timbre]
              [taoensso.nippy :as nippy]
              [onyx.messaging.acking-daemon :as acker]
              [onyx.extensions :as extensions])
    (:import [java.nio ByteBuffer]))

(def send-route "/send")

(def acker-route "/ack")

(def completion-route "/completion")

(defn app [daemon inbound-ch release-ch request]
  (let [thawed (nippy/thaw (.bytes (:body request)))
        uri (:uri request)]
    (cond (= uri send-route)
          (doseq [message thawed]
            (>!! inbound-ch message))

          (= uri acker-route)
          (acker/ack-message daemon
                             (:id thawed)
                             (:completion-id thawed)
                             (:ack-val thawed))

          (= uri completion-route)
          (>!! release-ch (:id thawed)))
    {:status 200
     :headers {"Content-Type" "text/plain"}}))

(defrecord HttpKit [opts]
  component/Lifecycle

  (start [component]
    (taoensso.timbre/info "Starting HTTP Kit")

    (let [ch (:inbound-ch (:messenger-buffer component))
          release-ch (chan (clojure.core.async/dropping-buffer 100000))
          daemon (:acking-daemon component)
          ip "0.0.0.0"
          server (server/run-server (partial app daemon ch release-ch) {:ip ip :port 0 :thread 1 :queue-size 100000})]
      (assoc component :server server :ip ip :port (:local-port (meta server)) :release-ch release-ch)))

  (stop [component]
    (taoensso.timbre/info "Stopping HTTP Kit")

    (close! (:release-ch component))
    ((:server component))
    (assoc component :release-ch nil)))

(defn http-kit [opts]
  (map->HttpKit {:opts opts}))

(defmethod extensions/peer-site HttpKit
  [messenger]
  {:url (format "http://%s:%s" (:ip messenger) (:port messenger))})

(defmethod extensions/receive-messages HttpKit
  [messenger {:keys [onyx.core/task-map] :as event}]
  (let [ms (or (:onyx/batch-timeout task-map) 1000)
        ch (:inbound-ch (:onyx.core/messenger-buffer event))]
    (filter
     identity
     (map (fn [_] (first (alts!! [ch (timeout ms)])))
          (range (:onyx/batch-size task-map))))))

(defmethod extensions/send-messages HttpKit
  [messenger event peer-site]
  (let [messages (:onyx.core/compressed event)
        url (:url peer-site)
        route (format "%s%s" url send-route)
        compressed-batch (nippy/freeze messages)]
    (client/post route {:body (ByteBuffer/wrap compressed-batch)}))
  {})

(defmethod extensions/internal-ack-message HttpKit
  [messenger event message-id acker-id completion-id ack-val]
  (let [replica @(:onyx.core/replica event)
        url (:url (get-in replica [:peer-site acker-id]))
        route (format "%s%s" url acker-route)
        contents (nippy/freeze {:id message-id :completion-id completion-id :ack-val ack-val})]
    (client/post route {:body (ByteBuffer/wrap contents)})))

(defmethod extensions/internal-complete-message HttpKit
  [messenger id peer-id replica]
  (let [snapshot @replica
        url (:url (get-in snapshot [:peer-site peer-id]))
        route (format "%s%s" url completion-route)
        contents (nippy/freeze {:id id})]
    (client/post route {:body (ByteBuffer/wrap contents)})))

(ns ^:no-doc onyx.messaging.http-kit
    (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout close!]]
              [com.stuartsierra.component :as component]
              [org.httpkit.server :as server]
              [org.httpkit.client :as client]
              [taoensso.timbre :as timbre]
              [taoensso.nippy :as nippy]
              [onyx.messaging.acking-daemon :as acker]
              [onyx.extensions :as extensions])
    (:import [java.nio ByteBuffer]))

(def send-route "/send")

(def acker-route "/ack")

(def completion-route "/completion")

(defn app [daemon inbound-ch release-ch request]
  (let [thawed (nippy/thaw (.bytes (:body request)))
        uri (:uri request)]
    (cond (= uri send-route)
          (doseq [message thawed]
            (>!! inbound-ch message))

          (= uri acker-route)
          (acker/ack-message daemon
                             (:id thawed)
                             (:completion-id thawed)
                             (:ack-val thawed))

          (= uri completion-route)
          (>!! release-ch (:id thawed)))
    {:status 200
     :headers {"Content-Type" "text/plain"}}))

(defrecord HttpKit [opts]
  component/Lifecycle

  (start [component]
    (taoensso.timbre/info "Starting HTTP Kit")

    (let [ch (:inbound-ch (:messenger-buffer component))
          release-ch (chan (clojure.core.async/dropping-buffer 100000))
          daemon (:acking-daemon component)
          ip "0.0.0.0"
          server (server/run-server (partial app daemon ch release-ch) {:ip ip :port 0 :thread 1 :queue-size 100000})]
      (assoc component :server server :ip ip :port (:local-port (meta server)) :release-ch release-ch)))

  (stop [component]
    (taoensso.timbre/info "Stopping HTTP Kit")

    (close! (:release-ch component))
    ((:server component))
    (assoc component :release-ch nil)))

(defn http-kit [opts]
  (map->HttpKit {:opts opts}))

(defmethod extensions/peer-site HttpKit
  [messenger]
  {:url (format "http://%s:%s" (:ip messenger) (:port messenger))})

(defmethod extensions/receive-messages HttpKit
  [messenger {:keys [onyx.core/task-map] :as event}]
  (let [ms (or (:onyx/batch-timeout task-map) 1000)
        ch (:inbound-ch (:onyx.core/messenger-buffer event))]
    (repeatedly (:onyx/batch-size task-map) #(<!! ch))
    #_(filter
     identity
     (map (fn [_] (first (alts!! [ch (timeout ms)])))
          (range (:onyx/batch-size task-map))))))

(defmethod extensions/send-messages HttpKit
  [messenger event peer-site]
  (let [messages (:onyx.core/compressed event)
        url (:url peer-site)
        route (format "%s%s" url send-route)
        compressed-batch (nippy/freeze messages)]
    (client/post route {:body (ByteBuffer/wrap compressed-batch)}))
  {})

(defmethod extensions/internal-ack-message HttpKit
  [messenger event message-id acker-id completion-id ack-val]
  (let [replica @(:onyx.core/replica event)
        url (:url (get-in replica [:peer-site acker-id]))
        route (format "%s%s" url acker-route)
        contents (nippy/freeze {:id message-id :completion-id completion-id :ack-val ack-val})]
    (client/post route {:body (ByteBuffer/wrap contents)})))

(defmethod extensions/internal-complete-message HttpKit
  [messenger id peer-id replica]
  (let [snapshot @replica
        url (:url (get-in snapshot [:peer-site peer-id]))
        route (format "%s%s" url completion-route)
        contents (nippy/freeze {:id id})]
    (client/post route {:body (ByteBuffer/wrap contents)})))

Disable batch timeout handling

Disable batch timeout handling


(ns onyx.peer.task-pipeline
  (:require [clojure.core.async :refer [alts!! <!! >!! >! chan close! go thread]]
            [com.stuartsierra.component :as component]
            [dire.core :as dire]
            [onyx.peer.pipeline-extensions :as p-ext]
            [onyx.queue.hornetq :refer [hornetq]]
            [onyx.peer.transform :as transform]
            [onyx.extensions :as extensions]))

(defn create-tx-session [{:keys [queue]}]
  (extensions/create-tx-session queue))

(defn new-payload [sync peer-node payload-ch]
  (let [peer-contents (extensions/read-place sync peer-node)
        node (extensions/create sync :payload)
        updated-contents (assoc peer-contents :payload node)]
    (extensions/write-place sync peer-node updated-contents)
    node))

(defn munge-new-payload [{:keys [sync peer-node payload-ch] :as event}]
  (let [node (new-payload sync peer-node payload-ch)]
    (extensions/on-change sync node #(>!! payload-ch %))
    (assoc event :new-payload-node node)))

(defn munge-open-session [event session]
  (assoc event :session session))

(defn munge-read-batch [event]
  (let [rets (p-ext/read-batch event)]
    (merge event rets)))

(defn munge-decompress-batch [event]
  (let [rets (p-ext/decompress-batch event)]
    (merge event rets)))

(defn munge-apply-fn [event]
  (let [rets (p-ext/apply-fn event)]
    (merge event rets)))

(defn munge-compress-batch [event]
  (let [rets (p-ext/compress-batch event)]
    (merge event rets)))

(defn munge-write-batch [event]
  (let [rets (p-ext/write-batch event)]
    (merge event rets)))

(defn munge-status-check [{:keys [sync status-node] :as event}]
  (assoc event :commit? (extensions/place-exists? sync status-node)))

(defn munge-commit-tx [{:keys [queue session] :as event}]
  (extensions/commit-tx queue session)
  (assoc event :committed true))

(defn munge-close-resources [{:keys [queue session producers consumers] :as event}]
  (doseq [producer producers] (extensions/close-resource queue producer))
  (doseq [consumer consumers] (extensions/close-resource queue consumer))
  (extensions/close-resource queue session)
  (assoc event :closed true))

(defn munge-complete-task [{:keys [sync completion-node decompressed] :as event}]
  (let [done? (= (last decompressed) :done)]
    (when done?
      (extensions/touch-place sync completion-node))
    (assoc event :completed done?)))

(defn open-session-loop [read-ch pipeline-data]
  (loop []
    (when-let [session (create-tx-session pipeline-data)]
      (>!! read-ch (munge-open-session pipeline-data session))
      (recur))))

(defn read-batch-loop [read-ch decompress-ch]
  (loop []
    (when-let [event (<!! read-ch)]
      (>!! decompress-ch (munge-read-batch event))
      (recur))))

(defn decompress-batch-loop [decompress-ch apply-fn-ch]
  (loop []
    (when-let [event (<!! decompress-ch)]
      (>!! apply-fn-ch (munge-decompress-batch event))
      (recur))))

(defn apply-fn-loop [apply-fn-ch compress-ch]
  (loop []
    (when-let [event (<!! apply-fn-ch)]
      (>!! compress-ch (munge-apply-fn event))
      (recur))))

(defn compress-batch-loop [compress-ch write-batch-ch]
  (loop []
    (when-let [event (<!! compress-ch)]
      (>!! write-batch-ch (munge-compress-batch event))
      (recur))))

(defn write-batch-loop [write-ch status-check-ch]
  (loop []
    (when-let [event (<!! write-ch)]
      (>!! status-check-ch (munge-write-batch event))
      (recur))))

(defn status-check-loop [status-ch commit-tx-ch reset-payload-node-ch]
  (loop []
    (when-let [event (<!! status-ch)]
      (let [event (munge-status-check event)]
        (if (:commit? event)
          (>!! commit-tx-ch event)
          (>!! reset-payload-node-ch event))
        (recur)))))

(defn commit-tx-loop [commit-ch close-resources-ch]
  (loop []
    (when-let [event (<!! commit-ch)]
      (>!! close-resources-ch (munge-commit-tx event))
      (recur))))

(defn close-resources-loop [close-ch complete-task-ch]
  (loop []
    (when-let [event (<!! close-ch)]
      (>!! complete-task-ch (munge-close-resources event))
      (recur))))

(defn complete-task-loop [complete-ch reset-payload-node-ch]
  (loop []
    (when-let [event (<!! complete-ch)]
      (let [event (munge-complete-task event)]
        (when (:completed event)
          (>!! reset-payload-node-ch event)))
      (recur))))

(defn reset-payload-node [reset-ch]
  (when-let [event (<!! reset-ch)]
    (munge-new-payload event)
    (>!! (:complete-ch event) true)))

(defrecord TaskPipeline [payload sync queue payload-ch complete-ch]
  component/Lifecycle

  (start [component]
    (prn "Starting Task Pipeline")

    (let [read-batch-ch (chan 1)
          decompress-batch-ch (chan 1)
          apply-fn-ch (chan 1)
          compress-batch-ch (chan 1)
          status-check-ch (chan 1)
          write-batch-ch (chan 1)
          commit-tx-ch (chan 1)
          close-resources-ch (chan 1)
          complete-task-ch (chan 1)
          reset-payload-node-ch (chan 1)

          pipeline-data {:ingress-queues (:task/ingress-queues (:task payload))
                         :egress-queues (:task/egress-queues (:task payload))
                         :task (:task/name (:task payload))
                         :peer-node (:peer (:nodes payload))
                         :status-node (:status (:nodes payload))
                         :completion-node (:completion (:nodes payload))
                         :catalog (read-string (extensions/read-place sync (:catalog (:nodes payload))))
                         :workflow (read-string (extensions/read-place sync (:workflow (:nodes payload))))
                         :payload-ch payload-ch
                         :complete-ch complete-ch
                         :queue queue
                         :sync sync
                         :batch-size 2
                         :timeout 50}]

      (dire/with-handler! #'open-session-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'read-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'decompress-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'apply-fn-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'compress-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'write-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'status-check-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'commit-tx-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'close-resources-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'complete-task-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'reset-payload-node
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (assoc component
        :read-batch-ch read-batch-ch
        :decompress-batch-ch decompress-batch-ch
        :apply-fn-ch apply-fn-ch
        :compress-batch-ch compress-batch-ch
        :write-batch-ch write-batch-ch
        :status-check-ch status-check-ch
        :commit-tx-ch commit-tx-ch
        :close-resources-ch close-resources-ch
        :complete-task-ch complete-task-ch
        :reset-payload-node-ch reset-payload-node-ch

        :open-session-loop (future (open-session-loop read-batch-ch pipeline-data))
        :read-batch-loop (thread (read-batch-loop read-batch-ch decompress-batch-ch))
        :decompress-batch-loop (thread (decompress-batch-loop decompress-batch-ch apply-fn-ch))
        :apply-fn-loop (thread (apply-fn-loop apply-fn-ch compress-batch-ch))
        :compress-batch-loop (thread (compress-batch-loop compress-batch-ch write-batch-ch))
        :write-batch-loop (thread (write-batch-loop write-batch-ch status-check-ch))
        :status-check-loop (thread (status-check-loop status-check-ch commit-tx-ch reset-payload-node-ch))
        :commit-tx-loop (thread (commit-tx-loop commit-tx-ch close-resources-ch))
        :close-resources-loop (thread (close-resources-loop close-resources-ch complete-task-ch))
        :complete-task-loop (thread (complete-task-loop complete-task-ch reset-payload-node-ch))
        :reset-payload-node (thread (reset-payload-node reset-payload-node-ch)))))

  (stop [component]
    (prn "Stopping Task Pipeline")

    (future-cancel (:open-session-loop component))

    (close! (:read-batch-ch component))
    (close! (:decompress-batch-ch component))
    (close! (:apply-fn-ch component))
    (close! (:compress-batch-ch component))
    (close! (:write-batch-ch component))
    (close! (:status-check-ch component))
    (close! (:commit-tx-ch component))
    (close! (:close-resources-ch component))
    (close! (:complete-task-ch component))
    (close! (:reset-payload-node-ch component))

    component))

(defn task-pipeline [payload sync queue payload-ch complete-ch]
  (map->TaskPipeline {:payload payload :sync sync
                      :queue queue :payload-ch payload-ch
                      :complete-ch complete-ch}))

(ns onyx.peer.task-pipeline
  (:require [clojure.core.async :refer [alts!! <!! >!! >! chan close! go thread]]
            [com.stuartsierra.component :as component]
            [dire.core :as dire]
            [onyx.peer.pipeline-extensions :as p-ext]
            [onyx.queue.hornetq :refer [hornetq]]
            [onyx.peer.transform :as transform]
            [onyx.extensions :as extensions]))

(defn create-tx-session [{:keys [queue]}]
  (extensions/create-tx-session queue))

(defn new-payload [sync peer-node payload-ch]
  (let [peer-contents (extensions/read-place sync peer-node)
        node (extensions/create sync :payload)
        updated-contents (assoc peer-contents :payload node)]
    (extensions/write-place sync peer-node updated-contents)
    node))

(defn munge-new-payload [{:keys [sync peer-node payload-ch] :as event}]
  (let [node (new-payload sync peer-node payload-ch)]
    (extensions/on-change sync node #(>!! payload-ch %))
    (assoc event :new-payload-node node)))

(defn munge-open-session [event session]
  (assoc event :session session))

(defn munge-read-batch [event]
  (let [rets (p-ext/read-batch event)]
    (merge event rets)))

(defn munge-decompress-batch [event]
  (let [rets (p-ext/decompress-batch event)]
    (merge event rets)))

(defn munge-apply-fn [event]
  (let [rets (p-ext/apply-fn event)]
    (merge event rets)))

(defn munge-compress-batch [event]
  (let [rets (p-ext/compress-batch event)]
    (merge event rets)))

(defn munge-write-batch [event]
  (let [rets (p-ext/write-batch event)]
    (merge event rets)))

(defn munge-status-check [{:keys [sync status-node] :as event}]
  (assoc event :commit? (extensions/place-exists? sync status-node)))

(defn munge-commit-tx [{:keys [queue session] :as event}]
  (extensions/commit-tx queue session)
  (assoc event :committed true))

(defn munge-close-resources [{:keys [queue session producers consumers] :as event}]
  (doseq [producer producers] (extensions/close-resource queue producer))
  (doseq [consumer consumers] (extensions/close-resource queue consumer))
  (extensions/close-resource queue session)
  (assoc event :closed true))

(defn munge-complete-task [{:keys [sync completion-node decompressed] :as event}]
  (let [done? (= (last decompressed) :done)]
    (when done?
      (extensions/touch-place sync completion-node))
    (assoc event :completed done?)))

(defn open-session-loop [read-ch kill-ch pipeline-data]
  (loop []
    (when (first (alts!! [kill-ch] :default true))
      (when-let [session (create-tx-session pipeline-data)]
        (>!! read-ch (munge-open-session pipeline-data session))
        (recur)))))

(defn read-batch-loop [read-ch decompress-ch]
  (loop []
    (when-let [event (<!! read-ch)]
      (>!! decompress-ch (munge-read-batch event))
      (recur))))

(defn decompress-batch-loop [decompress-ch apply-fn-ch]
  (loop []
    (when-let [event (<!! decompress-ch)]
      (>!! apply-fn-ch (munge-decompress-batch event))
      (recur))))

(defn apply-fn-loop [apply-fn-ch compress-ch]
  (loop []
    (when-let [event (<!! apply-fn-ch)]
      (>!! compress-ch (munge-apply-fn event))
      (recur))))

(defn compress-batch-loop [compress-ch write-batch-ch]
  (loop []
    (when-let [event (<!! compress-ch)]
      (>!! write-batch-ch (munge-compress-batch event))
      (recur))))

(defn write-batch-loop [write-ch status-check-ch]
  (loop []
    (when-let [event (<!! write-ch)]
      (>!! status-check-ch (munge-write-batch event))
      (recur))))

(defn status-check-loop [status-ch commit-tx-ch reset-payload-node-ch]
  (loop []
    (when-let [event (<!! status-ch)]
      (let [event (munge-status-check event)]
        (if (:commit? event)
          (>!! commit-tx-ch event)
          (>!! reset-payload-node-ch event))
        (recur)))))

(defn commit-tx-loop [commit-ch close-resources-ch]
  (loop []
    (when-let [event (<!! commit-ch)]
      (>!! close-resources-ch (munge-commit-tx event))
      (recur))))

(defn close-resources-loop [close-ch complete-task-ch]
  (loop []
    (when-let [event (<!! close-ch)]
      (>!! complete-task-ch (munge-close-resources event))
      (recur))))

(defn complete-task-loop [complete-ch reset-payload-node-ch]
  (loop []
    (when-let [event (<!! complete-ch)]
      (let [event (munge-complete-task event)]
        (when (:completed event)
          (>!! reset-payload-node-ch event)))
      (recur))))

(defn reset-payload-node [reset-ch]
  (when-let [event (<!! reset-ch)]
    (munge-new-payload event)
    (>!! (:complete-ch event) true)))

(defrecord TaskPipeline [payload sync queue payload-ch complete-ch]
  component/Lifecycle

  (start [component]
    (prn "Starting Task Pipeline")

    (let [open-session-kill-ch (chan 1)
          read-batch-ch (chan 1)
          decompress-batch-ch (chan 1)
          apply-fn-ch (chan 1)
          compress-batch-ch (chan 1)
          status-check-ch (chan 1)
          write-batch-ch (chan 1)
          commit-tx-ch (chan 1)
          close-resources-ch (chan 1)
          complete-task-ch (chan 1)
          reset-payload-node-ch (chan 1)

          pipeline-data {:ingress-queues (:task/ingress-queues (:task payload))
                         :egress-queues (:task/egress-queues (:task payload))
                         :task (:task/name (:task payload))
                         :peer-node (:peer (:nodes payload))
                         :status-node (:status (:nodes payload))
                         :completion-node (:completion (:nodes payload))
                         :catalog (read-string (extensions/read-place sync (:catalog (:nodes payload))))
                         :workflow (read-string (extensions/read-place sync (:workflow (:nodes payload))))
                         :payload-ch payload-ch
                         :complete-ch complete-ch
                         :queue queue
                         :sync sync
                         :batch-size 2
                         :timeout 50}]

      (dire/with-handler! #'open-session-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'read-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'decompress-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'apply-fn-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'compress-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'write-batch-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'status-check-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'commit-tx-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'close-resources-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'complete-task-loop
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (dire/with-handler! #'reset-payload-node
        java.lang.Exception
        (fn [e & _] (.printStackTrace e)))

      (assoc component
        :open-session-kill-ch open-session-kill-ch
        :read-batch-ch read-batch-ch
        :decompress-batch-ch decompress-batch-ch
        :apply-fn-ch apply-fn-ch
        :compress-batch-ch compress-batch-ch
        :write-batch-ch write-batch-ch
        :status-check-ch status-check-ch
        :commit-tx-ch commit-tx-ch
        :close-resources-ch close-resources-ch
        :complete-task-ch complete-task-ch
        :reset-payload-node-ch reset-payload-node-ch

        :open-session-loop (thread (open-session-loop read-batch-ch open-session-kill-ch pipeline-data))
        :read-batch-loop (thread (read-batch-loop read-batch-ch decompress-batch-ch))
        :decompress-batch-loop (thread (decompress-batch-loop decompress-batch-ch apply-fn-ch))
        :apply-fn-loop (thread (apply-fn-loop apply-fn-ch compress-batch-ch))
        :compress-batch-loop (thread (compress-batch-loop compress-batch-ch write-batch-ch))
        :write-batch-loop (thread (write-batch-loop write-batch-ch status-check-ch))
        :status-check-loop (thread (status-check-loop status-check-ch commit-tx-ch reset-payload-node-ch))
        :commit-tx-loop (thread (commit-tx-loop commit-tx-ch close-resources-ch))
        :close-resources-loop (thread (close-resources-loop close-resources-ch complete-task-ch))
        :complete-task-loop (thread (complete-task-loop complete-task-ch reset-payload-node-ch))
        :reset-payload-node (thread (reset-payload-node reset-payload-node-ch)))))

  (stop [component]
    (prn "Stopping Task Pipeline")

    (close! (:open-session-kill-ch component))
    (close! (:read-batch-ch component))
    (close! (:decompress-batch-ch component))
    (close! (:apply-fn-ch component))
    (close! (:compress-batch-ch component))
    (close! (:write-batch-ch component))
    (close! (:status-check-ch component))
    (close! (:commit-tx-ch component))
    (close! (:close-resources-ch component))
    (close! (:complete-task-ch component))
    (close! (:reset-payload-node-ch component))

    component))

(defn task-pipeline [payload sync queue payload-ch complete-ch]
  (map->TaskPipeline {:payload payload :sync sync
                      :queue queue :payload-ch payload-ch
                      :complete-ch complete-ch}))

Use a kill ch to stop session creation.

Use a kill ch to stop session creation.


(ns braid.server.db.group
  (:require [datomic.api :as d]
            [clojure.edn :as edn]
            [braid.server.db.common :refer :all]
            [braid.server.db.user :as user]))

(defn group-exists?
  [conn group-name]
  (some? (d/pull (d/db conn) '[:group/id] [:group/name group-name])))

(defn create-group!
  [conn {:keys [name id]}]
  (->> {:group/id id
        :group/name name}
       (create-entity! conn)
       db->group))

(defn get-group
  [conn group-id]
  (-> (d/pull (d/db conn) group-pull-pattern [:group/id group-id])
      db->group))

(defn get-users-in-group [conn group-id]
  (->> (d/q '[:find (pull ?u pull-pattern)
              :in $ ?group-id pull-pattern
              :where
              [?g :group/id ?group-id]
              [?g :group/user ?u]]
            (d/db conn)
            group-id
            user-pull-pattern)
       (map (comp db->user first))
       set))

(defn group-settings
  [conn group-id]
  (->> (d/pull (d/db conn) [:group/settings] [:group/id group-id])
       :group/settings
       ((fnil edn/read-string "{}"))))

(defn group-set!
  "Set a key to a value for the group's settings  This will throw if
  settings are changed in between reading & setting"
  [conn group-id k v]
  (let [old-prefs (-> (d/pull (d/db conn) [:group/settings] [:group/id group-id])
                      :group/settings)
        new-prefs (-> ((fnil edn/read-string "{}") old-prefs)
                      (assoc k v)
                      pr-str)]
    @(d/transact conn [[:db.fn/cas [:group/id group-id]
                        :group/settings old-prefs new-prefs]])))

(defn public-group-with-name
  [conn group-name]
  (when-let [group (-> (d/pull (d/db conn) group-pull-pattern
                               [:group/name group-name])
                       db->group)]
    (when (:public? (group-settings (group :id)))
      group)))

(defn get-group-tags
  [conn group-id]
  (->> (d/q '[:find (pull ?t [:tag/id
                              :tag/name
                              :tag/description
                              {:tag/group [:group/id :group/name]}])
              :in $ ?group-id
              :where
              [?g :group/id ?group-id]
              [?t :tag/group ?g]]
            (d/db conn) group-id)
       (map (comp db->tag first))))

(defn get-groups-for-user [conn user-id]
  (->> (d/q '[:find [?g ...]
              :in $ ?user-id
              :where
              [?u :user/id ?user-id]
              [?g :group/user ?u]]
            (d/db conn)
            user-id)
       (d/pull-many (d/db conn) group-pull-pattern)
       (map (comp #(dissoc % :users) db->group))
       set))

(defn user-in-group?
  [conn user-id group-id]
  (seq (d/q '[:find ?g
              :in $ ?user-id ?group-id
              :where
              [?u :user/id ?user-id]
              [?g :group/id ?group-id]
              [?g :group/user ?u]]
            (d/db conn)
            user-id group-id)))

(defn user-add-to-group! [conn user-id group-id]
  @(d/transact conn [[:db/add [:group/id group-id]
                      :group/user [:user/id user-id]]]))

(defn user-leave-group! [conn user-id group-id]
  (let [unsub-txn (->> (d/q '[:find [?t ...]
                              :in $ ?user-id ?group-id
                              :where
                              [?u :user/id ?user-id]
                              [?g :group/id ?group-id]
                              [?t :thread/group ?g]
                              [?u :user/subscribed-thread ?t]]
                            (d/db conn) user-id group-id)
                       (map (fn [t]
                              [:db/retract [:user/id user-id]
                               :user/subscribed-thread t])))
        unmention-txn (->> (d/q '[:find [?t ...]
                                  :in $ ?user-id ?group-id
                                  :where
                                  [?u :user/id ?user-id]
                                  [?g :group/id ?group-id]
                                  [?t :thread/group ?g]
                                  [?t :thread/mentioned ?u]]
                                (d/db conn) user-id group-id)
                           (map (fn [t]
                                  [:db/retract t
                                   :thread/mentioned [:user/id user-id]])))]
    (when-let [order (user/user-get-preference conn user-id :groups-order)]
      (user/user-set-preference!
        conn
        user-id :groups-order
        (into [] (remove (partial = group-id)) order)))
    @(d/transact conn (concat
                        [[:db/retract [:group/id group-id]
                          :group/user [:user/id user-id]]]
                        unsub-txn
                        unmention-txn))))

(defn user-make-group-admin! [conn user-id group-id]
  @(d/transact conn [[:db/add [:group/id group-id]
                      :group/user [:user/id user-id]]
                     [:db/add [:group/id group-id]
                      :group/admins [:user/id user-id]]]))

(defn user-is-group-admin?
  [conn user-id group-id]
  (some?
    (d/q '[:find ?u .
           :in $ ?user-id ?group-id
           :where
           [?g :group/id ?group-id]
           [?u :user/id ?user-id]
           [?g :group/admins ?u]]
         (d/db conn) user-id group-id)))

(defn user-subscribe-to-group-tags!
  "Subscribe the user to all current tags in the group"
  [conn user-id group-id]
  (->> (d/q '[:find ?tag
              :in $ ?group-id
              :where
              [?tag :tag/group ?g]
              [?g :group/id ?group-id]]
            (d/db conn) group-id)
       (map (fn [[tag]]
              [:db/add [:user/id user-id]
               :user/subscribed-tag tag]))
       (d/transact conn)
       deref))

(ns braid.server.db.group
  (:require [datomic.api :as d]
            [clojure.edn :as edn]
            [braid.server.db.common :refer :all]
            [braid.server.db.user :as user]))

(defn group-exists?
  [conn group-name]
  (some? (d/pull (d/db conn) '[:group/id] [:group/name group-name])))

(defn create-group!
  [conn {:keys [name id]}]
  (->> {:group/id id
        :group/name name}
       (create-entity! conn)
       db->group))

(defn get-group
  [conn group-id]
  (-> (d/pull (d/db conn) group-pull-pattern [:group/id group-id])
      db->group))

(defn get-users-in-group [conn group-id]
  (->> (d/q '[:find (pull ?u pull-pattern)
              :in $ ?group-id pull-pattern
              :where
              [?g :group/id ?group-id]
              [?g :group/user ?u]]
            (d/db conn)
            group-id
            user-pull-pattern)
       (map (comp db->user first))
       set))

(defn group-settings
  [conn group-id]
  (->> (d/pull (d/db conn) [:group/settings] [:group/id group-id])
       :group/settings
       ((fnil edn/read-string "{}"))))

(defn group-set!
  "Set a key to a value for the group's settings  This will throw if
  settings are changed in between reading & setting"
  [conn group-id k v]
  (let [old-prefs (-> (d/pull (d/db conn) [:group/settings] [:group/id group-id])
                      :group/settings)
        new-prefs (-> ((fnil edn/read-string "{}") old-prefs)
                      (assoc k v)
                      pr-str)]
    @(d/transact conn [[:db.fn/cas [:group/id group-id]
                        :group/settings old-prefs new-prefs]])))

(defn public-group-with-name
  [conn group-name]
  (when-let [group (-> (d/pull (d/db conn) group-pull-pattern
                               [:group/name group-name])
                       db->group)]
    (when (:public? (group-settings conn (group :id)))
      group)))

(defn get-group-tags
  [conn group-id]
  (->> (d/q '[:find (pull ?t [:tag/id
                              :tag/name
                              :tag/description
                              {:tag/group [:group/id :group/name]}])
              :in $ ?group-id
              :where
              [?g :group/id ?group-id]
              [?t :tag/group ?g]]
            (d/db conn) group-id)
       (map (comp db->tag first))))

(defn get-groups-for-user [conn user-id]
  (->> (d/q '[:find [?g ...]
              :in $ ?user-id
              :where
              [?u :user/id ?user-id]
              [?g :group/user ?u]]
            (d/db conn)
            user-id)
       (d/pull-many (d/db conn) group-pull-pattern)
       (map (comp #(dissoc % :users) db->group))
       set))

(defn user-in-group?
  [conn user-id group-id]
  (seq (d/q '[:find ?g
              :in $ ?user-id ?group-id
              :where
              [?u :user/id ?user-id]
              [?g :group/id ?group-id]
              [?g :group/user ?u]]
            (d/db conn)
            user-id group-id)))

(defn user-add-to-group! [conn user-id group-id]
  @(d/transact conn [[:db/add [:group/id group-id]
                      :group/user [:user/id user-id]]]))

(defn user-leave-group! [conn user-id group-id]
  (let [unsub-txn (->> (d/q '[:find [?t ...]
                              :in $ ?user-id ?group-id
                              :where
                              [?u :user/id ?user-id]
                              [?g :group/id ?group-id]
                              [?t :thread/group ?g]
                              [?u :user/subscribed-thread ?t]]
                            (d/db conn) user-id group-id)
                       (map (fn [t]
                              [:db/retract [:user/id user-id]
                               :user/subscribed-thread t])))
        unmention-txn (->> (d/q '[:find [?t ...]
                                  :in $ ?user-id ?group-id
                                  :where
                                  [?u :user/id ?user-id]
                                  [?g :group/id ?group-id]
                                  [?t :thread/group ?g]
                                  [?t :thread/mentioned ?u]]
                                (d/db conn) user-id group-id)
                           (map (fn [t]
                                  [:db/retract t
                                   :thread/mentioned [:user/id user-id]])))]
    (when-let [order (user/user-get-preference conn user-id :groups-order)]
      (user/user-set-preference!
        conn
        user-id :groups-order
        (into [] (remove (partial = group-id)) order)))
    @(d/transact conn (concat
                        [[:db/retract [:group/id group-id]
                          :group/user [:user/id user-id]]]
                        unsub-txn
                        unmention-txn))))

(defn user-make-group-admin! [conn user-id group-id]
  @(d/transact conn [[:db/add [:group/id group-id]
                      :group/user [:user/id user-id]]
                     [:db/add [:group/id group-id]
                      :group/admins [:user/id user-id]]]))

(defn user-is-group-admin?
  [conn user-id group-id]
  (some?
    (d/q '[:find ?u .
           :in $ ?user-id ?group-id
           :where
           [?g :group/id ?group-id]
           [?u :user/id ?user-id]
           [?g :group/admins ?u]]
         (d/db conn) user-id group-id)))

(defn user-subscribe-to-group-tags!
  "Subscribe the user to all current tags in the group"
  [conn user-id group-id]
  (->> (d/q '[:find ?tag
              :in $ ?group-id
              :where
              [?tag :tag/group ?g]
              [?g :group/id ?group-id]]
            (d/db conn) group-id)
       (map (fn [[tag]]
              [:db/add [:user/id user-id]
               :user/subscribed-tag tag]))
       (d/transact conn)
       deref))

fix call to group-settings (from db refactor)


(ns braid.ui.styles.body)

(def body
  [:body
   {:margin 0
    :padding 0
    :font-family "Open Sans, Helvetica, Arial, sans-serif"
    :font-size "12px"
    :background "#eee"}])

(ns braid.ui.styles.body)

(def body
  [:body
   {:margin 0
    :padding 0
    :font-family "\"Open Sans\", Helvetica, Arial, sans-serif"
    :font-size "12px"
    :background "#eee"}])

Add quotes to Open Sans

Add quotes to Open Sans


(ns workflo.macros.query
  (:require #?(:cljs [cljs.spec :as s]
               :clj  [clojure.spec :as s])
            [workflo.macros.query.util :as util]
            [workflo.macros.specs.conforming-query]
            [workflo.macros.specs.parsed-query]
            [workflo.macros.specs.query]))

;;;; Properties specification parsing

(declare parse)

(s/fdef conform
  :args (s/cat :query :workflo.macros.specs.query/query)
  :ret  :workflo.macros.specs.conforming-query/query)

(defn conform
  "Validates a query and returns the parsed, conforming result."
  [query]
  (s/conform :workflo.macros.specs.query/query query))

(s/def ::subquery
  (s/or :regular-query
        :workflo.macros.specs.conforming-query/regular-query
        :parameterized-query
        :workflo.macros.specs.conforming-query/parameterized-query))

(s/fdef parse-subquery
  :args (s/cat :query ::subquery)
  :ret  :workflo.macros.specs.parsed-query/query)

(defn parse-subquery
  "Takes a subquery and returns a vector of parsed properties, each
   in one of the following forms:

       {:name user/name :type :property}
       {:name user/email :type :property}
       {:name user/friends :type :join :join-target User}
       {:name user/friends :type :join
        :join-target [{:name user/name :type :property}]}
       {:name current-user :type :link :link-id _}.

   Each of these may in addition contain an optional :parameters
   key with a {symbol ?variable}-style map."
  [[type query]]
  (case type
    :regular-query       (parse-subquery query)
    :parameterized-query (->> (:regular-query-value query)
                              (parse-subquery)
                              (mapv (fn [parsed]
                                      (assoc parsed :parameters
                                             (:parameters query)))))
    :nested-properties   (let [{:keys [base children]} query]
                           (->> children
                                (map parse-subquery)
                                (apply concat)
                                (mapv (fn [child]
                                        (update child :name
                                                (fn [sym]
                                                  (symbol
                                                   (name base)
                                                   (name sym))))))))
    :property            (parse-subquery query)
    :simple              [{:name query :type :property}]
    :link                (let [[name link-id] query]
                           [{:name name :type :link :link-id link-id}])
    :join                (parse-subquery query)
    :model-join          (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target target}])
    :recursive-join      (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target target}])
    :properties-join     (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target (parse target)}])))

(s/fdef parse
  :args (s/cat :props :workflo.macros.specs.query/query)
  :ret :workflo.macros.specs.parsed-query/query)

(defn parse
  "Parses a query expression like

       [user [name email {friends User}] [current-user _]]

   into a flat vector of parsed properties with the following
   structure:

       [{:name user/name :type :property}
        {:name user/email :type :property}
        {:name user/friends :type :join :join-target User}
        {:name current-user :type :link :link-id _}].

   From this it is trivial to generate queries for arbitrary
   frameworks (e.g. Om Next) as well as keys for destructuring
   the results."
  [query]
  (->> (conform query)
       (map parse-subquery)
       (apply concat)
       (into [])))

(s/fdef map-destructuring-keys
  :args (s/cat :props :workflo.macros.specs.parsed-query/query)
  :ret  (s/and vector? (s/+ symbol?))
  :fn   (s/and #(= (into #{} (:ret %))
                   (into #{} (map :name) (:props (:args %))))))

(defn map-destructuring-keys
  "Generates keys for destructuring a map of properties from a parsed
   properties specification."
  [props]
  (into [] (map :name) props))

(ns workflo.macros.query
  (:require #?(:cljs [cljs.spec :as s]
               :clj  [clojure.spec :as s])
            [workflo.macros.query.util :as util]
            [workflo.macros.specs.conforming-query]
            [workflo.macros.specs.parsed-query]
            [workflo.macros.specs.query]))

;;;; Properties specification parsing

(declare parse)

(s/fdef conform
  :args (s/cat :query :workflo.macros.specs.query/query)
  :ret  :workflo.macros.specs.conforming-query/query)

(defn conform
  "Validates a query and returns the parsed, conforming result."
  [query]
  (s/conform :workflo.macros.specs.query/query query))

(s/def ::subquery
  (s/or :regular-query
        :workflo.macros.specs.conforming-query/regular-query
        :parameterized-query
        :workflo.macros.specs.conforming-query/parameterized-query))

(s/fdef parse-subquery
  :args (s/cat :query ::subquery)
  :ret  :workflo.macros.specs.parsed-query/query)

(defn parse-subquery
  "Takes a subquery and returns a vector of parsed properties, each
   in one of the following forms:

       {:name user/name :type :property}
       {:name user/email :type :property}
       {:name user/friends :type :join :join-target User}
       {:name user/friends :type :join
        :join-target [{:name user/name :type :property}]}
       {:name current-user :type :link :link-id _}.

   Each of these may in addition contain an optional :parameters
   key with a {symbol ?variable}-style map."
  [[type query]]
  (case type
    :regular-query       (parse-subquery query)
    :parameterized-query (->> (:regular-query-value query)
                              (parse-subquery)
                              (mapv (fn [parsed]
                                      (assoc parsed :parameters
                                             (:parameters query)))))
    :nested-properties   (let [{:keys [base children]} query]
                           (->> children
                                (map parse-subquery)
                                (apply concat)
                                (mapv (fn [child]
                                        (update child :name
                                                (fn [sym]
                                                  (symbol
                                                   (name base)
                                                   (name sym))))))))
    :property            (parse-subquery query)
    :simple              [{:name query :type :property}]
    :link                (let [[name link-id] query]
                           [{:name name :type :link :link-id link-id}])
    :join                (parse-subquery query)
    :model-join          (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target target}])
    :recursive-join      (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target (second target)}])
    :properties-join     (let [[name target] (first query)]
                           [{:name name :type :join
                             :join-target (parse target)}])))

(s/fdef parse
  :args (s/cat :props :workflo.macros.specs.query/query)
  :ret :workflo.macros.specs.parsed-query/query)

(defn parse
  "Parses a query expression like

       [user [name email {friends User}] [current-user _]]

   into a flat vector of parsed properties with the following
   structure:

       [{:name user/name :type :property}
        {:name user/email :type :property}
        {:name user/friends :type :join :join-target User}
        {:name current-user :type :link :link-id _}].

   From this it is trivial to generate queries for arbitrary
   frameworks (e.g. Om Next) as well as keys for destructuring
   the results."
  [query]
  (->> (conform query)
       (map parse-subquery)
       (apply concat)
       (into [])))

(s/fdef map-destructuring-keys
  :args (s/cat :props :workflo.macros.specs.parsed-query/query)
  :ret  (s/and vector? (s/+ symbol?))
  :fn   (s/and #(= (into #{} (:ret %))
                   (into #{} (map :name) (:props (:args %))))))

(defn map-destructuring-keys
  "Generates keys for destructuring a map of properties from a parsed
   properties specification."
  [props]
  (into [] (map :name) props))

Update query parsing to the latest changes in clojure.spec


(ns mdr2.archive.core
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  (:require [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [conman.core :as conman]
            [mdr2.config :refer [env]]
            [mdr2.db.core :as db]
            [java-time :as time]
            [babashka.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.repair.core :as repair]
            [mdr2.rdf :as rdf]
            [iapetos.collector.fn :as prometheus]
            [mdr2.metrics :as metrics]))

;;(def ^:private db {:factory factory :name "java:jboss/datasources/archive"})
(def ^:private db {:name "java:jboss/datasources/archive"})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn container-root-path
  "Return the root container path for a given `production` and
  `sektion`"
  [production sektion]
  (file (env :archive-spool-dir) (container-id production sektion)))

(defn container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)]
    (file root-path "produkt")))

(defn container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file root-path rdf-name))))

(defn- db-job
  "Return a map that can be used to insert a job in the archive db for
  given `production` and `sektion`"
  [production sektion]
  {:archivar "Madras2"
   :abholer ""
   :aktion (if (> (:revision production) 1) "update" "save")
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""
   :verzeichnis (container-id production sektion)
   :sektion (case sektion :master "master" :dist-master "cdimage")
   :datum (time/local-date)})

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [update (> (:revision production) 1)
        job (db-job production sektion)]
    (if update
      (let [container-id (repair/container-id production sektion)]
        (log/debugf "Updating %s (%s, %s) in archive db" (:id production) sektion container-id)
        (db/update-archive-container-job (assoc job :container-id container-id)))
      (do
        (log/debugf "Adding %s (%s) to archive db" (:id production) sektion)
        (db/insert-archive-container-job job)))))

(defn set-file-permissions
  "Set file permissions on `file-tree` to g+w recursively"
  [file-tree]
  (let [visitor-fn (fn [f _] (fs/set-posix-file-permissions f "rw-rw-r--") :continue)]
    (fs/walk-file-tree file-tree {:pre-visit-dir visitor-fn :visit-file visitor-fn})))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-root-path (container-root-path production sektion)]
    (if (fs/exists? archive-root-path)
      (let [message (format "Archive root path %s already exists" archive-root-path)]
        (log/error message)
        (throw (ex-info message {:error-id ::directory-already-exists})))
      (let [archive-path (container-path production sektion)]
        (fs/create-dirs archive-path)
        (log/debugf "Copying files for %s (%s)" (:id production) sektion)
        (case sektion
          :master
          (fs/copy-tree (path/recorded-path production)
                        (file archive-path (prod/dam-number production)))
          :dist-master
          (doseq [volume (range 1 (inc (:volumes production)))]
            (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                  iso-archive-path (file archive-path iso-archive-name)]
              (fs/copy (path/iso-name production volume) iso-archive-path))))
        (set-file-permissions archive-root-path)))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        rdf-path (container-rdf-path production sektion)]
    (log/debugf "Creating rdf for %s (%s)" (:id production) sektion)
    (spit rdf-path rdf)))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`

  There are multiple ways to archive an production.

  1. for a *book* we simply archive both the master and the dist-master
  2. for a *periodical* we archive the master and then put the
     dist-master into a special spool directory based on the setting
     `:archive-periodical-spool-dir`
  3. for *other* productions we archive the master and then put the
     dist-master into a special spool directory based on the setting
     `:archive-other-spool-dir`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (log/infof "Archiving %s as a book" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    (archive-sektion production :dist-master)
    (prod/set-state-archived! production)))

(defmethod archive "periodical"
  [production]
  (log/infof "Archiving %s as a periodical" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    ;; archive the periodical iso(s)
    (let [dam-number (prod/dam-number production)
          archive-path (.getPath (file (env :archive-periodical-spool-dir) dam-number))
          multi-volume? (prod/multi-volume? production)]
      (when (fs/exists? archive-path)
        ;; when repairing the production is already in the spool dir
        (when-not (fs/delete-tree archive-path)
          (let [message (format "Failed to remove archive path for periodical (%s)"
                                archive-path)]
            (log/error message)
            (throw (ex-info message {:error-id ::spool-dir-remove-failed})))))
      (fs/create-dirs archive-path)
      ;; create the rdf
      (let [rdf-path (file archive-path (str dam-number ".rdf"))
            rdf (rdf/rdf production)]
        (spit rdf-path rdf))
      ;; copy all volumes
      (doseq [volume (range 1 (inc (:volumes production)))]
        (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
              iso-archive-path (file archive-path "produkt" iso-archive-name)]
          (fs/create-dirs (fs/parent iso-archive-path))
          (fs/copy (path/iso-name production volume) iso-archive-path)))
      (set-file-permissions (file archive-path))
      (prod/set-state-archived! production))))

(defmethod archive "other"
  [production]
  (log/infof "Archiving %s as an other" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    ;; place the iso(s) in a spool directory
    (let [dam-number (prod/dam-number production)
          archive-path (.getPath (file (env :archive-other-spool-dir) dam-number))
          multi-volume? (prod/multi-volume? production)]
      (when (fs/exists? archive-path)
        ;; when repairing the production is already in the spool dir
        (when-not (fs/delete-tree archive-path)
          (let [message (format "Failed to remove archive path for other production (%s)"
                                archive-path)]
            (log/error message)
            (throw (ex-info message {:error-id ::spool-dir-remove-failed})))))
      (fs/create-dirs archive-path)
      ;; create the rdf
      (let [rdf-path (file archive-path (str dam-number ".rdf"))
            rdf (rdf/rdf production)]
        (spit rdf-path rdf))
      ;; copy all volumes
      (doseq [volume (range 1 (inc (:volumes production)))]
        (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
              iso-archive-path (file archive-path "produkt" iso-archive-name)]
          (fs/create-dirs (fs/parent iso-archive-path))
          (fs/copy (path/iso-name production volume) iso-archive-path)
          (set-file-permissions (file iso-archive-path))))
      (prod/set-state-archived! production))))

(prometheus/instrument! metrics/registry #'archive)

(comment
  (let [p {:id 50000 :revision 0 :library_signature "ds70000"}]
    (db-job p :master))

  (let [p {:id 50000 :revision 0 :library_signature "ds70000"}]
    (add-to-db p :master))

  (let [p {:id 50000 :revision 2 :library_signature "ds70000"}]
    (add-to-db p :master))

  )

(ns mdr2.archive.core
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  (:require [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [conman.core :as conman]
            [mdr2.config :refer [env]]
            [mdr2.db.core :as db]
            [java-time :as time]
            [babashka.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.repair.core :as repair]
            [mdr2.rdf :as rdf]
            [iapetos.collector.fn :as prometheus]
            [mdr2.metrics :as metrics]))

;;(def ^:private db {:factory factory :name "java:jboss/datasources/archive"})
(def ^:private db {:name "java:jboss/datasources/archive"})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn container-root-path
  "Return the root container path for a given `production` and
  `sektion`"
  [production sektion]
  (file (env :archive-spool-dir) (container-id production sektion)))

(defn container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)]
    (file root-path "produkt")))

(defn container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [root-path (container-root-path production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file root-path rdf-name))))

(defn- db-job
  "Return a map that can be used to insert a job in the archive db for
  given `production` and `sektion`"
  [production sektion]
  {:archivar "Madras2"
   :abholer ""
   :aktion (if (> (:revision production) 1) "update" "save")
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""
   :verzeichnis (container-id production sektion)
   :sektion (case sektion :master "master" :dist-master "cdimage")
   :datum (time/local-date)})

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [update (> (:revision production) 1)
        job (db-job production sektion)]
    (if update
      (let [container-id (repair/container-id production sektion)]
        (log/debugf "Updating %s (%s, %s) in archive db" (:id production) sektion container-id)
        (db/update-archive-container-job (assoc job :container-id container-id)))
      (do
        (log/debugf "Adding %s (%s) to archive db" (:id production) sektion)
        (db/insert-archive-container-job job)))))

(defn set-file-permissions
  "Set file permissions on `file-tree` to g+w recursively"
  [file-tree]
  (let [visit-file-fn (fn [f _] (fs/set-posix-file-permissions f "rw-rw-r--") :continue)
        visit-dir-fn (fn [f _] (fs/set-posix-file-permissions f "rwxrwxr-x") :continue)]
    (fs/walk-file-tree file-tree {:pre-visit-dir visit-dir-fn :visit-file visit-file-fn})))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-root-path (container-root-path production sektion)]
    (if (fs/exists? archive-root-path)
      (let [message (format "Archive root path %s already exists" archive-root-path)]
        (log/error message)
        (throw (ex-info message {:error-id ::directory-already-exists})))
      (let [archive-path (container-path production sektion)]
        (fs/create-dirs archive-path)
        (log/debugf "Copying files for %s (%s)" (:id production) sektion)
        (case sektion
          :master
          (fs/copy-tree (path/recorded-path production)
                        (file archive-path (prod/dam-number production)))
          :dist-master
          (doseq [volume (range 1 (inc (:volumes production)))]
            (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                  iso-archive-path (file archive-path iso-archive-name)]
              (fs/copy (path/iso-name production volume) iso-archive-path))))
        (set-file-permissions archive-root-path)))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        rdf-path (container-rdf-path production sektion)]
    (log/debugf "Creating rdf for %s (%s)" (:id production) sektion)
    (spit rdf-path rdf)))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`

  There are multiple ways to archive an production.

  1. for a *book* we simply archive both the master and the dist-master
  2. for a *periodical* we archive the master and then put the
     dist-master into a special spool directory based on the setting
     `:archive-periodical-spool-dir`
  3. for *other* productions we archive the master and then put the
     dist-master into a special spool directory based on the setting
     `:archive-other-spool-dir`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (log/infof "Archiving %s as a book" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    (archive-sektion production :dist-master)
    (prod/set-state-archived! production)))

(defmethod archive "periodical"
  [production]
  (log/infof "Archiving %s as a periodical" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    ;; archive the periodical iso(s)
    (let [dam-number (prod/dam-number production)
          archive-path (.getPath (file (env :archive-periodical-spool-dir) dam-number))
          multi-volume? (prod/multi-volume? production)]
      (when (fs/exists? archive-path)
        ;; when repairing the production is already in the spool dir
        (when-not (fs/delete-tree archive-path)
          (let [message (format "Failed to remove archive path for periodical (%s)"
                                archive-path)]
            (log/error message)
            (throw (ex-info message {:error-id ::spool-dir-remove-failed})))))
      (fs/create-dirs archive-path)
      ;; create the rdf
      (let [rdf-path (file archive-path (str dam-number ".rdf"))
            rdf (rdf/rdf production)]
        (spit rdf-path rdf))
      ;; copy all volumes
      (doseq [volume (range 1 (inc (:volumes production)))]
        (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
              iso-archive-path (file archive-path "produkt" iso-archive-name)]
          (fs/create-dirs (fs/parent iso-archive-path))
          (fs/copy (path/iso-name production volume) iso-archive-path)))
      (set-file-permissions (file archive-path))
      (prod/set-state-archived! production))))

(defmethod archive "other"
  [production]
  (log/infof "Archiving %s as an other" (:id production))
  (conman/with-transaction [db/*archive-db*]
    (archive-sektion production :master)
    ;; place the iso(s) in a spool directory
    (let [dam-number (prod/dam-number production)
          archive-path (.getPath (file (env :archive-other-spool-dir) dam-number))
          multi-volume? (prod/multi-volume? production)]
      (when (fs/exists? archive-path)
        ;; when repairing the production is already in the spool dir
        (when-not (fs/delete-tree archive-path)
          (let [message (format "Failed to remove archive path for other production (%s)"
                                archive-path)]
            (log/error message)
            (throw (ex-info message {:error-id ::spool-dir-remove-failed})))))
      (fs/create-dirs archive-path)
      ;; create the rdf
      (let [rdf-path (file archive-path (str dam-number ".rdf"))
            rdf (rdf/rdf production)]
        (spit rdf-path rdf))
      ;; copy all volumes
      (doseq [volume (range 1 (inc (:volumes production)))]
        (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
              iso-archive-path (file archive-path "produkt" iso-archive-name)]
          (fs/create-dirs (fs/parent iso-archive-path))
          (fs/copy (path/iso-name production volume) iso-archive-path)
          (set-file-permissions (file iso-archive-path))))
      (prod/set-state-archived! production))))

(prometheus/instrument! metrics/registry #'archive)

(comment
  (let [p {:id 50000 :revision 0 :library_signature "ds70000"}]
    (db-job p :master))

  (let [p {:id 50000 :revision 0 :library_signature "ds70000"}]
    (add-to-db p :master))

  (let [p {:id 50000 :revision 2 :library_signature "ds70000"}]
    (add-to-db p :master))

  )

implement the visitor functions to set file permissions properly


(ns runbld.facts.oshi
  (:require
   [cheshire.core :as json]
   [clojure.java.shell :as sh]
   [clojure.string :as string]
   [clojure.walk :as walk]
   [runbld.facts :refer [Facter] :as facts]
   [runbld.io :as rio]
   [runbld.util.data :as data]
   [runbld.util.debug :as debug])
  (:import
   (oshi.json SystemInfo)))

;; just wanted the defrecord near the top
(declare facts primary-network)

(defrecord Oshi [facts]
  Facter

  (raw [x] x)

  (arch [{x :facts}]
    (get-in x [:properties :os.arch]))

  (model [{x :facts}]
    ;; The field that we use from facter is [:os :hardware] which
    ;; appears to basically return the system architecture.
    (get-in x [:properties :os.arch]))

  (cpu-type [{x :facts}]
    (get-in x [:hardware :processor :name]))

  (cpus [{x :facts}]
    (get-in x [:hardware :processor :logicalProcessorCount]))

  (cpus-physical [{x :facts}]
    (get-in x [:hardware :processor :physicalProcessorCount]))

  (facter-provider [{x :facts}]
    "oshi")

  (facter-version [{x :facts}]
    (->> (get-in x [:properties :java.class.path])
         (re-find #".*oshi-json/((?:\d+\.?)+)/oshi-json")
         last))

  (hostname [{x :facts}]
    (get-in x [:operatingSystem :networkParams :hostName]))

  (ip4 [{x :facts}]
    (first (primary-network x)))

  (ip6 [{x :facts}]
    ;; this silliness is to compress the ipv6 address as that's what
    ;; facter provides.  There are libraries to do this, but a regex
    ;; doesn't introduce new deps
    ;; https://stackoverflow.com/questions/7043983/ipv6-address-into-compressed-form-in-java
    (string/replace
     (last (primary-network x))
     #"((?:(?:^|:)0+\b){2,}):?(?!\S*\b\1:0+\b)(\S*)"
     "::$2"))

  (kernel-name [{x :facts}]
    (get-in x [:uname :name]))

  (kernel-release [{x :facts}]
    (get-in x [:uname :version]))

  (kernel-version [{x :facts}]
    (get-in x [:uname :version]))

  (os [{x :facts}]
    (get-in x [:operatingSystem :family]))

  (os-version [{x :facts}]
    (get-in x [:operatingSystem :version :version]))

  (os-family [{x :facts}]
    (get-in x [:operatingSystem :family]))

  (ram-mb [{x :facts}]
    (data/bigdec
     (/ (get-in x [:hardware :memory :total])
        (* 1024 1024))
     2))

  (ram-gb [{x :facts}]
    (data/bigdec
     (/ (get-in x [:hardware :memory :total])
        (* 1024 1024 1024))
     2))

  (ram-bytes [{x :facts}]
    (get-in x [:hardware :memory :total]))

  (timezone [{x :facts}]
    (get-in x [:properties :user.timezone]))

  (uptime-days [{x :facts}]
    (int
     (/ (get-in x [:hardware :processor :systemUptime])
        (* 60 60 24))))

  (uptime-secs [{x :facts}]
    (get-in x [:hardware :processor :systemUptime]))

  (uptime [{x :facts :as raw}]
    (let [days (.uptime-days raw)]
      (str days
           (if (> days 1)
             " days"
             " day"))))

  ;; OSHI doesn't report this, and figuring it out generically appears
  ;; to be impossible (facter tries a bunch of different strategies to
  ;; figure it out).  Instead, for now, defer to the 'hosting'
  ;; provider.
  (virtual [_]))

(defn primary-network
  "Takes the set of facts and returns a vector of [ipv4 ipv6] for the
  primary network adapter.  Is somewhat naive in that it picks the
  primary adapter based on total bytes sent and received."
  [facts]
  ;; TODO - is this sufficient to find the "primary"?
  (->> (get-in facts [:hardware :networks])
       (remove (comp empty? :ipv4))
       (sort-by #(+ (:bytesSent %)
                    (:bytesRecv %)))
       last
       ((juxt :ipv4 :ipv6))
       (map first)))

(defn uname [{:keys [platform] :as facts}]
  (let [platform (string/lower-case platform)]
    (cond
      (#{"linux" "macosx"} platform)
      {:name (string/trim (:out (rio/run "uname" "-s")))
       :version (string/trim (:out (rio/run "uname" "-r")))}

      (= "windows" platform)
      (let [sysinfo (:out (rio/run "cmd.exe" "-c" "systeminfo"))]
        {:name "Windows"
         :version (last (re-find #"(\d+\.?)+" sysinfo))}))))

(defn facts* []
  (let [start (System/currentTimeMillis)
        system-facts (json/parse-string (str (SystemInfo.)) true)
        oshi-time (System/currentTimeMillis)
        system-props (walk/keywordize-keys (into {} (System/getProperties)))
        props-time (System/currentTimeMillis)
        uname-props (uname system-facts)
        uname-time (System/currentTimeMillis)]
    (debug/log "Collected system facts."
               "OSHI took:" (- oshi-time start) "ms."
               "Reading sys props took:" (- props-time oshi-time) "ms."
               "Reading uname took:" (- uname-time props-time) "ms.")
    (assoc system-facts
           :properties system-props
           :uname (uname system-facts))))

(def facts (memoize facts*))

(ns runbld.facts.oshi
  (:require
   [cheshire.core :as json]
   [clojure.java.shell :as sh]
   [clojure.string :as string]
   [clojure.walk :as walk]
   [runbld.facts :refer [Facter] :as facts]
   [runbld.io :as rio]
   [runbld.util.data :as data]
   [runbld.util.debug :as debug])
  (:import
   (oshi.json SystemInfo)))

;; just wanted the defrecord near the top
(declare facts primary-network)

(defrecord Oshi [facts]
  Facter

  (raw [x] x)

  (arch [{x :facts}]
    (get-in x [:properties :os.arch]))

  (model [{x :facts}]
    ;; The field that we use from facter is [:os :hardware] which
    ;; appears to basically return the system architecture.
    (let [arch (get-in x [:properties :os.arch])]
      (if (= "amd64" arch)
        "x86_64"
        arch)))

  (cpu-type [{x :facts}]
    (get-in x [:hardware :processor :name]))

  (cpus [{x :facts}]
    (get-in x [:hardware :processor :logicalProcessorCount]))

  (cpus-physical [{x :facts}]
    (get-in x [:hardware :processor :physicalProcessorCount]))

  (facter-provider [{x :facts}]
    "oshi")

  (facter-version [{x :facts}]
    (->> (get-in x [:properties :java.class.path])
         (re-find #".*oshi-json/((?:\d+\.?)+)/oshi-json")
         last))

  (hostname [{x :facts}]
    (get-in x [:operatingSystem :networkParams :hostName]))

  (ip4 [{x :facts}]
    (first (primary-network x)))

  (ip6 [{x :facts}]
    ;; this silliness is to compress the ipv6 address as that's what
    ;; facter provides.  There are libraries to do this, but a regex
    ;; doesn't introduce new deps
    ;; https://stackoverflow.com/questions/7043983/ipv6-address-into-compressed-form-in-java
    (string/replace
     (last (primary-network x))
     #"((?:(?:^|:)0+\b){2,}):?(?!\S*\b\1:0+\b)(\S*)"
     "::$2"))

  (kernel-name [{x :facts}]
    (get-in x [:uname :name]))

  (kernel-release [{x :facts}]
    (get-in x [:uname :version]))

  (kernel-version [{x :facts}]
    (first
     (string/split
      (get-in x [:uname :version]) #"-")))

  (os [{x :facts}]
    (get-in x [:operatingSystem :family]))

  (os-version [{x :facts}]
    (get-in x [:operatingSystem :version :version]))

  (os-family [{x :facts}]
    (get-in x [:operatingSystem :family]))

  (ram-mb [{x :facts}]
    (data/bigdec
     (/ (get-in x [:hardware :memory :total])
        (* 1024 1024))
     2))

  (ram-gb [{x :facts}]
    (data/bigdec
     (/ (get-in x [:hardware :memory :total])
        (* 1024 1024 1024))
     2))

  (ram-bytes [{x :facts}]
    (get-in x [:hardware :memory :total]))

  (timezone [{x :facts}]
    (get-in x [:properties :user.timezone]))

  (uptime-days [{x :facts}]
    (int
     (/ (get-in x [:hardware :processor :systemUptime])
        (* 60 60 24))))

  (uptime-secs [{x :facts}]
    (get-in x [:hardware :processor :systemUptime]))

  (uptime [{x :facts :as raw}]
    (let [days (.uptime-days raw)]
      (str days
           (if (> days 1)
             " days"
             " day"))))

  ;; OSHI doesn't report this, and figuring it out generically appears
  ;; to be impossible (facter tries a bunch of different strategies to
  ;; figure it out).  Instead, for now, defer to the 'hosting'
  ;; provider.
  (virtual [_]))

(defn primary-network
  "Takes the set of facts and returns a vector of [ipv4 ipv6] for the
  primary network adapter.  Is somewhat naive in that it picks the
  primary adapter based on total bytes sent and received."
  [facts]
  ;; TODO - is this sufficient to find the "primary"?
  (->> (get-in facts [:hardware :networks])
       (remove (comp empty? :ipv4))
       (sort-by #(+ (:bytesSent %)
                    (:bytesRecv %)))
       last
       ((juxt :ipv4 :ipv6))
       (map first)))

(defn uname [{:keys [platform] :as facts}]
  (let [platform (string/lower-case platform)]
    (cond
      (#{"linux" "macosx"} platform)
      {:name (string/trim (:out (rio/run "uname" "-s")))
       :version (string/trim (:out (rio/run "uname" "-r")))}

      (= "windows" platform)
      (let [sysinfo (:out (rio/run "cmd.exe" "-c" "systeminfo"))]
        {:name "Windows"
         :version (last (re-find #"(\d+\.?)+" sysinfo))}))))

(defn facts* []
  (let [start (System/currentTimeMillis)
        system-facts (json/parse-string (str (SystemInfo.)) true)
        oshi-time (System/currentTimeMillis)
        system-props (walk/keywordize-keys (into {} (System/getProperties)))
        props-time (System/currentTimeMillis)
        uname-props (uname system-facts)
        uname-time (System/currentTimeMillis)]
    (debug/log "Collected system facts."
               "OSHI took:" (- oshi-time start) "ms."
               "Reading sys props took:" (- props-time oshi-time) "ms."
               "Reading uname took:" (- uname-time props-time) "ms.")
    (assoc system-facts
           :properties system-props
           :uname (uname system-facts))))

(def facts (memoize facts*))

clean up a few differences between oshi and facter