(ns com.stuartsierra.lazytest)

;;; PROTOCOLS

(defprotocol TestInvokable
  (invoke-test [t active]))

(defprotocol TestResult
  (success? [r] "True if this result and all its children passed.")
  (pending? [r] "True if this is the result of an empty test.")
  (error? [r] "True if this is the result of a thrown exception.")
  (container? [r] "True if this is a container for other results."))

;;; Results

(deftype TestResultContainer [source children]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] (every? success? children))
    (pending? [] (if (seq children) false true))
    (error? [] false)
    (container? [] true))

(deftype TestPassed [source states]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] true)
    (pending? [] false)
    (error? [] false)
    (container? [] false))

(deftype TestFailed [source states]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] false)
    (pending? [] false)
    (error? [] false)
    (container? [] false))

(deftype TestThrown [source states throwable]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] false)
    (pending? [] false)
    (error? [] true)
    (container? [] false))

;;; Contexts

(deftype Context [parents before after])

(defn- open-context
  "Opens context c, and all its parents, unless it is already active."
  [active c]
  (let [active (reduce open-context active (:parents c))
        states (map active (:parents c))]
    (if-let [f (:before c)]
      (assoc active c (or (active c) (apply f states)))
      active)))

(defn- close-context
  "Closes context c and removes it from active."
  [active c]
  (let [states (map active (:parents c))]
    (when-let [f (:after c)]
      (apply f (active c) states))
    (let [active (reduce close-context active (:parents c))]
      (dissoc active c))))

(defmacro defcontext
  "Defines a context.
  decl => docstring? [bindings*] before-body* after-fn?
  after-fn => :after [state] after-body*"
  [name & decl]
  (let [m {:name name, :ns *ns*, :file *file*, :line @Compiler/LINE}
        m (if (string? (first decl)) (assoc m :doc (first decl)) m)
        decl (if (string? (first decl)) (next decl) decl)
        bindings (first decl)
        bodies (next decl)]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (vec (map first pairs))
          contexts (vec (map second pairs))
          before (take-while #(not= :after %) bodies)
          after (next (drop-while #(not= :after %) bodies))
          before-fn `(fn ~locals ~@before)]
      (when after (assert (vector? (first after))))
      (let [after-fn (when after
                       `(fn ~(vec (concat (first after) locals))
                          ~@after))]
        `(def ~name (Context ~contexts ~before-fn ~after-fn '~m nil))))))

(defn- has-after?
  "True if Context c or any of its parents has an :after function."
  [c]
  (or (:after c)
      (some has-after? (:parents c))))

(defn- close-local-contexts [contexts merged active]
  (reduce close-context merged
          ;; Only close contexts that weren't active at start:
          (filter #(not (contains? active %))
                  (reverse contexts))))

;;; Assertion types

(deftype SimpleAssertion [pred] :as this
  TestInvokable
    (invoke-test [active]
      (try
        (if (pred)
          (TestPassed this nil)
          (TestFailed this nil))
        (catch Throwable t
          (TestThrown this nil t)))))

(deftype ContextualAssertion [contexts pred] :as this
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)
            states (map merged contexts)]
        (try
         (if (apply pred states)
           (TestPassed this states)
           (TestFailed this states))
         (catch Throwable t (TestThrown this states t))
         (finally (close-local-contexts contexts merged active))))))

;;; Container types

(deftype SimpleContainer [children] :as this
  clojure.lang.IFn
    (invoke [] (invoke-test this {}))
  TestInvokable
    (invoke-test [active]
      (try
       (TestResultContainer this (map #(invoke-test % active) children))
       (catch Throwable t
         (TestThrown this nil t)))))

(deftype ContextualContainer [contexts children] :as this
  clojure.lang.IFn
    (invoke [] (invoke-test this {}))
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)]
        (try
         (let [results (map #(invoke-test % merged) children)]
           ;; Force non-lazy evaluation when contexts need closing:
           (when (some has-after? contexts) (dorun results))
           (TestResultContainer this results))
         (catch Throwable t (TestThrown this nil t))
         (finally (close-local-contexts contexts merged active))))))

;;; Public API

(defmacro is
  "A series of assertions.  Each assertion is a simple expression,
  which will be compiled into a function.  A string will be attached
  as :doc metadata on the following assertion."
  [& assertions]
  (loop [r [], as assertions]
    (if (seq as)
      (let [[doc form nxt]
            (if (string? (first as))
              [(first as) (second as) (nnext as)]
              [nil (first as) (next as)])]
        (recur (conj r `(SimpleAssertion
                         (fn [] ~form)
                         {:doc ~doc,
                          :form '~form
                          :file *file*,
                          :line ~(:line (meta form))}
                         nil))
               nxt))
      `(SimpleContainer ~r {:generator 'is
                            :line ~(:line (meta &form))
                            :file *file*
                            :form '~&form}
                        nil))))

(defmacro are
  "A series of assertions reusing a single expression.
  Creates a function of (fn argv expr).  Values will be partitioned
  into groups of the same size as argv.  The function will be applied
  to each group.

  Example:

      (are [x y z] (= (+ x y) z)
          2 2  4
          3 2  5
          8 -1 7)

      ;; Equivalent to:

      (is (= (+ 2 2) 4)
          (= (+ 3 2) 5)
          (= (+ 8 -1) 7))
"
  [argv expr & values]
  (let [argc (count argv)
        sym (gensym "f")]
    (assert (vector? argv))
    (assert (zero? (rem (count values) argc)))
    `(let [~sym (fn ~argv ~expr)]
       (SimpleContainer ~(vec (map (fn [vs]
                                     `(SimpleAssertion
                                       (fn [] (~sym ~@vs))
                                       {:form '(are ~argv ~expr ~@vs)
                                        :file *file*
                                        :line ~(some #(:line (meta %)) vs)}
                                       nil))
                                   (partition argc values)))
                        {:generator 'are
                         :file *file*
                         :line ~(:line (meta &form))
                         :form '~&form}
                        nil))))

(defmacro given
  "A series of assertions using values from contexts.
  bindings is a vector of name-value pairs, like let, where each value
  is a context created with defcontext.  A string will be attached
  as :doc metadata on the following assertion."
  [bindings & assertions]
  (assert (vector? bindings))
  (assert (even? (count bindings)))
  (let [pairs (partition 2 bindings)
        locals (vec (map first pairs))
        contexts (vec (map second pairs))]
    (loop [r [], as assertions]
      (if (seq as)
        (let [[doc form nxt]
              (if (string? (first as))
                [(first as) (second as) (nnext as)]
                [nil (first as) (next as)])]
          (recur (conj r `(ContextualAssertion
                           ~contexts
                           (fn ~locals ~form)
                           {:doc ~doc,
                            :locals '~locals
                            :form '~form
                            :file *file*,
                            :line ~(:line (meta form))}
                           nil))
                 nxt))
        `(SimpleContainer ~r {:generator 'given
                              :line ~(:line (meta &form))
                              :form '~&form}
                          nil)))))

(defn- attributes
  "Reads optional name symbol and doc string from args,
  returns [m a] where m is a map containing keys
  [:name :doc :ns :file] and a is remaining arguments."
  [args]
  (let [m {:ns *ns*, :file *file*}
        m    (if (symbol? (first args)) (assoc m :name (first args)) m)
        args (if (symbol? (first args)) (next args) args)
        m    (if (string? (first args)) (assoc m :doc (first args)) m)
        args (if (string? (first args)) (next args) args)]
    [m args]))

(defn- options
  "Reads keyword-value pairs from args, returns [m a] where m is a map
  of keyword/value options and a is remaining arguments."
  [args]
  (loop [opts {}, as args]
    (if (and (seq as) (keyword? (first as)))
      (recur (assoc opts (first as) (second as)) (nnext as))
      [opts as])))

(defmacro spec
  "Creates a test container.
  decl   => name? docstring? option* child*

  name  => a symbol, will def a Var if provided.
  child => 'is' or 'given' or nested 'spec'.

  options => keyword/value pairs, recognized keys are:
    :contexts => vector of contexts to run only once for this container.
    :strategy => a test-running strategy."
  [& decl]
  (let [[m decl] (attributes decl)
        m (assoc m :line (:line (meta &form))
                 :generator `spec
                 :form &form)
        [opts decl] (options decl)
        {:keys [contexts strategy]} opts
        children (vec decl)
        sym (gensym "c")]
    `(let [~sym ~(if contexts
                    (do (assert (vector? contexts))
                        `(ContextualContainer ~contexts ~children '~m nil))
                    `(SimpleContainer ~children '~m nil))]
       ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
       ~sym)))

(defmacro spec-do
  "Creates an assertion function consisting of arbitrary code.
  Passes if it does not throw an exception.  Use assert for value
  tests.

  decl    => name? docstring? [binding*] body*
  binding => symbol context

  name  => a symbol, will def a Var if provided.
"
  [& decl]
  (let [[m decl] (attributes decl)
        m (assoc m :line (:line (meta &form))
                 :generator `spec-do
                 :form &form)
        bindings (first decl)
        body (next decl)
        sym (gensym "c")]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (map first pairs)
          contexts (map second pairs)]
      `(let [~sym ~(if (seq contexts)
                     `(ContextualAssertion ~contexts (fn ~locals ~@body :ok)
                                           '~m nil)
                     `(SimpleAssertion (fn [] ~@body :ok) '~m nil))]
         ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
         ~sym))))

(defmacro describe
  "Attaches :spec metadata to target (a Namespace or a Var).  body is
  the same as the body of the spec macro.

  By writing (describe *ns* ...) you can attach a single top-level
  spec container to the current namespace."
  [target & body]
  `(alter-meta! ~target assoc :spec (spec ~@body)))

(defn spec?
  "Returns true if x is a spec, meaning it satisfies the TestInvokable
  protocol."
  [x] (satisfies? TestInvokable x))

(defn find-spec
  "Finds and returns a spec object for a namespace, var, collection,
  or symbol.  If x is a symbol, attempts to reload the namespace named
  by the symbol."
  [x]
  (cond (coll? x)
        (let [xs (filter identity (map find-spec x))]
          (if (seq xs)
            (SimpleContainer (vec xs)
                             {:doc "Generated from collection by find-spec."
                              :generator `find-spec}
                             nil)))

        (instance? clojure.lang.Namespace x)
        (if-let [t (:spec (meta x))]
          (find-spec t)
          (find-spec (vals (ns-interns x))))

        (var? x)
        (let [m (meta x)]
          (if-let [t (:spec m)]
            (find-spec t)
            (if-let [t (:test m)]
              (SimpleAssertion t {:doc "Generated from :test function by find-spec."
                                  :generator `find-spec
                                  :name (:name m)
                                  :ns (:ns m)
                                  :file (:file m)
                                  :line (:line m)}
                               nil)
              (let [v (var-get x)]
                (when (spec? v) v)))))

        (symbol? x)
        (find-spec (find-ns x))

        (spec? x) x

        :else nil))

(ns com.stuartsierra.lazytest)

;;; PROTOCOLS

(defprotocol TestInvokable
  (invoke-test [t active]))

(defprotocol TestResult
  (success? [r] "True if this result and all its children passed.")
  (pending? [r] "True if this is the result of an empty test.")
  (error? [r] "True if this is the result of a thrown exception.")
  (container? [r] "True if this is a container for other results."))

;;; Results

(deftype TestResultContainer [source children]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] (every? success? children))
    (pending? [] (if (seq children) false true))
    (error? [] false)
    (container? [] true))

(deftype TestPassed [source states]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] true)
    (pending? [] false)
    (error? [] false)
    (container? [] false))

(deftype TestFailed [source states]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] false)
    (pending? [] false)
    (error? [] false)
    (container? [] false))

(deftype TestThrown [source states throwable]
  clojure.lang.IPersistentMap
  TestResult
    (success? [] false)
    (pending? [] false)
    (error? [] true)
    (container? [] false))

;;; Contexts

(deftype Context [parents before after])

(defn- open-context
  "Opens context c, and all its parents, unless it is already active."
  [active c]
  (let [active (reduce open-context active (:parents c))
        states (map active (:parents c))]
    (if-let [f (:before c)]
      (assoc active c (or (active c) (apply f states)))
      active)))

(defn- close-context
  "Closes context c and removes it from active."
  [active c]
  (let [states (map active (:parents c))]
    (when-let [f (:after c)]
      (apply f (active c) states))
    (let [active (reduce close-context active (:parents c))]
      (dissoc active c))))

(defmacro defcontext
  "Defines a context.
  decl => docstring? [bindings*] before-body* after-fn?
  after-fn => :after [state] after-body*"
  [name & decl]
  (let [m {:name name, :ns *ns*, :file *file*, :line @Compiler/LINE}
        m (if (string? (first decl)) (assoc m :doc (first decl)) m)
        decl (if (string? (first decl)) (next decl) decl)
        bindings (first decl)
        bodies (next decl)]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (vec (map first pairs))
          contexts (vec (map second pairs))
          before (take-while #(not= :after %) bodies)
          after (next (drop-while #(not= :after %) bodies))
          before-fn `(fn ~locals ~@before)]
      (when after (assert (vector? (first after))))
      (let [after-fn (when after
                       `(fn ~(vec (concat (first after) locals))
                          ~@after))]
        `(def ~name (Context ~contexts ~before-fn ~after-fn '~m nil))))))

(defn- has-after?
  "True if Context c or any of its parents has an :after function."
  [c]
  (or (:after c)
      (some has-after? (:parents c))))

(defn- close-local-contexts [contexts merged active]
  (reduce close-context merged
          ;; Only close contexts that weren't active at start:
          (filter #(not (contains? active %))
                  (reverse contexts))))

;;; Assertion types

(deftype SimpleAssertion [pred] :as this
  TestInvokable
    (invoke-test [active]
      (try
        (if (pred)
          (TestPassed this nil)
          (TestFailed this nil))
        (catch Throwable t
          (TestThrown this nil t)))))

(deftype ContextualAssertion [contexts pred] :as this
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)
            states (map merged contexts)]
        (try
         (if (apply pred states)
           (TestPassed this states)
           (TestFailed this states))
         (catch Throwable t (TestThrown this states t))
         (finally (close-local-contexts contexts merged active))))))

;;; Container types

(deftype SimpleContainer [children] :as this
  clojure.lang.IFn
    (invoke [] (invoke-test this {}))
  TestInvokable
    (invoke-test [active]
      (try
       (TestResultContainer this (map #(invoke-test % active) children))
       (catch Throwable t
         (TestThrown this nil t)))))

(deftype ContextualContainer [contexts children] :as this
  clojure.lang.IFn
    (invoke [] (invoke-test this {}))
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)]
        (try
         (let [results (map #(invoke-test % merged) children)]
           ;; Force non-lazy evaluation when contexts need closing:
           (when (some has-after? contexts) (dorun results))
           (TestResultContainer this results))
         (catch Throwable t (TestThrown this nil t))
         (finally (close-local-contexts contexts merged active))))))

;;; Public API

(defmacro is
  "A series of assertions.  Each assertion is a simple expression,
  which will be compiled into a function.  A string will be attached
  as :doc metadata on the following assertion."
  [& assertions]
  (loop [r [], as assertions]
    (if (seq as)
      (let [[doc form nxt]
            (if (string? (first as))
              [(first as) (second as) (nnext as)]
              [nil (first as) (next as)])]
        (recur (conj r `(SimpleAssertion
                         (fn [] ~form)
                         {:doc ~doc,
                          :form '~form
                          :file *file*,
                          :line ~(:line (meta form))}
                         nil))
               nxt))
      `(SimpleContainer ~r {:generator 'is
                            :line ~(:line (meta &form))
                            :file *file*
                            :form '~&form}
                        nil))))

(defmacro are
  "A series of assertions reusing a single expression.
  Creates a function of (fn argv expr).  Values will be partitioned
  into groups of the same size as argv.  The function will be applied
  to each group.

  Example:

      (are [x y z] (= (+ x y) z)
          2 2  4
          3 2  5
          8 -1 7)

      ;; Equivalent to:

      (is (= (+ 2 2) 4)
          (= (+ 3 2) 5)
          (= (+ 8 -1) 7))
"
  [argv expr & values]
  (let [argc (count argv)
        sym (gensym "f")]
    (assert (vector? argv))
    (assert (zero? (rem (count values) argc)))
    `(let [~sym (fn ~argv ~expr)]
       (SimpleContainer ~(vec (map (fn [vs]
                                     `(SimpleAssertion
                                       (fn [] (~sym ~@vs))
                                       {:form '(are ~argv ~expr ~@vs)
                                        :file *file*
                                        :line ~(some #(:line (meta %)) vs)}
                                       nil))
                                   (partition argc values)))
                        {:generator 'are
                         :file *file*
                         :line ~(:line (meta &form))
                         :form '~&form}
                        nil))))

(defmacro given
  "A series of assertions using values from contexts.
  bindings is a vector of name-value pairs, like let, where each value
  is a context created with defcontext.  A string will be attached
  as :doc metadata on the following assertion."
  [bindings & assertions]
  (assert (vector? bindings))
  (assert (even? (count bindings)))
  (let [pairs (partition 2 bindings)
        locals (vec (map first pairs))
        contexts (vec (map second pairs))]
    (loop [r [], as assertions]
      (if (seq as)
        (let [[doc form nxt]
              (if (string? (first as))
                [(first as) (second as) (nnext as)]
                [nil (first as) (next as)])]
          (recur (conj r `(ContextualAssertion
                           ~contexts
                           (fn ~locals ~form)
                           {:doc ~doc,
                            :locals '~locals
                            :form '~form
                            :file *file*,
                            :line ~(:line (meta form))}
                           nil))
                 nxt))
        `(SimpleContainer ~r {:generator 'given
                              :line ~(:line (meta &form))
                              :form '~&form}
                          nil)))))

(defn- attributes
  "Reads optional name symbol and doc string from args,
  returns [m a] where m is a map containing keys
  [:name :doc :ns :file] and a is remaining arguments."
  [args]
  (let [m {:ns *ns*, :file *file*}
        m    (if (symbol? (first args)) (assoc m :name (first args)) m)
        args (if (symbol? (first args)) (next args) args)
        m    (if (string? (first args)) (assoc m :doc (first args)) m)
        args (if (string? (first args)) (next args) args)]
    [m args]))

(defn- options
  "Reads keyword-value pairs from args, returns [m a] where m is a map
  of keyword/value options and a is remaining arguments."
  [args]
  (loop [opts {}, as args]
    (if (and (seq as) (keyword? (first as)))
      (recur (assoc opts (first as) (second as)) (nnext as))
      [opts as])))

(defmacro spec
  "Creates a test container.
  decl   => name? docstring? option* child*

  name  => a symbol, will def a Var if provided.
  child => 'is' or 'given' or nested 'spec'.

  options => keyword/value pairs, recognized keys are:
    :contexts => vector of contexts to run only once for this container.
    :strategy => a test-running strategy."
  [& decl]
  (let [[m decl] (attributes decl)
        m (assoc m :line (:line (meta &form))
                 :generator `spec
                 :form &form)
        [opts decl] (options decl)
        {:keys [contexts strategy]} opts
        children (vec decl)
        sym (gensym "c")]
    `(let [~sym ~(if contexts
                    (do (assert (vector? contexts))
                        `(ContextualContainer ~contexts ~children '~m nil))
                    `(SimpleContainer ~children '~m nil))]
       ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
       ~sym)))

(defmacro spec-do
  "Creates an assertion function consisting of arbitrary code.
  Passes if it does not throw an exception.  Use assert for value
  tests.

  decl    => name? docstring? [binding*] body*
  binding => symbol context

  name  => a symbol, will def a Var if provided.
"
  [& decl]
  (let [[m decl] (attributes decl)
        m (assoc m :line (:line (meta &form))
                 :generator `spec-do
                 :form &form)
        bindings (first decl)
        body (next decl)
        sym (gensym "c")]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (map first pairs)
          contexts (map second pairs)]
      `(let [~sym ~(if (seq contexts)
                     `(ContextualAssertion ~contexts (fn ~locals ~@body :ok)
                                           '~m nil)
                     `(SimpleAssertion (fn [] ~@body :ok) '~m nil))]
         ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
         ~sym))))

(defmacro describe
  "Attaches :spec metadata to target (a Namespace or a Var).  body is
  the same as the body of the spec macro.

  By writing (describe *ns* ...) you can attach a single top-level
  spec container to the current namespace."
  [target & body]
  `(alter-meta! ~target assoc :spec (spec ~@body)))

(defn spec?
  "Returns true if x is a spec, meaning it satisfies the TestInvokable
  protocol."
  [x] (satisfies? TestInvokable x))

(defn find-spec
  "Finds and returns a spec object for a namespace, var, collection,
  or symbol.  If x is a symbol, attempts to reload the namespace named
  by the symbol."
  [x]
  (cond (spec? x) x

        (coll? x)
        (let [xs (filter identity (map find-spec x))]
          (if (seq xs)
            (SimpleContainer (vec xs)
                             {:doc "Generated from collection by find-spec."
                              :generator `find-spec}
                             nil)))

        (instance? clojure.lang.Namespace x)
        (if-let [t (:spec (meta x))]
          (find-spec t)
          ;; Omit the *1/*2/*3 REPL vars, in case they are specs:
          (find-spec (filter #(not (#{#'*1 #'*2 #'*3} %))
                             (vals (ns-interns x)))))

        (var? x)
        (let [m (meta x)]
          (if-let [t (:spec m)]
            (find-spec t)
            (if-let [t (:test m)]
              (SimpleAssertion t {:doc "Generated from :test function by find-spec."
                                  :generator `find-spec
                                  :name (:name m)
                                  :ns (:ns m)
                                  :file (:file m)
                                  :line (:line m)}
                               nil)
              (let [v (try (var-get x) (catch Exception e nil))]
                (when (spec? v) v)))))

        (symbol? x)
        (find-spec (find-ns x))

        :else nil))

Handle *1/2/3 vars and unbound vars in find-spec


(ns stl-collector.core-test
  (:require [clojure.test :refer :all]
            [stl-collector.reader :as r]
            [stl-collector.writer :as w]
            [nio.core :as nio]
            [clojure.java.io :as io])
  (:import (java.nio ByteOrder)
           (java.io File)))

(deftest test-rw-float
  (testing "Can read and write floats"
    (let [f (java.io.File/createTempFile "test-rw-float" nil)
          v (float 3.141592)
          float_size_bytes 4
          offset 0]
      (let [buffer (doto
                       (nio.core/mmap f offset float_size_bytes)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (.putFloat buffer v))
      (let [buffer (doto
                       (nio.core/mmap f)
                     (.order ByteOrder/LITTLE_ENDIAN))]

        (is (= v (.getFloat buffer)))))))

(deftest test-rw-pad
  (testing "can add padding before and after a float"
    (let [f (java.io.File/createTempFile "test-rw-pad" nil)
          v (float 3.141592)
          total_file_size 7
          offset 0]
      (let [buffer (doto
                       (nio.core/mmap f offset total_file_size)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (.put buffer (byte 0))
        (.put buffer (byte 0))
        (.putFloat buffer v)
        (.put buffer (byte 0)))

      (let [buffer (doto
                       (nio.core/mmap f)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (doseq [_ (range 2)]
          (.get buffer))

        (is (= v (.getFloat buffer)))))))

(deftest test-rw-stl-file
  (testing "can read and write a real file"
    (let [tmp-file (File/createTempFile "bob" ".stl")
          real-file (->> "stl/Creeper.stl"
                         io/resource
                         io/file)
          read-file (r/read-stl real-file)
          write-file (w/write-stl read-file tmp-file)
          new-read-file (r/read-stl tmp-file)]
      (= read-file new-read-file))))

(ns stl-collector.core-test
  (:require [clojure.test :refer :all]
            [stl-collector.reader :as r]
            [stl-collector.writer :as w]
            [nio.core :as nio]
            [clojure.java.io :as io])
  (:import (java.nio ByteOrder)
           (java.io File)))

(deftest test-rw-float
  (testing "Can read and write floats"
    (let [f (java.io.File/createTempFile "test-rw-float" nil)
          v (float 3.141592)
          float_size_bytes 4
          offset 0]
      (let [buffer (doto
                       (nio.core/mmap f offset float_size_bytes)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (.putFloat buffer v))
      (let [buffer (doto
                       (nio.core/mmap f)
                     (.order ByteOrder/LITTLE_ENDIAN))]

        (is (= v (.getFloat buffer)))))))

(deftest test-rw-pad
  (testing "can add padding before and after a float"
    (let [f (java.io.File/createTempFile "test-rw-pad" nil)
          v (float 3.141592)
          total_file_size 7
          offset 0]
      (let [buffer (doto
                       (nio.core/mmap f offset total_file_size)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (.put buffer (byte 0))
        (.put buffer (byte 0))
        (.putFloat buffer v)
        (.put buffer (byte 0)))

      (let [buffer (doto
                       (nio.core/mmap f)
                     (.order ByteOrder/LITTLE_ENDIAN))]
        (doseq [_ (range 2)]
          (.get buffer))

        (is (= v (.getFloat buffer)))))))

(deftest test-rw-stl-file
  (testing "can read and write a real file"
    (let [tmp-file (File/createTempFile "bob" ".stl")
          real-file (->> "stl/Creeper.stl"
                         io/resource
                         io/file)
          read-file (r/read-stl real-file)
          write-file (w/write-stl read-file tmp-file)
          new-read-file (r/read-stl tmp-file)]
      (= read-file new-read-file)
      (.delete tmp-file))))

delete dangling temporary file

delete dangling temporary file


{:user {:dependencies [[clj-stacktrace "0.2.5"]
                       [org.clojure/tools.trace "0.7.5"]
                       [org.clojure/tools.namespace "0.2.3"]
                       [redl "0.1.0"]
                       [spyscope "0.1.3"]
                       [slamhound "1.3.3"]]
        :plugins [[lein-difftest "1.3.7"]
                  [lein-drip "0.1.1-SNAPSHOT"]
                  [lein-exec "0.3.0"]
                  [lein-clojars "0.9.1"]
                  [lein-pprint "1.1.1"]
                  [lein-ring "0.8.0"]
                  [lein-cljsbuild "0.1.9"]
                  [lein-deps-tree "0.1.2"]
                  [lein-marginalia "0.7.1"]]
        :repl-options {:timeout 120000}
        :injections [(require '[redl core complete])
                     (require 'spyscope.core)
                     (require 'clojure.tools.namespace)
                     (let [orig (ns-resolve (doto 'clojure.stacktrace require)
                                            'print-cause-trace)
                           new (ns-resolve (doto 'clj-stacktrace.repl require)
                                           'pst)]
                       (alter-var-root orig (constantly @new)))]
        :vimclojure-opts {:repl true}}}

{:user {:dependencies [[clj-stacktrace "0.2.5"]
                       [org.clojure/tools.trace "0.7.5"]
                       [org.clojure/tools.namespace "0.2.3"]
                       [redl "0.1.0"]
                       [speclj-tmux "1.0.0"]
                       [spyscope "0.1.3"]
                       [slamhound "1.3.3"]]
        :plugins [[lein-difftest "1.3.7"]
                  [lein-drip "0.1.1-SNAPSHOT"]
                  [lein-exec "0.3.0"]
                  [lein-clojars "0.9.1"]
                  [lein-pprint "1.1.1"]
                  [lein-ring "0.8.0"]
                  [lein-cljsbuild "0.1.9"]
                  [lein-deps-tree "0.1.2"]
                  [lein-marginalia "0.7.1"]]
        :repl-options {:timeout 120000}
        :injections [(require '[redl core complete])
                     (require 'spyscope.core)
                     (require 'clojure.tools.namespace)
                     (let [orig (ns-resolve (doto 'clojure.stacktrace require)
                                            'print-cause-trace)
                           new (ns-resolve (doto 'clj-stacktrace.repl require)
                                           'pst)]
                       (alter-var-root orig (constantly @new)))]
        :vimclojure-opts {:repl true}}}

Add speclj-tmux to lein user profile.

Add speclj-tmux to lein user profile.


{:user {:plugins [[lein-cloverage                    "1.0.9"]
                  [lein-fore-prob                    "0.1.2"]

                  ; Check for outdated dependencies
                  [lein-ancient                      "0.6.14"]

                  ;; lein-test when something changes
                  [com.jakemccrary/lein-test-refresh "0.21.1"]

                  [lein-figwheel                     "0.5.10"]
                  [venantius/ultra                   "0.5.1"]]

        :dependencies [[org.clojure/tools.namespace  "0.2.11"]

                       ;; Inject symbols in the REPL's global ns
                       ;; http://dev.solita.fi/2014/03/18/pimp-my-repl.html
                       ;; http://docs.caudate.me/lucidity/lucid-core.html#core-inject
                       [im.chit/lucid.core.inject    "1.3.9"]]

        :ultra {:stacktraces false ; don't break my stacktraces thanks
                :repl {:sort-keys false ; don't sort collections before printing
                       }}

        :injections [(require 'lucid.core.inject)
                     (lucid.core.inject/in
                       ;; help function
                       [clojure.repl :refer [doc]]

                       ;; Refresh namespaces without reloading the REPL
                       [clojure.tools.namespace.repl :refer [refresh]])]

        :signing {:gpg-key "E5B26621"}}}

{:user {:plugins [[lein-cloverage                    "1.0.9"]
                  [lein-fore-prob                    "0.1.2"]

                  ; Check for outdated dependencies
                  [lein-ancient                      "0.6.15"]

                  ;; lein-test when something changes
                  [com.jakemccrary/lein-test-refresh "0.21.1"]

                  [lein-figwheel                     "0.5.10"]
                  [venantius/ultra                   "0.5.1"]]

        :dependencies [[org.clojure/tools.namespace  "0.2.11"]

                       ;; Inject symbols in the REPL's global ns
                       ;; http://dev.solita.fi/2014/03/18/pimp-my-repl.html
                       ;; http://docs.caudate.me/lucidity/lucid-core.html#core-inject
                       [im.chit/lucid.core.inject    "1.3.9"]]

        :ultra {:stacktraces false ; don't break my stacktraces thanks
                :repl {:sort-keys false ; don't sort collections before printing
                       }}

        :injections [(require 'lucid.core.inject)
                     (lucid.core.inject/in
                       ;; help function
                       [clojure.repl :refer [doc]]

                       ;; Refresh namespaces without reloading the REPL
                       [clojure.tools.namespace.repl :refer [refresh]])]

        :signing {:gpg-key "E5B26621"}}}

bump lein-ancient

[lein] bump lein-ancient


(ns chapter4.linneus
  (:refer chapter3.match :only [match match-state atom?])
  (:refer clojure.test :only [with-test is run-tests]))
;TODO: This is probably wrong -- should be locally scoped inside the conversation loop
(def isa (atom {}))
(def includes (atom {}))
(with-test
  (defn add-to-list [aname x d]
    (if (d aname)
      (update-in d [aname] conj x)
      (conj d [aname #{x}])))
  (is (= {'a #{1}} (add-to-list 'a 1 {})))
  (is (= {'a #{1 2}} (add-to-list 'a 2 {'a #{1}}))))
(with-test
  (defn isa-test [isa x y n]
    (if (zero? n)
      false
      (or (= x y)
          (contains? (isa x) y)
          (some (fn [xx] (isa-test isa xx y (dec n))) (isa x)))))
  (is (isa-test {} 'dog 'dog 100))
  (is (not (isa-test {} 'dog 'cat 100)))
  (is (isa-test {'dog #{'mammal}} 'dog 'mammal 100))
  (is (not (isa-test {'d #{'mammal}} 'dog 'bug 100)))
  (is (isa-test {'dog #{'mammal} 'mammal #{'animal}} 'dog 'animal 2))
  (is (not (isa-test {'dog #{'mammal} 'mammal #{'animal}} 'dog 'animal 1))))
(with-test
  (defn article? [article]
    (contains? #{'a 'an 'the 'that 'this 'those 'these} article))
  (is (article? 'a))
  (is (not (article? 'wat))))
(defn case-match [text cases]
  (loop [cases cases]
    (if (empty? cases)
      (do (println "I do not understand.") ['error {} {} {}])
      (let [[patterns f] (first cases)]
        (if-let [d (some #(match % text) patterns)]
          (f d)
          (recur (rest cases)))))))
(defn chain-interpret [utterances]
  (loop [utterances utterances ds ['start {} {} {}]]
    (if (empty? utterances)
      ds
      (recur (rest utterances)
             (apply interpret (first utterances) (rest ds))))))
(with-test
  (defn make-conj [l article]
    (cond
      (empty? l) nil
      (empty? (rest l)) (cons (article (first l)) l)
      :else (concat (list (article (first l)) (first l) 'and) (make-conj (rest l) article))))
  (is (= nil (make-conj (list) '{dog a})))
  (is (= '(a dog) (make-conj '(dog) '{dog a})))
  (is (= '(a dog and an animal) (make-conj '(dog animal) '{dog a animal an}))))
(defn tell [article x y]
  (list (article x) x 'is (article y) y))
(defn explain-chain [isa article x l y]
  (cond
    (empty? l) nil
    (contains? l y) (cons 'and (tell article x y))
    (isa-test isa (first l) y 10)
    (concat (tell article x (first l))
            (explain-chain isa article (first l) (isa (first l)) y))
    :else (explain-chain isa article x (rest l) y)))
(with-test
  (defn explain-links [isa article x y]
    (cond
      (= x y) "They are identical"
      (contains? (isa x) y) "You told me"
      :else (explain-chain isa article x (isa x) y)))
  (is (= "They are identical" (explain-links {} {} 'dog 'dog)))
  (is (= "You told me" (explain-links '{dog #{animal}} '{dog a} 'dog 'animal)))
  (is (= '(a dog is a mammal and a mammal is an animal) (explain-links '{dog #{mammal} mammal #{animal}} '{dog a, mammal a, animal an} 'dog 'animal))))
(with-test
  (defn interpret [text isa includes article]
    (case-match
     text
     [['(((article? article1) (? x) is (article? article2) (? y)))
       (fn [d]
         (println "I understand.")
         ['add-fact (add-to-list (d 'x) (d 'y) isa) (add-to-list (d 'y) (d 'x) includes) (assoc article (d 'x) (d 'article1) (d 'y) (d 'article2))])]
      ['((what is (? x)) (what is (article? article1) (? x)))
       (fn [d]
         (let [y (or (isa (d 'x)) (includes (d 'x)))
               flag (cond (isa (d 'x)) 'isa (includes (d 'x)) 'includes :else 'dunno)]
           (if (= flag 'dunno)
             (println "I don't know.")
             (println (article (d 'x)) (d 'x)
                      (cond (= flag 'isa) "is" (= flag 'includes) "is something more general than")
                      (make-conj y article)))
           [flag isa includes article]))]
      ['((is (article? article1) (? x) (article? article2) (? y)))
       (fn [d]
         (let [flag
               (if (isa-test isa (d 'x) (d 'y) 10)
                 (do (println "Yes indeed," (article 'x) (d 'x) "is" (article 'y) (d 'y)) 'is-indeed)
                 (do (println "Sorry, not that I know of.") 'is-not))]
           [flag isa includes article]))]
      ['((why is (article? article1) (? x) (article? article2) (? y)))
       (fn [d]
         (let [flag
               (if (isa-test isa (d 'x) (d 'y) 10)
                 (do (println "Because" (explain-links isa article (d 'x) (d 'y))) 'because)
                 (do (println "But it's not!") 'its-not))]
           [flag isa includes article]))]
      ['((bye) (goodbye))
       (fn [d] ['bye isa includes article])]]))
  (is (= '[add-fact
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal)))))
  (is (= '[add-fact
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal)))))
  (is (= '[includes
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal) (what is an animal)))))
  (is (= '[dunno
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal) (what is a wombat)))))
  (is (= '[isa
           {dog #{animal friend}}
           {animal #{dog} friend #{dog}}
           {dog a, animal an, friend a}]
         (chain-interpret '((a dog is an animal) (a dog is a friend) (what is a dog)))))
  (is (= '[because
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal) (why is a dog an animal)))))
  (is (= '[its-not
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal) (why is a wombat an animal))))))

(defn linneus []
  (println "This is Linneus. Please talk to me.")
  (loop [isa {} includes {} article {}]
    (println "--> ")
    (let [[result isa includes article] (interpret (read))]
      (if (= result 'bye)
        'goodbye
        (recur isa includes article)))))

(ns chapter4.linneus
  (:refer chapter3.match :only [match match-state atom?])
  (:refer clojure.test :only [with-test is run-tests]))
(with-test
  (defn add-to-list [aname x d]
    (if (d aname)
      (update-in d [aname] conj x)
      (conj d [aname #{x}])))
  (is (= {'a #{1}} (add-to-list 'a 1 {})))
  (is (= {'a #{1 2}} (add-to-list 'a 2 {'a #{1}}))))
(with-test
  (defn isa-test [isa x y n]
    (if (zero? n)
      false
      (or (= x y)
          (contains? (isa x) y)
          (some (fn [xx] (isa-test isa xx y (dec n))) (isa x)))))
  (is (isa-test {} 'dog 'dog 100))
  (is (not (isa-test {} 'dog 'cat 100)))
  (is (isa-test {'dog #{'mammal}} 'dog 'mammal 100))
  (is (not (isa-test {'d #{'mammal}} 'dog 'bug 100)))
  (is (isa-test {'dog #{'mammal} 'mammal #{'animal}} 'dog 'animal 2))
  (is (not (isa-test {'dog #{'mammal} 'mammal #{'animal}} 'dog 'animal 1))))
(with-test
  (defn article? [article]
    (contains? #{'a 'an 'the 'that 'this 'those 'these} article))
  (is (article? 'a))
  (is (not (article? 'wat))))
(defn case-match [text cases]
  (loop [cases cases]
    (if (empty? cases)
      (do (println "I do not understand.") ['error {} {} {}])
      (let [[patterns f] (first cases)]
        (if-let [d (some #(match % text) patterns)]
          (f d)
          (recur (rest cases)))))))
(defn chain-interpret [utterances]
  (loop [utterances utterances ds ['start {} {} {}]]
    (if (empty? utterances)
      ds
      (recur (rest utterances)
             (apply interpret (first utterances) (rest ds))))))
(with-test
  (defn make-conj [l article]
    (cond
      (empty? l) nil
      (empty? (rest l)) (cons (article (first l)) l)
      :else (concat (list (article (first l)) (first l) 'and) (make-conj (rest l) article))))
  (is (= nil (make-conj (list) '{dog a})))
  (is (= '(a dog) (make-conj '(dog) '{dog a})))
  (is (= '(a dog and an animal) (make-conj '(dog animal) '{dog a animal an}))))
(defn tell [article x y]
  (list (article x) x 'is (article y) y))
(defn explain-chain [isa article x l y]
  (cond
    (empty? l) nil
    (contains? l y) (cons 'and (tell article x y))
    (isa-test isa (first l) y 10)
    (concat (tell article x (first l))
            (explain-chain isa article (first l) (isa (first l)) y))
    :else (explain-chain isa article x (rest l) y)))
(with-test
  (defn explain-links [isa article x y]
    (cond
      (= x y) "They are identical"
      (contains? (isa x) y) "You told me"
      :else (explain-chain isa article x (isa x) y)))
  (is (= "They are identical" (explain-links {} {} 'dog 'dog)))
  (is (= "You told me" (explain-links '{dog #{animal}} '{dog a} 'dog 'animal)))
  (is (= '(a dog is a mammal and a mammal is an animal) (explain-links '{dog #{mammal} mammal #{animal}} '{dog a, mammal a, animal an} 'dog 'animal))))
(with-test
  (defn interpret [text isa includes article]
    (case-match
     text
     [['(((article? article1) (? x) is (article? article2) (? y)))
       (fn [d]
         (println "I understand.")
         ['add-fact (add-to-list (d 'x) (d 'y) isa) (add-to-list (d 'y) (d 'x) includes) (assoc article (d 'x) (d 'article1) (d 'y) (d 'article2))])]
      ['((what is (? x)) (what is (article? article1) (? x)))
       (fn [d]
         (let [y (or (isa (d 'x)) (includes (d 'x)))
               flag (cond (isa (d 'x)) 'isa (includes (d 'x)) 'includes :else 'dunno)]
           (if (= flag 'dunno)
             (println "I don't know.")
             (println (article (d 'x)) (d 'x)
                      (cond (= flag 'isa) "is" (= flag 'includes) "is something more general than")
                      (make-conj y article)))
           [flag isa includes article]))]
      ['((is (article? article1) (? x) (article? article2) (? y)))
       (fn [d]
         (let [flag
               (if (isa-test isa (d 'x) (d 'y) 10)
                 (do (println "Yes indeed," (article 'x) (d 'x) "is" (article 'y) (d 'y)) 'is-indeed)
                 (do (println "Sorry, not that I know of.") 'is-not))]
           [flag isa includes article]))]
      ['((why is (article? article1) (? x) (article? article2) (? y)))
       (fn [d]
         (let [flag
               (if (isa-test isa (d 'x) (d 'y) 10)
                 (do (println "Because" (explain-links isa article (d 'x) (d 'y))) 'because)
                 (do (println "But it's not!") 'its-not))]
           [flag isa includes article]))]
      ['((bye) (goodbye))
       (fn [d] ['bye isa includes article])]]))
  (is (= '[add-fact
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal)))))
  (is (= '[add-fact
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal)))))
  (is (= '[includes
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal) (what is an animal)))))
  (is (= '[dunno
           {dog #{animal}}
           {animal #{dog}}
           {dog a, animal an}]
         (chain-interpret '((a dog is an animal) (what is a wombat)))))
  (is (= '[isa
           {dog #{animal friend}}
           {animal #{dog} friend #{dog}}
           {dog a, animal an, friend a}]
         (chain-interpret '((a dog is an animal) (a dog is a friend) (what is a dog)))))
  (is (= '[because
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal) (why is a dog an animal)))))
  (is (= '[its-not
           {dog #{mammal} mammal #{animal}}
           {mammal #{dog} animal #{mammal}}
           {dog a, animal an, mammal a}]
         (chain-interpret '((a mammal is an animal) (a dog is a mammal) (why is a wombat an animal))))))

(defn linneus []
  (println "This is Linneus. Please talk to me.")
  (loop [isa {} includes {} article {}]
    (println "--> ")
    (let [[result isa includes article] (interpret (read))]
      (if (= result 'bye)
        'goodbye
        (recur isa includes article)))))

Remove linneus globals (unused)

Remove linneus globals (unused)


(ns frontend.components.build-head
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [put!]]
            [frontend.datetime :as datetime]
            [frontend.models.build :as build-model]
            [frontend.components.builds-table :as builds-table]
            [frontend.components.common :as common]
            [frontend.components.forms :as forms]
            [frontend.utils :as utils :include-macros true]
            [goog.string :as gstring]
            goog.string.format
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true])
  (:require-macros [frontend.utils :refer [html]]))

(defn build-queue [data owner]
  (reify
    om/IRender
    (render [_]
      (let [{:keys [build builds]} data
            controls-ch (om/get-shared owner [:comms :controls])
            run-queued? (build-model/in-run-queue? build)
            usage-queued? (build-model/in-usage-queue? build)]
        (html
         (if-not builds
           [:div.loading-spinner common/spinner]
           [:div
            (when-not usage-queued?
              [:p (str "Circle "
                       (when run-queued? "has") " spent "
                       (if run-queued?
                         (om/build common/updating-duration (:queued_at build))
                         (datetime/as-duration (build-model/run-queued-time build)))
                       " acquiring containers for this build")])

            (when (seq builds)
              ;; XXX this could still use some work
              (list
               [:p "This build " (if usage-queued? "has been" "was")
                " queued behind the following builds for "
                (if usage-queued?
                  (om/build common/updating-duration (:usage_queued_at build))
                  (build-model/usage-queued-time build))]

               (om/build builds-table/builds-table builds {:opts {:show-actions? true}})))]))))))

(defn commit-line [{:keys [subject body commit_url commit] :as commit-details}]
  [:div
   ;; XXX add tooltips
   [:span {:title body}
    subject " "]
   [:a.sha-one {:href commit_url
                :title commit}
    (subs commit 0 7)
    [:i.fa.fa-github]]])

(defn build-commits [build owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            build-id (build-model/id build)]
        (html
         [:section.build-commits {:class (when (:show-all-commits build) "active")}
          [:div.build-commits-title
           [:strong "Commit Log"]
           (when (:compare build)
             [:a.compare {:href (:compare build)}
              "compare"
              [:i.fa.fa-github]])
           (when (< 3 (count (:all_commit_details build)))
             [:a {:role "button"
                  :on-click #(put! controls-ch [:toggle-show-all-commits build-id])}
              (str (- (count (:all_commit_details build)) 3) " more ")
              [:i.fa.fa-caret-down]])]
          [:div.build-commits-list
           (if-not (seq (:all_commit_details build))
             (commit-line {:subject (:subject build)
                           :body (:body build)
                           :commit_url (build-model/github-commit-url build)
                           :commit (:vcs_revision build)})
             (list
              (map commit-line (take 3 (:all_commit_details build)))
              (when (:show-all-commits build)
                (map commit-line (drop 3 (:all_commit_details build))))))]])))))

(defn build-ssh [nodes owner]
  (reify
    om/IRender
    (render [_]
      (html
       [:section.build-ssh
        [:div.build-ssh-title
         [:strong "SSH Info "]
         [:i.fa.fa-question-circle
          ;; XXX popovers
          {:title "You can SSH into this build. Use the same SSH public key that you use for GitHub. SSH boxes will stay up for 30 minutes. This build takes up one of your concurrent builds, so cancel it when you are done."}]]
        [:div.build-ssh-list
         [:dl.dl-horizontal
          (map (fn [node]
                 (list
                  [:dt (when (> 1 (count nodes)) [:span (:index node)])]
                  [:dd {:class (when (:ssh_enabled node) "connected")}
                   [:span (gstring/format "ssh -p %s %s@%s " (:port node) (:username node) (:ip_addr node))]
                   (when-not (:ssh_enabled node)
                     [:span.loading-spinner common/spinner])]))
               nodes)]]
        [:div.build-ssh-doc
         "Debugging Selenium browser tests? "
         [:a {:href "/docs/browser-debugging#interact-with-the-browser-over-vnc"}
          "Read our doc on interacting with the browser over VNC"]
         "."]]))))

(defn build-artifacts-list [artifacts-data owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            artifacts (:artifacts artifacts-data)
            show-artifacts (:show-artifacts artifacts-data)]
        (html
         [:section.build-artifacts {:class (when show-artifacts "active")}
          [:div.build-artifacts-title
           [:strong "Build Artifacts"]
           [:a {:role "button"
                :on-click #(put! controls-ch [:show-artifacts-toggled])}
            [:span " view "]
            [:i.fa.fa-caret-down {:class (when show-artifacts "fa-rotate-180")}]]]
          (when show-artifacts
            (if-not artifacts
              [:div.loading-spinner common/spinner]

              [:ol.build-artifacts-list
               (map (fn [artifact]
                      [:li
                       [:a {:href (:url artifact) :target "_blank"}
                        (:pretty_path artifact)]])
                    artifacts)]))])))))

(defn build-head [build-data owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            build (:build build-data)
            build-id (build-model/id build)
            build-num (:build_num build)
            vcs-url (:vcs_url build)
            usage-queue-data (:usage-queue-data build-data)
            run-queued? (build-model/in-run-queue? build)
            usage-queued? (build-model/in-usage-queue? build)]
        (html
         [:div.build-head-wrapper
          [:div.build-head
           [:div.build-info
            [:table
             [:tbody
              [:tr
               [:th "Author"]
               [:td (if-not (:author_email build)
                      [:span (build-model/author build)]
                      [:a {:href (str "mailto:" (:author_email build))}
                       (build-model/author build)])]
               [:th "Started"]
               [:td (om/build common/updating-duration (:start_time build) {:opts {:formatter datetime/time-ago}}) " ago"]]
              [:tr
               [:th "Trigger"]
               [:td (build-model/why-in-words build)]
               [:th "Duration"]
               [:td (if (build-model/running? build)
                      (om/build common/updating-duration (:start_time build))
                      (build-model/duration build))]]
              [:tr
               [:th "Previous"]
               (if-not (:previous_build build)
                 [:td "none"]
                 [:td
                  [:a {:href (build-model/path-for (select-keys build [:vcs_url])
                                                   (assoc build :build_num (:previous_build build)))}
                   (:previous_build build)]])
               [:th "Status"]
               [:td
                [:span.build-status {:class (:status build)}
                 (build-model/status-words build)]]]
              [:tr
               (when (:usage_queued_at build)
                 (list [:th "Queued"]
                       [:td (if (< 0 (build-model/run-queued-time build))
                              [:span
                               (if usage-queued?
                                 (om/build common/updating-duration (:usage_queued_at build))
                                 (datetime/as-duration (build-model/usage-queued-time build)))
                               " waiting + "
                               (if run-queued?
                                 (om/build common/updating-duration (:queued_at build))
                                 (datetime/as-duration (build-model/run-queued-time build)))
                               " in queue"]

                              [:span
                               (if usage-queued?
                                 (om/build common/updating-duration (:usage_queued_at build))
                                 (datetime/as-duration (build-model/usage-queued-time build)))
                               " waiting for builds to finish"])

                        [:a#queued_explanation
                         {:on-click #(put! controls-ch [:usage-queue-why-toggled
                                                        {:build-id build-id
                                                         :username (:username @build)
                                                         :reponame (:reponame @build)
                                                         :build_num (:build_num @build)}])}
                         " view "]
                        [:i.fa.fa-caret-down {:class (when (:show-usage-queue usage-queue-data) "fa-rotate-180")}]]))
               (when (build-model/author-isnt-committer build)
                 [:th "Committer"]
                 [:td
                  (if-not (:committer_email build)
                    [:span (build-model/committer build)]
                    [:a {:href (str "mailto:" (:committer_email build))}
                     (build-model/committer build)])])]
              [:tr
               [:th "Parallelism"]
               [:td
                [:a {:title (str "This build used " (:parallel build) " containers. Click here to change parallelism for future builds.")
                     :href (build-model/path-for-parallelism build)}
                 (str (:parallel build) "x")]]]]]
            [:div.build-actions
             (forms/stateful-button
              [:button.retry_build
               {:data-loading-text "Rebuilding",
                :title "Retry the same tests",
                :on-click #(put! controls-ch [:retry-build-clicked {:build-id build-id
                                                                    :vcs-url vcs-url
                                                                    :build-num build-num
                                                                    :clear-cache? false}])}
               "Rebuild"])
             (forms/stateful-button
              [:button.clear_cache_retry
               {:data-loading-text "Rebuilding",
                :title "Clear cache and retry",
                :on-click #(put! controls-ch [:retry-build-clicked {:build-id build-id
                                                                    :vcs-url vcs-url
                                                                    :build-num build-num
                                                                    :clear-cache? true}])}
               "w/ cleared cache"])

             (forms/stateful-button
              [:button.ssh_build
               {:data-loading-text "Rebuilding",
                :title "Retry with SSH in VM",
                :on-click #(put! controls-ch [:ssh-build-clicked build-id])}
               "w/ ssh enabled"])
             [:button.report_build
              {:title "Report error with build",
               :on-click #(put! controls-ch [:report-build-clicked {:build-url (:build_url @build)}])}
              "Report"]
             (when (build-model/can-cancel? build)
               (forms/stateful-button
                [:button.cancel_build
                 {:data-loading-text "Canceling",
                  :title "Cancel this build",
                  :on-click #(put! controls-ch [:cancel-build-clicked {:build-id build-id
                                                                       :vcs-url vcs-url
                                                                       :build-num build-num}])}
                 "Cancel"]))]]
           (when (:show-usage-queue usage-queue-data)
             (om/build build-queue {:build build
                                    :builds (:builds usage-queue-data)}))
           (when (:subject build)
             (om/build build-commits build))
           (when (build-model/ssh-enabled-now? build)
             (om/build build-ssh (:node build)))
           (when (:has_artifacts build)
             (om/build build-artifacts-list (get build-data :artifacts-data)))]])))))

(ns frontend.components.build-head
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [put!]]
            [frontend.datetime :as datetime]
            [frontend.models.build :as build-model]
            [frontend.components.builds-table :as builds-table]
            [frontend.components.common :as common]
            [frontend.components.forms :as forms]
            [frontend.utils :as utils :include-macros true]
            [goog.string :as gstring]
            goog.string.format
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true])
  (:require-macros [frontend.utils :refer [html]]))

(defn build-queue [data owner]
  (reify
    om/IRender
    (render [_]
      (let [{:keys [build builds]} data
            controls-ch (om/get-shared owner [:comms :controls])
            run-queued? (build-model/in-run-queue? build)
            usage-queued? (build-model/in-usage-queue? build)]
        (html
         (if-not builds
           [:div.loading-spinner common/spinner]
           [:div
            (when-not usage-queued?
              [:p (str "Circle "
                       (when run-queued? "has") " spent "
                       (if run-queued?
                         (om/build common/updating-duration (:queued_at build))
                         (datetime/as-duration (build-model/run-queued-time build)))
                       " acquiring containers for this build")])

            (when (seq builds)
              ;; XXX this could still use some work
              (list
               [:p "This build " (if usage-queued? "has been" "was")
                " queued behind the following builds for "
                (if usage-queued?
                  (om/build common/updating-duration (:usage_queued_at build))
                  (build-model/usage-queued-time build))]

               (om/build builds-table/builds-table builds {:opts {:show-actions? true}})))]))))))

(defn commit-line [{:keys [subject body commit_url commit] :as commit-details}]
  [:div
   ;; XXX add tooltips
   [:span {:title body}
    subject " "]
   [:a.sha-one {:href commit_url
                :title commit}
    (subs commit 0 7)
    [:i.fa.fa-github]]])

(defn build-commits [build owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            build-id (build-model/id build)]
        (html
         [:section.build-commits {:class (when (:show-all-commits build) "active")}
          [:div.build-commits-title
           [:strong "Commit Log"]
           (when (:compare build)
             [:a.compare {:href (:compare build)}
              "compare"
              [:i.fa.fa-github]])
           (when (< 3 (count (:all_commit_details build)))
             [:a {:role "button"
                  :on-click #(put! controls-ch [:toggle-show-all-commits build-id])}
              (str (- (count (:all_commit_details build)) 3) " more ")
              [:i.fa.fa-caret-down]])]
          [:div.build-commits-list
           (if-not (seq (:all_commit_details build))
             (commit-line {:subject (:subject build)
                           :body (:body build)
                           :commit_url (build-model/github-commit-url build)
                           :commit (:vcs_revision build)})
             (list
              (map commit-line (take 3 (:all_commit_details build)))
              (when (:show-all-commits build)
                (map commit-line (drop 3 (:all_commit_details build))))))]])))))

(defn build-ssh [nodes owner]
  (reify
    om/IRender
    (render [_]
      (html
       [:section.build-ssh
        [:div.build-ssh-title
         [:strong "SSH Info "]
         [:i.fa.fa-question-circle
          ;; XXX popovers
          {:title "You can SSH into this build. Use the same SSH public key that you use for GitHub. SSH boxes will stay up for 30 minutes. This build takes up one of your concurrent builds, so cancel it when you are done."}]]
        [:div.build-ssh-list
         [:dl.dl-horizontal
          (map (fn [node]
                 (list
                  [:dt (when (> 1 (count nodes)) [:span (:index node)])]
                  [:dd {:class (when (:ssh_enabled node) "connected")}
                   [:span (gstring/format "ssh -p %s %s@%s " (:port node) (:username node) (:ip_addr node))]
                   (when-not (:ssh_enabled node)
                     [:span.loading-spinner common/spinner])]))
               nodes)]]
        [:div.build-ssh-doc
         "Debugging Selenium browser tests? "
         [:a {:href "/docs/browser-debugging#interact-with-the-browser-over-vnc"}
          "Read our doc on interacting with the browser over VNC"]
         "."]]))))

(defn build-artifacts-list [artifacts-data owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            artifacts (:artifacts artifacts-data)
            show-artifacts (:show-artifacts artifacts-data)]
        (html
         [:section.build-artifacts {:class (when show-artifacts "active")}
          [:div.build-artifacts-title
           [:strong "Build Artifacts"]
           [:a {:role "button"
                :on-click #(put! controls-ch [:show-artifacts-toggled])}
            [:span " view "]
            [:i.fa.fa-caret-down {:class (when show-artifacts "fa-rotate-180")}]]]
          (when show-artifacts
            (if-not artifacts
              [:div.loading-spinner common/spinner]

              [:ol.build-artifacts-list
               (map (fn [artifact]
                      [:li
                       [:a {:href (:url artifact) :target "_blank"}
                        (:pretty_path artifact)]])
                    artifacts)]))])))))

(defn build-head [build-data owner]
  (reify
    om/IRender
    (render [_]
      (let [controls-ch (om/get-shared owner [:comms :controls])
            build (:build build-data)
            build-id (build-model/id build)
            build-num (:build_num build)
            vcs-url (:vcs_url build)
            usage-queue-data (:usage-queue-data build-data)
            run-queued? (build-model/in-run-queue? build)
            usage-queued? (build-model/in-usage-queue? build)]
        (html
         [:div.build-head-wrapper
          [:div.build-head
           [:div.build-info
            [:table
             [:tbody
              [:tr
               [:th "Author"]
               [:td (if-not (:author_email build)
                      [:span (build-model/author build)]
                      [:a {:href (str "mailto:" (:author_email build))}
                       (build-model/author build)])]
               [:th "Started"]
               [:td (om/build common/updating-duration (:start_time build) {:opts {:formatter datetime/time-ago}}) " ago"]]
              [:tr
               [:th "Trigger"]
               [:td (build-model/why-in-words build)]
               [:th "Duration"]
               [:td (if (build-model/running? build)
                      (om/build common/updating-duration (:start_time build))
                      (build-model/duration build))]]
              [:tr
               [:th "Previous"]
               (if-not (:previous_build build)
                 [:td "none"]
                 [:td
                  [:a {:href (build-model/path-for (select-keys build [:vcs_url])
                                                   (assoc build :build_num (:previous_build build)))}
                   (:previous_build build)]])
               [:th "Status"]
               [:td
                [:span.build-status {:class (:status build)}
                 (build-model/status-words build)]]]
              [:tr
               (when (:usage_queued_at build)
                 (list [:th "Queued"]
                       [:td (if (< 0 (build-model/run-queued-time build))
                              [:span
                               (if usage-queued?
                                 (om/build common/updating-duration (:usage_queued_at build))
                                 (datetime/as-duration (build-model/usage-queued-time build)))
                               " waiting + "
                               (if run-queued?
                                 (om/build common/updating-duration (:queued_at build))
                                 (datetime/as-duration (build-model/run-queued-time build)))
                               " in queue"]

                              [:span
                               (if usage-queued?
                                 (om/build common/updating-duration (:usage_queued_at build))
                                 (datetime/as-duration (build-model/usage-queued-time build)))
                               " waiting for builds to finish"])

                        [:a#queued_explanation
                         {:on-click #(put! controls-ch [:usage-queue-why-toggled
                                                        {:build-id build-id
                                                         :username (:username @build)
                                                         :reponame (:reponame @build)
                                                         :build_num (:build_num @build)}])}
                         " view "]
                        [:i.fa.fa-caret-down {:class (when (:show-usage-queue usage-queue-data) "fa-rotate-180")}]]))
               (when (build-model/author-isnt-committer build)
                 [:th "Committer"]
                 [:td
                  (if-not (:committer_email build)
                    [:span (build-model/committer build)]
                    [:a {:href (str "mailto:" (:committer_email build))}
                     (build-model/committer build)])])]
              [:tr
               [:th "Parallelism"]
               [:td
                [:a {:title (str "This build used " (:parallel build) " containers. Click here to change parallelism for future builds.")
                     :href (build-model/path-for-parallelism build)}
                 (str (:parallel build) "x")]]]]]
            [:div.build-actions
             [:div.actions
              (forms/stateful-button
               [:button.retry_build
                {:data-loading-text "Rebuilding",
                 :title "Retry the same tests",
                 :on-click #(put! controls-ch [:retry-build-clicked {:build-id build-id
                                                                     :vcs-url vcs-url
                                                                     :build-num build-num
                                                                     :clear-cache? false}])}
                "Rebuild"])
              (forms/stateful-button
               [:button.clear_cache_retry
                {:data-loading-text "Rebuilding",
                 :title "Clear cache and retry",
                 :on-click #(put! controls-ch [:retry-build-clicked {:build-id build-id
                                                                     :vcs-url vcs-url
                                                                     :build-num build-num
                                                                     :clear-cache? true}])}
                "& clear cache"])

              (forms/stateful-button
               [:button.ssh_build
                {:data-loading-text "Rebuilding",
                 :title "Retry with SSH in VM",
                 :on-click #(put! controls-ch [:ssh-build-clicked build-id])}
                "& enable ssh"])]
             [:div.actions
              [:button.report_build
               {:title "Report error with build",
                :on-click #(put! controls-ch [:report-build-clicked {:build-url (:build_url @build)}])}
               "Report"]
              (when (build-model/can-cancel? build)
                (forms/stateful-button
                 [:button.cancel_build
                  {:data-loading-text "Canceling",
                   :title "Cancel this build",
                   :on-click #(put! controls-ch [:cancel-build-clicked {:build-id build-id
                                                                        :vcs-url vcs-url
                                                                        :build-num build-num}])}
                  "Cancel"]))]]]
           (when (:show-usage-queue usage-queue-data)
             (om/build build-queue {:build build
                                    :builds (:builds usage-queue-data)}))
           (when (:subject build)
             (om/build build-commits build))
           (when (build-model/ssh-enabled-now? build)
             (om/build build-ssh (:node build)))
           (when (:has_artifacts build)
             (om/build build-artifacts-list (get build-data :artifacts-data)))]])))))

update build header

update build header


(ns ring.util.response
  "Functions for generating and augmenting response maps."
  (:require [clojure.java.io :as io]
            [clojure.string :as str]
            [ring.util.io :refer [last-modified-date]]
            [ring.util.time :refer [format-date]])
  (:import [java.io File]
           [java.util Date]
           [java.net URL URLDecoder URLEncoder]))

(def redirect-status-codes
  {:moved-permanently 301
   :found 302
   :see-other 303
   :temporary-redirect 307
   :permanent-redirect 308})

(defn redirect
  "Returns a Ring response for an HTTP 302 redirect. Status may be
  a key in redirect-status-codes or a numeric code. Defaults to 302"
  ([url] (redirect url :found))
  ([url status]
   {:status  (redirect-status-codes status status)
    :headers {"Location" url}
    :body    ""}))

(defn redirect-after-post
  "Returns a Ring response for an HTTP 303 redirect. Deprecated in favor
  of using redirect with a :see-other status."
  {:deprecated "1.4"}
  [url]
  {:status  303
   :headers {"Location" url}
   :body    ""})

(defn created
  "Returns a Ring response for a HTTP 201 created response."
  {:added "1.2"}
  ([url] (created url nil))
  ([url body]
     {:status  201
      :headers {"Location" url}
      :body    body}))

(defn not-found
  "Returns a 404 'not found' response."
  {:added "1.1"}
  [body]
  {:status  404
   :headers {}
   :body    body})

(defn response
  "Returns a skeletal Ring response with the given body, status of 200, and no
  headers."
  [body]
  {:status  200
   :headers {}
   :body    body})

(defn status
  "Returns an updated Ring response with the given status."
  [resp status]
  (assoc resp :status status))

(defn header
  "Returns an updated Ring response with the specified header added."
  [resp name value]
  (assoc-in resp [:headers name] (str value)))

(defn- safe-path?
  "Is a filepath safe for a particular root?"
  [^String root ^String path]
  (.startsWith (.getCanonicalPath (File. root path))
               (.getCanonicalPath (File. root))))

(defn- directory-transversal?
  "Check if a path contains '..'."
  [^String path]
  (-> (str/split path #"/|\\")
      (set)
      (contains? "..")))

(defn- find-index-file
  "Search the directory for an index file."
  [^File dir]
  (first
    (filter
      #(.startsWith (.toLowerCase (.getName ^File %)) "index.")
       (.listFiles dir))))

(defn- safely-find-file [^String path opts]
  (if-let [^String root (:root opts)]
    (if (or (safe-path? root path)
            (and (:allow-symlinks? opts) (not (directory-transversal? path))))
      (File. root path))
    (File. path)))

(defn- find-file [^String path opts]
  (if-let [^File file (safely-find-file path opts)]
    (cond
      (.isDirectory file)
        (and (:index-files? opts true) (find-index-file file))
      (.exists file)
        file)))

(defn- file-data [^File file]
  {:content        file
   :content-length (.length file)
   :last-modified  (last-modified-date file)})

(defn- content-length [resp len]
  (if len
    (header resp "Content-Length" len)
    resp))

(defn- last-modified [resp last-mod]
  (if last-mod
    (header resp "Last-Modified" (format-date last-mod))
    resp))

(defn file-response
  "Returns a Ring response to serve a static file, or nil if an appropriate
  file does not exist.
  Options:
    :root            - take the filepath relative to this root path
    :index-files?    - look for index.* files in directories, defaults to true
    :allow-symlinks? - serve files through symbolic links, defaults to false"
  [filepath & [opts]]
  (if-let [file (find-file filepath opts)]
    (let [data (file-data file)]
      (-> (response (:content data))
          (content-length (:content-length data))
          (last-modified (:last-modified data))))))

;; In Clojure 1.5.1, the as-file function does not correctly decode
;; UTF-8 byte sequences.
;;
;; See: http://dev.clojure.org/jira/browse/CLJ-1177
;;
;; As a work-around, we'll backport the fix from CLJ-1177 into
;; url-as-file.

(defn- ^File url-as-file [^java.net.URL u]
  (-> (.getFile u)
      (str/replace \/ File/separatorChar)
      (str/replace "+" (URLEncoder/encode "+" "UTF-8"))
      (URLDecoder/decode "UTF-8")
      io/as-file))

(defn content-type
  "Returns an updated Ring response with the a Content-Type header corresponding
  to the given content-type."
  [resp content-type]
  (header resp "Content-Type" content-type))

(defn find-header
  "Looks up a header in a Ring response (or request) case insensitively,
  returning the header map entry, or nil if not present."
  {:added "1.4"}
  [resp ^String header-name]
  (->> (:headers resp)
       (filter #(.equalsIgnoreCase header-name (key %)))
       (first)))

(defn get-header
  "Looks up a header in a Ring response (or request) case insensitively,
  returning the value of the header, or nil if not present."
  {:added "1.2"}
  [resp header-name]
  (some-> resp (find-header header-name) val))

(defn update-header
  "Looks up a header in a Ring response (or request) case insensitively,
  then updates the header with the supplied function and arguments in the
  manner of update-in."
  {:added "1.4"}
  [resp header-name f & args]
  (let [header-key (or (some-> resp (find-header header-name) key) header-name)]
    (update-in resp [:headers header-key] #(apply f % args))))

(defn charset
  "Returns an updated Ring response with the supplied charset added to the
  Content-Type header."
  {:added "1.1"}
  [resp charset]
  (update-header resp "Content-Type"
    (fn [content-type]
      (-> (or content-type "text/plain")
          (str/replace #";\s*charset=[^;]*" "")
          (str "; charset=" charset)))))

(defn set-cookie
  "Sets a cookie on the response. Requires the handler to be wrapped in the
  wrap-cookies middleware."
  {:added "1.1"}
  [resp name value & [opts]]
  (assoc-in resp [:cookies name] (merge {:value value} opts)))

(defn response?
  "True if the supplied value is a valid response map."
  {:added "1.1"}
  [resp]
  (and (map? resp)
       (integer? (:status resp))
       (map? (:headers resp))))

(defmulti resource-data
  "Returns data about the resource specified by url, or nil if an
  appropriate resource does not exist.

  The return value is a map with optional values for:
  :content        - the content of the URL, suitable for use as the :body
                    of a ring response
  :content-length - the length of the :content, nil if not available
  :last-modified  - the Date the :content was last modified, nil if not
                    available

  This dispatches on the protocol of the URL as a keyword, and
  implementations are provided for :file and :jar. If you are on a
  platform where (Class/getResource) returns URLs with a different
  protocol, you will need to provide an implementation for that
  protocol.

  This function is used internally by url-response."
  (fn [^java.net.URL url]
    (keyword (.getProtocol url))))

(defmethod resource-data :file
  [url]
  (if-let [file (url-as-file url)]
    (if-not (.isDirectory file)
      (file-data file))))

(defn- add-ending-slash [^String path]
  (if (.endsWith path "/")
    path
    (str path "/")))

(defn- jar-directory? [^java.net.JarURLConnection conn]
  (let [jar-file   (.getJarFile conn)
        entry-name (.getEntryName conn)
        dir-entry  (.getEntry jar-file (add-ending-slash entry-name))]
    (and dir-entry (.isDirectory dir-entry))))

(defn- connection-content-length [^java.net.URLConnection conn]
  (let [len (.getContentLength conn)]
    (if (<= 0 len) len)))

(defn- connection-last-modified [^java.net.URLConnection conn]
  (let [last-mod (.getLastModified conn)]
    (if-not (zero? last-mod)
      (Date. last-mod))))

(defmethod resource-data :jar
  [^java.net.URL url]
  (let [conn (.openConnection url)]
    (if-not (jar-directory? conn)
      {:content        (.getInputStream conn)
       :content-length (connection-content-length conn)
       :last-modified  (connection-last-modified conn)})))

(defn url-response
  "Return a response for the supplied URL."
  {:added "1.2"}
  [^URL url]
  (if-let [data (resource-data url)]
    (-> (response (:content data))
        (content-length (:content-length data))
        (last-modified (:last-modified data)))))

(defn resource-response
  "Returns a Ring response to serve a packaged resource, or nil if the
  resource does not exist.
  Options:
    :root - take the resource relative to this root
    :loader - resolve the resource in this class loader"
  [path & [{:keys [root loader] :as opts}]]
  (let [path (-> (str (or root "") "/" path)
                 (.replace "//" "/")
                 (.replaceAll "^/" ""))]
    (if-let [resource (if loader
                        (io/resource path loader)
                        (io/resource path))]
      (url-response resource))))

Remove unnecessary blank line

Remove unnecessary blank line


(ns pc.replay
  (:require [datomic.api :as d]
            [pc.datomic :as pcd]
            [pc.datomic.schema :as schema]
            [pc.datomic.web-peer :as web-peer])
  (:import java.util.UUID))

(defn- ->datom
  [[e a v tx added]]
  {:e e :a a :v v :tx tx :added added})

(defn tx-data [transaction]
  (->> (d/q '{:find [?e ?a ?v ?tx ?op]
              :in [?log ?txid]
              :where [[(tx-data ?log ?txid) [[?e ?a ?v ?tx ?op]]]]}
            (d/log (pcd/conn)) (:db/id transaction))
    (map ->datom)
    set))

(defn get-document-tx-ids
  "Returns array of tx-ids sorted by db/txInstant"
  [db doc]
  (map first
       (sort-by second
                (d/q '{:find [?t ?tx]
                       :in [$ ?doc-id]
                       :where [[?t :transaction/document ?doc-id]
                               [?t :transaction/broadcast]
                               [?t :db/txInstant ?tx]]}
                     db (:db/id doc)))))

(defn reproduce-transaction [db tx-id]
  (let [tx (d/entity db tx-id)]
    {:tx-data (tx-data tx)
     :db-after db}))

(defn get-document-transactions
  "Returns a lazy sequence of transactions for a document in order of db/txInstant.
   Has :tx-data and :db-after fields"
  [db doc]
  (map (partial reproduce-transaction db)
       (get-document-tx-ids db doc)))

(defn replace-frontend-ids [db doc-id txes]
  (let [a (d/entid db :frontend/id)]
    (map (fn [tx]
           (if (= (:a tx) a)
             (assoc tx
                    :v (UUID. doc-id (web-peer/client-part (:v tx)))
                    :a (d/entid (pcd/default-db) :frontend/id))
             tx))
         txes)))

(defn copy-transactions [db doc new-doc & {:keys [sleep-ms]
                                           :or {sleep-ms 1000}}]
  (let [conn (pcd/conn)
        tx-datas (->> (get-document-transactions db doc)
                   (map (fn [t]
                          (->> (:tx-data t)
                            (remove #(= (:e %) (:db/id t)))
                            (map #(if (= (:v %) (:db/id doc))
                                    (assoc % :v (:db/id new-doc))
                                    %))
                            (replace-frontend-ids db (:db/id new-doc))))))
        eid-translations (-> (apply concat (map #(map :e %) tx-datas))
                           set
                           (disj (:db/id doc))
                           (zipmap (repeatedly #(d/tempid :db.part/user)))
                           (assoc (:db/id doc) (:db/id new-doc)))]
    (doseq [tx-data tx-datas]
      (def my-tx-data tx-data)
      (let [txid (d/tempid :db.part/tx)]
        @(d/transact conn (conj (map #(-> %
                                        (update-in [:e] eid-translations)
                                        pcd/datom->transaction)
                                     tx-data)
                                {:db/id txid
                                 :transaction/document (:db/id new-doc)
                                 :transaction/broadcast true}))
        (Thread/sleep sleep-ms)))))

(ns pc.replay
  (:require [clojure.set :as set]
            [datomic.api :as d]
            [pc.datomic :as pcd]
            [pc.datomic.schema :as schema]
            [pc.datomic.web-peer :as web-peer])
  (:import java.util.UUID))

(defn- ->datom
  [[e a v tx added]]
  {:e e :a a :v v :tx tx :added added})

(defn tx-data [transaction]
  (->> (d/q '{:find [?e ?a ?v ?tx ?op]
              :in [?log ?txid]
              :where [[(tx-data ?log ?txid) [[?e ?a ?v ?tx ?op]]]]}
            (d/log (pcd/conn)) (:db/id transaction))
    (map ->datom)
    set))

(defn get-document-tx-ids
  "Returns array of tx-ids sorted by db/txInstant"
  [db doc]
  (map first
       (sort-by second
                (d/q '{:find [?t ?tx]
                       :in [$ ?doc-id]
                       :where [[?t :transaction/document ?doc-id]
                               [?t :transaction/broadcast]
                               [?t :db/txInstant ?tx]]}
                     db (:db/id doc)))))

(defn reproduce-transaction [db tx-id]
  (let [tx (d/entity db tx-id)]
    {:tx-data (tx-data tx)
     :tx tx
     :db-after db}))

(defn get-document-transactions
  "Returns a lazy sequence of transactions for a document in order of db/txInstant."
  [db doc]
  (map (partial reproduce-transaction db)
       (get-document-tx-ids db doc)))

(defn replace-frontend-ids [db doc-id txes]
  (let [a (d/entid db :frontend/id)]
    (map (fn [tx]
           (if (= (:a tx) a)
             (assoc tx
                    :v (UUID. doc-id (web-peer/client-part (:v tx))))
             tx))
         txes)))

(defn doc-id-attr->ref-attr [db {:keys [e v] :as d}]
  (let [ent (d/entity db e)]
    (cond (:layer/type ent) :layer/document
          (:chat/body ent)  :chat/document
          (:layer/name ent) :layer/document
          (= :layer (:entity/type ent)) :layer/document
          (:layer/end-x ent) :layer/document
          :else (throw (Exception. (format "couldn't find attr for %s" d))))))

(defn replace-document-ids [db txes]
  (let [a (d/entid db :document/id)]
    (map (fn [tx]
           (if (= (:a tx) a)
             (assoc tx
                    :a (doc-id-attr->ref-attr (d/as-of db (if (:added tx)
                                                            (:tx tx)
                                                            (dec (:tx tx))))
                                              tx))
             tx))
         txes)))

(defn copy-transactions [db doc new-doc & {:keys [sleep-ms]
                                           :or {sleep-ms 1000}}]
  (let [conn (pcd/conn)
        txes (->> (get-document-transactions db doc)
               (map (fn [tx]
                      (update-in tx
                                 [:tx-data]
                                 (fn [tx-data]
                                   (->> tx-data
                                     (remove #(= (:e %) (:db/id (:tx tx))))
                                     (map #(if (= (:v %) (:db/id doc))
                                             (assoc % :v (:db/id new-doc))
                                             %))
                                     (replace-frontend-ids db (:db/id new-doc))
                                     (replace-document-ids db)))))))
        eid-translations (-> (reduce (fn [acc {:keys [tx-data]}]
                                       (set/union acc (set (map :e tx-data))))
                                     #{} txes)
                           (disj (:db/id doc))
                           (zipmap (repeatedly #(d/tempid :db.part/user)))
                           (assoc (:db/id doc) (:db/id new-doc)))
        reverse-eid-translations (set/map-invert eid-translations)
        new-eids (reduce (fn [new-eid-trans tx]
                           (if-not (seq (:tx-data tx))
                             new-eid-trans
                             (let [txid (d/tempid :db.part/tx)
                                   tempids (map #(get eid-translations %)
                                                (remove #(get new-eid-trans %)
                                                        (map :e (:tx-data tx))))
                                   new-tx @(d/transact conn (conj (map #(-> %
                                                                          (update-in [:e] (fn [e] (or (get new-eid-trans e)
                                                                                (get eid-translations e))))
                                                                          pcd/datom->transaction)
                                                                       (:tx-data tx))
                                                                  (merge
                                                                   {:db/id txid
                                                                    :transaction/document (:db/id new-doc)}
                                                                   (when (:transaction/broadcast (:tx tx))
                                                                     {:transaction/broadcast true}))))]
                               (merge new-eid-trans
                                      (zipmap (map #(get reverse-eid-translations %) tempids)
                                              (map #(d/resolve-tempid (:db-after new-tx) (:tempids new-tx) %) tempids))))))
                         {} txes)]
    @(d/transact conn (map (fn [e]
                             [:db/add e :frontend/id (UUID. (:db/id new-doc) e)])
                           (remove #(:frontend/id (d/entity db %))
                                   (vals new-eids))))
    new-doc))

make copy-doc work again

make copy-doc work again