Lots of changes to support namespaces.

Lots of changes to support namespaces.

So it turns out that an Attributes instance can't be used safely after exiting the SAX handler. As it works now, this code is busted, because it just puts the Attributes instances into the sax-event seq, and then uses them later. That doesn't work. Sigh.

--- src/rapscallion/xml.clj
+++ src/rapscallion/xml.clj
@@ -87,83 +87,45 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Parsing XML

-(def ^:dynamic *xmlns-aware*
-  "Determines whether parsing is XML-namespace-aware.
-
-   When set to false, XML namespaces are more-or-less ignored, and
-   tags and attributes are stored as they appear textually in the
-   XML, including prefixes.
-
-   When set to true, namespace URIs are stored as part of Elements'
-   values, and prefix information is stored in metadata.
-
-   Specifically, setting this when parsing causes the following
-   differences in the resulting tree, where each point below lists the
-   effects of setting *xmlns-aware* to true (t) or false (f):
-
-    * xmlns declarations:
-       t: stored in metadata as :xmlns-decls
-       f: present in the attrs map, like regular attributes
-
-    * The ns field of Elements:
-       t: the namespace URI (or nil, for the default namespace)
-       f: always nil
-
-    * The tag field of Elements:
-       t: the localName only (no prefix)
-       f: the QName (prefix:tagname)
-
-    * Unprefixed attributes:
-       t: attribute name as a keyword
-       f: attribute name as a keyword
-
-    * Prefixed (namespaced) attributes:
-       t: vector of [:localName ns-uri], with {:prefix prefix} metadata
-       f: the QName as a keyword (prefix:attrname)
-
-    * Other stuff that I can't remember right now:
-       t: ???
-       f: ???
-
-  "
-  true)
-
-
 (defn- parse-error [& messages]
   (throw (IllegalArgumentException. (apply str messages))))

-(defn xml-handler
+(defn sax-handler
   "Return an instance of org.xml.sax.ext.DefaultHandler2 that will
   handle SAX events by calling the supplied function, passing a vector
-  of 1, 2 or 3 items, the first being the event type as a keyword, and
-  the other 2 (optional) being the associated data.
+  of 1 or more items, the first being the event type as a keyword, and
+  the others being the associated data.

   The event types and their associated data are:
-    [:start-element tag attrs]
-    [:end-element tag]
+    [:start-element uri local-name q-name attrs]
+    [:end-element uri local-name q-name]
+    [:start-prefix-mapping prefix uri]
+    [:end-prefix-mapping prefix]
     [:text string]
     [:start-cdata]
     [:end-cdata]
     [:processing-instruction target data]
-    [:start-prefix-mapping prefix uri]
-    [:end-prefix-mapping prefix]
     [:comment text]
   "
-
-  [f]
+  [f & [opts]]
   (proxy [DefaultHandler2] []

     ;; Elements
-    (startElement [uri local-name q-name ^Attributes atts]
-      (f [:start-element (keyword q-name) atts]))
+    (startElement [uri local-name q-name attrs]
+      (f [:start-element uri local-name q-name attrs]))
     (endElement [uri local-name q-name]
-      (f [:end-element (keyword q-name)]))
+      (f [:end-element uri local-name q-name]))

     ;; Text
     (characters [^chars ch ^long start ^long length]
       (f [:text (String. ch start length)]))
-
+
+    ;; As far as I can tell, ignorableWhitespace never gets called.
+    ;; does anyone ever need this?
+    #_(ignorableWhitespace [^chars ch ^long start ^long length]
+        (f [:whitespace (String. ch start length)]))
+
     ;; Keep track of which text came from a CDATA section
     (startCDATA []
       (f [:start-cdata]))
@@ -182,7 +144,7 @@

     ;; Comments
     (comment [^chars ch ^long start ^long length]
-      (f [:comment (String. ch start length)]))
+             (f [:comment (String. ch start length)]))

     ))

@@ -208,25 +170,24 @@

 (defn sax-seq
   "Given a source of XML, returns a sequence of events, in the form of
-  vectors of [type data ...]. See xml-handler for details."
+   vectors of [type data ...]. See sax-handler for details."
   [in & [opts]]
-  (let [{:keys [namespaces]
-         :or   {namespaces true}} opts
-
+  (let [{:keys [namespaces]} opts
         ^InputSource in (as-input-source in)
         parser          (XMLReaderFactory/createXMLReader)
-        [put event-seq] (pipe/pipe)
-        handler         (xml-handler put)]
+        [put event-seq] (pipe/pipe {:capacity 4096})
+        handler         (sax-handler put opts)]

     (.setContentHandler parser handler)

-    ;; Set the "lexical-handler" property in order to get
-    ;; start-prefix-mapping & end-prefix-mapping events.
-    (.setProperty parser "http://xml.org/sax/properties/lexical-handler" handler)
-
-    ;; Setting this to true means that undeclared namespace-prefixes
-    ;; will be an error.
-    (.setFeature parser "http://xml.org/sax/features/namespaces" namespaces)
+    (when namespaces
+      ;; Set the "lexical-handler" property in order to get
+      ;; start-prefix-mapping & end-prefix-mapping events.
+      (.setProperty parser "http://xml.org/sax/properties/lexical-handler" handler)
+
+      ;; Setting this to true means that undeclared namespace-prefixes
+      ;; will be an error.
+      (.setFeature parser "http://xml.org/sax/features/namespaces" namespaces))

     ;; Run the SAX parser in a thread.
     (future
@@ -239,31 +200,17 @@

     event-seq))

+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Transformations of event streams
-(defn throw-if-error [[type ex :as evt]]
-  (if (= :error type)
-    (throw ex)
-    evt))

 (defn throw-on-error [events]
-  (map throw-if-error events))
-
-
-;; swiped from data.xml:
-(defn attrs->map [^Attributes atts]
-  (into {} (for [^Long i (range (.getLength atts))]
-             [(keyword (.getQName atts i))
-              (.getValue atts i)])))
-
-(defn mapify-attrs
-  "Tranform start-element events so that attributes are stored in a
-  map, rather than an Attributes instance."
-  [events]
-  (map (fn [[type tag attrs :as evt]]
-         (if (= type :start-element)
-           [:start-element tag (attrs->map attrs)]
+  (map (fn [[type exc :as evt]]
+         (if (= :error type)
+           (throw exc)
            evt))
        events))
+

 (defn merge-adjacent-text
   "Transform the event stream so that adjacent bits of text are
@@ -301,66 +248,107 @@
    1 - A seq of nodes extracted from the event seq, and
    2 - A seq of the unconsumed events.
   "
-  [events & [xmlns-prefix-map]]
-
-  ;; Notes: I tried for a while to make this consume the event-seq
-  ;;        lazily, but that made my brain explode.
-
-  (loop [nodes []
-         [[type data :as evt] & events] events
-         ns-stack (list xmlns-prefix-map)]
-
-    (case type
-
-      :start-prefix-mapping
-      (let [[_ prefix uri] evt
-            ns-map (assoc-in (peek ns-stack) [:xmlns uri] prefix)]
-        (recur nodes events (conj ns-stack ns-map)))
-
-      :end-prefix-mapping
-      (recur nodes events (pop ns-stack))
-
-      :start-element
-      (let [[_ tag attrs]     evt
-            [children events] (events->nodes events (peek ns-stack))
-            elt               (Element. tag attrs children nil)]
-        (recur (conj nodes (with-meta elt {:xmlns (peek ns-stack)}))
-               events
-               ns-stack))
-
-      :text
-      (recur (conj nodes data)
-             events
-             ns-stack)
-
-      :comment
-      (recur (conj nodes (Comment. data))
-             events
-             ns-stack)
-
-      :start-cdata
-      (let [[text-nodes [end-cdata & events]]
-            (split-with (fn [[type]] (= type :text)) events)]
-        (assert (= (end-cdata 0) :end-cdata) "Expected :end-cdata event.")
-        (recur (conj nodes (CData. (apply str (map second text-nodes))))
-               events
-               ns-stack))
-
-      :processing-instruction
-      (let [[_ target text] evt]
-        (recur (conj nodes (PI. target text))
-               events
-               ns-stack))
-
-      (:end-element nil)
-      [nodes events]
-
-      )))
+  [events & [opts]]
+  ;; TODO - this function is way too busy
+  (let [{:keys [namespaces]} opts
+
+        attr-key
+        (if namespaces
+          (fn [^Attributes attrs ^Long i]
+            (let [uri (.getURI attrs i)
+                  q-name (.getQName attrs i)]
+              (if (.isEmpty uri)
+                (keyword q-name)
+                (let [[prefix _] (string/split q-name #":" 2)]
+                  (with-meta
+                    [(keyword (.getLocalName attrs i)) uri]
+                    {:prefix prefix})))))
+          (fn [^Attributes attrs ^Long i]
+            (keyword (.getQName attrs i))))
+
+        attrs->map
+        (fn [^Attributes attrs]
+          (into {} (for [^Long i (range (.getLength attrs))]
+                     [(attr-key attrs i) (.getValue attrs i)])))
+
+        make-element
+        (if namespaces
+          (fn [[_ uri local-name q-name attrs] content ns-map]
+            (let [[prefix tag] (string/split q-name #":" 2)
+                  prefix (if tag prefix nil)]
+              (with-meta
+                (Element. (keyword local-name)
+                          (attrs->map attrs)
+                          content
+                          uri)
+                (if prefix
+                  (assoc ns-map :prefix prefix) ;TODO - intern this somehow
+                  ns-map))))
+          (fn [[_ _ _ q-name attrs] content _]
+            (Element. (keyword q-name)
+                      (attrs->map attrs)
+                      content
+                      nil)))
+
+        make-nodes
+        (fn make-nodes [events xmlns-map]
+          (loop [nodes []
+                 [[type data :as evt] & events] events
+                 ns-stack (list xmlns-map)]
+
+            (case type
+
+              :start-prefix-mapping
+              (let [[_ prefix uri] evt
+                    ns-map (assoc-in (peek ns-stack) [:xmlns prefix] uri)]
+                (recur nodes events (conj ns-stack ns-map)))
+
+              :end-prefix-mapping
+              ;; TODO - sanity check? make sure the prefix is in the ns-map?
+              (recur nodes events (pop ns-stack))
+
+              :start-element
+              (let [ns-map (peek ns-stack)
+                    [children events] (make-nodes events ns-map)
+                    elt (make-element evt children ns-map)]
+                (recur (conj nodes elt)
+                       events
+                       ns-stack))
+
+              :text
+              (recur (conj nodes data)
+                     events
+                     ns-stack)
+
+              :comment
+              (recur (conj nodes (Comment. data))
+                     events
+                     ns-stack)
+
+              :start-cdata
+              (let [[text-nodes [end-cdata & events]]
+                    (split-with (fn [[type]] (= type :text)) events)]
+                (assert (= (end-cdata 0) :end-cdata) "Expected :end-cdata event.")
+                (recur (conj nodes (CData. (apply str (map second text-nodes))))
+                       events
+                       ns-stack))
+
+              :processing-instruction
+              (let [[_ target text] evt]
+                (recur (conj nodes (PI. target text))
+                       events
+                       ns-stack))
+
+              (:end-element nil)
+              [nodes events]
+
+              )))]
+    (make-nodes events nil)))

 (defn make-tree
   "Takes a seq of SAX events and returns a vector of the top-level nodes."
-  [events]
-  (let [[nodes events] (events->nodes events)]
+  [events & [opts]]
+  (let [[nodes events] (events->nodes events opts)]
     (when (seq events)
       ;; This shouldn't be possible if the source of the events is an
       ;; actual SAX parser, but could happen for an event-seq from
@@ -386,10 +374,15 @@
    :processing-instructions false
    })

-(def ^{:dynamic true} *parse-options* default-parse-options)
+(def ^{:dynamic true
+       :doc "Map of parsing options. Any options not explitly provided
+in a call to parse will take their values from this map.
+
+  "}
+  *parse-options* default-parse-options)

 (defn parse
-  "Takes something convertable to a InputSource, and returns a vector
+  "Takes something convertable to a InputSource, and returns a seq
    of top-level XML nodes.

    The opts parameter is an optional map of options. The defaults for
@@ -405,7 +398,45 @@
        If false, nodes of the corresponding type are discarded.

      :namespaces
-       Sets namespace-awareness in the SAX parser.
+       Sets namespace-awareness in the SAX parser. See below.
+
+   Namespace-awareness has the following effects:
+
+   When set to false, XML namespaces are more-or-less ignored, and
+   tags and attributes are stored as they appear textually in the
+   XML, including prefixes.
+
+   When set to true, namespace URIs are stored as part of Elements'
+   values, and prefix information is stored in metadata.
+
+   Specifically, setting this when parsing causes the following
+   differences in the resulting tree, where each point below lists the
+   effects of setting :namespaces to true (t) or false (f):
+
+    * xmlns declarations:
+       t: stored in metadata as :xmlns-decls
+       f: present in the attrs map, like regular attributes
+
+    * The ns field of Elements:
+       t: the namespace URI (or nil, for the default namespace)
+       f: always nil
+
+    * The tag field of Elements:
+       t: the localName only (no prefix)
+       f: the QName (prefix:tagname)
+
+    * Unprefixed attributes:
+       t: attribute name as a keyword
+       f: attribute name as a keyword
+
+    * Prefixed (namespaced) attributes:
+       t: vector of [:localName ns-uri], with {:prefix prefix} metadata
+       f: the QName as a keyword (prefix:attrname)
+
+    * Other stuff that I can't remember right now:
+       t: ???
+       f: ???
+
    "

   [source & [opts]]
@@ -446,9 +477,6 @@
         ;; <exception>].  This transformation will re-throw them.
         e (throw-on-error e)

-        ;; Turn Attributes on start-element events into maps.
-        e (mapify-attrs e)
-
         ;; SAX parsers can emit multiple "characters" events for one
         ;; piece of text (for example, when it contains entities, such
         ;; as &). It's generally more convenient to work with
@@ -464,7 +492,7 @@
     ;; nodes. This actually returns all the top-level nodes, which
     ;; should consist of exactly one Element, as well as any number of
     ;; Comments and PIs preceeding and/or following the Element.
-    (make-tree e)))
+    (make-tree e opts)))


remove deprecated code in interop.clj

remove deprecated code in interop.clj

--- src/reagent/interop.clj
+++ src/reagent/interop.clj
@@ -54,21 +54,3 @@
   (let [[field names] (dot-args object field)]
     (assert field (str "Field name must start with - in " field))
     `(aset ~object ~@names ~value)))
-
-#_(defmacro .' [& args]
-  ;; Deprecated since names starting with . cause problems with bootstrapped cljs.
-  (let [ns (str cljs.analyzer/*cljs-ns*)
-        line (:line (meta &form))]
-    (binding [*out* *err*]
-      (println "WARNING: reagent.interop/.' is deprecated in " ns " line " line
-               ". Use reagent.interop/$ instead.")))
-  `($ ~@args))
-
-#_(defmacro .! [& args]
-  ;; Deprecated since names starting with . cause problems with bootstrapped cljs.
-  (let [ns (str cljs.analyzer/*cljs-ns*)
-        line (:line (meta &form))]
-    (binding [*out* *err*]
-      (println "WARNING: reagent.interop/.! is deprecated in " ns " line " line
-               ". Use reagent.interop/$! instead.")))
-  `($! ~@args))


Make prevent-default and stop-propagation functions nil safe.

--- src/uxbox/util/dom.cljs
+++ src/uxbox/util/dom.cljs
@@ -16,11 +16,13 @@

 (defn stop-propagation
   [e]
-  (.stopPropagation e))
+  (when e
+    (.stopPropagation e)))

 (defn prevent-default
   [e]
-  (.preventDefault e))
+  (when e
+    (.preventDefault e)))

 (defn event->inner-text
   [e]


fix logging

fix logging

--- src/wb_es/bulk/core.clj
+++ src/wb_es/bulk/core.clj
@@ -319,7 +319,7 @@
                (let [job (deref job-ref)
                      job-meta (meta job)]
                  (try
-                   (debug "Starting" (:action job-meta))
+                   (debug "Starting" job-meta)
                    (case (:action job-meta)
                      "snapshot" (let [index-id (:index job-meta)
                                       repository-name (:repository job-meta)


[fix] Events list.

[fix] Events list.

--- src/ombs/dbold.clj
+++ src/ombs/dbold.clj
@@ -1,6 +1,8 @@
 (ns ombs.dbold
   (:require [korma.db :as kdb]
-            [korma.core :as sql]))
+            [korma.core :as sql]
+            [ombs.funcs :as f]
+            ))

 (kdb/defdb korma-db (kdb/sqlite3
                       { :db "database.db"
@@ -70,18 +72,20 @@
 (defn add-event
   ([ename price author date parts]
    (sql/insert events (sql/values {:name ename :price price :author author :date date :status (statuses :initial) :parts parts})))
-  ([ename price author parts]
-   (sql/insert events (sql/values {:name ename :price price :author author :status (statuses :initial) :parts parts}))))
+  ([ename price author date]
+   (sql/insert events (sql/values {:name ename :price price :author author :date date :status (statuses :initial) }))))

 (defn set-status [ename date s]
   (sql/update events (sql/set-fields {:status (statuses s)})
               (sql/where {:name ename :date date})) )

 (defn get-events []
-  (sql/select events
-              (sql/fields :name :date :price :author :status )
-              (sql/with goods (sql/fields [:rest :parts]))
-              ))
+  (map
+    #(update % :parts f/nil-fix)
+    (sql/select events
+                (sql/fields :name :date :price :author :status )
+                (sql/with goods (sql/fields [:rest :parts]))
+                )))

 (defn get-active-events []
   (sql/select events


Bugfix: added forward declarations

Bugfix: added forward declarations

--- src/pscan/core.clj
+++ src/pscan/core.clj
@@ -6,29 +6,12 @@
             [clojure.java.io :as io])
   (:import match.Match2))

-(declare region-query-s)
-(declare region-query-p)
-(declare memoized-metric)
-
-;; TODO: find optimal subdivision for r/fold
-
-(def memoized-dbscan
-  "If true, calls to the metric passed to dbscan will be memoized"
-  true)
-
-(def memoized-mediods
-  "If true, calls to the metric passed to mediod-protein will be memoized"
-  true)
-
-(def region-query
-  "Select region-query-s (serial) or region-query-p (parallel)"
-  region-query-p)
-
-(def partition-size
-  "Approximate subdivision size for clojure.core.reducers/fold"
-  16)
-
-;;;
+(declare memoize-metric)
+(declare partition-size)
+(declare region-query)
+(declare memoized-dbscan)
+(declare memoized-medioids)
+

 (defn region-query-s
   "Serial region query; returns all pts *at least* eps similar to pt."
@@ -47,7 +30,7 @@
 (defn expand-cluster
   "Expand cluster at pt
    Returns false if there is not cluster to be had
-   Returns the core points of the cluster and an updated visited set otherwise"
+   Returns the core points of the cluster and an updated visited set otherwise"
   [pt pts metric eps min-pts visited]

   (let [local (region-query pt pts metric eps)]
@@ -144,7 +127,7 @@
 (defn medioid
   "Return element of cluster that maximizes sum of similarity scores"
   [cluster metric]
-  (let [mem-metric (if memoized-mediods
+  (let [mem-metric (if memoized-medioids
                      (memoize-metric metric)
                       metric)]
     (second
@@ -165,7 +148,28 @@
     (for [rep cluster-reps]
       [(metric pt rep), rep])))

-;;;
+
+;;; "Constants"
+
+;; TODO: find optimal subdivision for r/fold (partition-size)
+
+(def memoized-dbscan
+  "If true, calls to the metric passed to dbscan will be memoized"
+  true)
+
+(def memoized-medioids
+  "If true, calls to the metric passed to medioid-protein will be memoized"
+  true)
+
+(def region-query
+  "Select region-query-s (serial) or region-query-p (parallel)"
+  region-query-p)
+
+(def partition-size
+  "Approximate subdivision size for clojure.core.reducers/fold"
+  16)
+
+;;; Evaluation

 (def files
   ["UniRef90_A0A060TYH3.fa", "UniRef90_I0C6W8.fa","UniRef90_Q0A457.fa",
@@ -185,9 +189,10 @@
   (reduce into
           (map read-fasta (take 10 prefixed-files))))

-(count sample-proteins)
-
 (time (def trial (dbscan sample-proteins protein-metric 100 4)))
+
+
+;;; Test code (I know, I know, I should have written a real test suite.)

 (comment

@@ -202,8 +207,6 @@
 (def region-query
   "Select region-query-s (serial) or region-query-p (parallel)"
   region-query-p)
-
-

 (read-fasta "resources/simple.fasta")

@@ -249,5 +252,8 @@
 (region-query [0 0] pts r2-dist 2)

 (map #(region-query % pts r2-dist 1) '([0 0] [0 1]))
+
+
+
 )


Fix logger JSONLayout bug: it's called JSONLayoutV0 now.

--- src/riemann/logging.clj
+++ src/riemann/logging.clj
@@ -9,7 +9,8 @@
              ConsoleAppender
              FileAppender
              SimpleLayout)
-           (net.logstash.log4j JSONEventLayoutV1 JSONEventLayout)
+           (net.logstash.log4j JSONEventLayoutV0
+                               JSONEventLayoutV1)
            (org.apache.log4j.spi RootLogger))
   (:import (org.apache.log4j.rolling TimeBasedRollingPolicy
                                      SizeBasedTriggeringPolicy
@@ -42,7 +43,8 @@
 (def ^{:doc "available logging patterns"}
   layouts
   {:riemann       (EnhancedPatternLayout. "%p [%d] %t - %c - %m%n%throwable")
-   :json-event    (JSONEventLayout.)
+   :json-event    (JSONEventLayoutV0.)
+   :json-event-v0 (JSONEventLayoutV0.)
    :json-event-v1 (JSONEventLayoutV1.)})

 (defn get-layout


fix tests

fix tests

--- test/com/rpl/specter/core_test.cljx
+++ test/com/rpl/specter/core_test.cljx
@@ -574,11 +574,11 @@
   (for-all+
     [s1 (gen/vector (limit-size 5 gen/int))]
     (and
-      (empty? (s/select s/VOID s1))
-      (empty? (s/select [s/VOID s/ALL s/ALL s/ALL s/ALL] s1))
-      (= s1 (s/transform s/VOID inc s1))
-      (= s1 (s/transform [s/ALL s/VOID s/ALL] inc s1))
-      (= (s/transform [s/ALL (s/cond-path even? nil odd? s/VOID)] inc s1)
+      (empty? (s/select s/STOP s1))
+      (empty? (s/select [s/STOP s/ALL s/ALL s/ALL s/ALL] s1))
+      (= s1 (s/transform s/STOP inc s1))
+      (= s1 (s/transform [s/ALL s/STOP s/ALL] inc s1))
+      (= (s/transform [s/ALL (s/cond-path even? nil odd? s/STOP)] inc s1)
          (s/transform [s/ALL even?] inc s1))
       )))


nix space

nix space

--- clojure/src/dnd/character.cljs
+++ clojure/src/dnd/character.cljs
@@ -57,7 +57,7 @@
                   ))

 (defn tree [] (item-maker
-                (coin-flip "🎄" "🌲 ")
+                (coin-flip "🎄" "🌲")
                 (rand-rgb-vec)
                 "a happy tree"))


removed let statement that is not necessary

--- test/forma/trends/analysis_test.clj
+++ test/forma/trends/analysis_test.clj
@@ -171,9 +171,6 @@
   start and end index don't matter for this application, but are left
   in there anyway to ensure forward compatibility"
   [m]
-  (let [ndvi (vector (:ndvi m))
-        reli (vector (:reli m))
-        rain (vector (:rain m))])
   (transpose (telescoping-long-trend 23 135 136 ndvi reli rain)))


fixing tests

fixing tests

--- test/celestial/test/persistency.clj
+++ test/celestial/test/persistency.clj
@@ -3,10 +3,8 @@
    midje.sweet
    [celestial.roles :only (admin)]
    [celestial.persistency :only (validate-type validate-quota user-exists? validate-user)]
-   [celestial.fixtures :only (redis-type is-type? user-quota with-m?)]
-   )
- (:import clojure.lang.ExceptionInfo )
-  )
+   [celestial.fixtures :only (redis-type is-type? user-quota with-m?)])
+ (:import clojure.lang.ExceptionInfo))

 (fact "puppet std type validation"

@@ -38,9 +36,9 @@
    (provided (user-exists? "foo") => true :times 1))

 (fact "user validation"
-     (validate-user {:username "foo" :password "bar" :roles admin})  => truthy
-     (validate-user {:password "bar" :roles admin})  =>
+     (validate-user {:username "foo" :password "bar" :roles admin :envs []})  => truthy
+     (validate-user {:password "bar" :roles admin :envs []})  =>
        (throws ExceptionInfo (with-m? {:username '("must be present")} ))
-     (validate-user {:username "foo" :password "bar" :roles ["foo"]})  =>
+     (validate-user {:username "foo" :password "bar" :roles ["foo"] :envs []})  =>
        (throws ExceptionInfo (with-m? {:roles '(({0 ("role must be either #{:celestial.roles/anonymous :celestial.roles/user :celestial.roles/admin}")}))} ))
       )


Upgraded to samsara-client 0.1.4

Upgraded to samsara-client 0.1.4

--- clients/logger/project.clj
+++ clients/logger/project.clj
@@ -6,7 +6,7 @@
   :dependencies [[org.clojure/clojure "1.6.0"]
                  [org.slf4j/slf4j-api "1.7.12"]
                  [org.apache.logging.log4j/log4j-core "2.3"]
-                 [samsara/samsara-client "0.1.0-beta2"]]
+                 [samsara/samsara-client "0.1.4"]]
   :aot [samsara.logger.EventLogger]

   :source-paths ["src/main/clojure"]


Altered the optimize method to return the index.

--- src/clucy/core.clj
+++ src/clucy/core.clj
@@ -56,7 +56,8 @@
   (if (<= (:optimize-frequency @index) (:updates @index))
     (with-open [writer (index-writer index)]
       (.optimize writer)
-      (swap! index assoc :updates 0))))
+      (swap! index assoc :updates 0))
+    index))

 (defn- add-field
   "Add a Field to a Document."


Use local snapshot version of play-clj with fixes

--- totem-destroyer/desktop/project.clj
+++ totem-destroyer/desktop/project.clj
@@ -12,7 +12,7 @@
                  [com.badlogicgames.gdx/gdx-platform "1.9.3"
                   :classifier "natives-desktop"]
                  [org.clojure/clojure "1.7.0"]
-                 [play-clj "1.1.1"]]
+                 [play-clj "1.2.0-SNAPSHOT"]]

   :source-paths ["src" "src-common"]
   :javac-options ["-target" "1.6" "-source" "1.6" "-Xlint:-options"]


CMR-7106: Updated mime-types test.

CMR-7106: Updated mime-types test.

--- common-lib/test/cmr/common/test/mime_types.clj
+++ common-lib/test/cmr/common/test/mime_types.clj
@@ -1,9 +1,10 @@
 (ns cmr.common.test.mime-types
   "Tests for mime-type functions."
-  (:require [clojure.test :refer :all]
-            [clojure.string :as str]
-            [cmr.common.util :refer [are2]]
-            [cmr.common.mime-types :as mt]))
+  (:require
+   [clojure.string :as str]
+   [clojure.test :refer :all]
+   [cmr.common.mime-types :as mt]
+   [cmr.common.util :refer [are2]]))

 ;; Tests various times when the content type should be used when extracting mime types from headers
 (deftest mime-type-from-headers-test
@@ -107,5 +108,6 @@
 (deftest test-format->mime-type
   (is (= "application/json" (mt/format->mime-type :json)))
   (is (= "application/vnd.nasa.cmr.umm+json" (mt/format->mime-type :umm-json)))
-  (is (= "application/vnd.nasa.cmr.umm+json" (mt/format->mime-type {:format :umm-json
-                                                                    :version "16.1.3"}))))
+  (is (= "application/vnd.nasa.cmr.umm+json;version=16.1.3" (mt/format->mime-type
+                                                              {:format :umm-json
+                                                               :version "16.1.3"}))))


few datomic helpers

few datomic helpers

--- src/pc/datomic.clj
+++ src/pc/datomic.clj
@@ -58,6 +58,34 @@
   (let [{:keys [a e v tx added]} datom]
     [(if added :db/add :db/retract) e a v]))

+(defn revert-transaction [conn {:keys [tx-data db-after] :as transaction-report}]
+  (d/transact conn (map (fn [{:keys [a e v tx added] :as datom}]
+                          [(if added :db/retract :db/add) e a v])
+                        (remove #(->> % :a (d/entity db-after) :db/ident (= :db/txInstant))
+                                tx-data))))
+
+(defn rollback
+  "Reassert retracted datoms and retract asserted datoms in a transaction,
+  effectively \"undoing\" the transaction."
+  [conn tx]
+  (let [tx-log (-> conn d/log (d/tx-range tx nil) first) ; find the transaction
+        txid   (-> tx-log :t d/t->tx) ; get the transaction entity id
+        newdata (->> (:data tx-log)   ; get the datoms from the transaction
+                     (remove #(= (:e %) txid)) ; remove transaction-metadata datoms
+                     ; invert the datoms add/retract state.
+                     (map #(do [(if (:added %) :db/retract :db/add) (:e %) (:a %) (:v %)]))
+                     reverse)] ; reverse order of inverted datoms.
+    @(d/transact conn newdata)))  ; commit new datoms.
+
+;; TODO: This really needs a test
+(defn unique-conflict? [ex]
+  (loop [ex ex]
+    (if (:db/error (ex-data ex))
+      (= (:db/error (ex-data ex)) :db.error/unique-conflict)
+      (if (.getCause ex)
+        (recur (.getCause ex))
+        false))))
+
 (defonce tx-report-ch (async/chan (async/sliding-buffer 1024)))

 (defn setup-tx-report-ch [conn]


Retrieve and reload accept :include, etc.

--- src/pundit/api.clj
+++ src/pundit/api.clj
@@ -184,14 +184,24 @@
 ; Retrieving one object

 (defn retrieve
-  "Retrieves an object by ID from Parse"
-  [klass id]
-  (transform-object
-    klass
-    (GET ["classes" klass id] *auth*)))
-
-(defn reload [{:keys [class-name object-id]}]
+  "Retrieves an object by ID from Parse."
+  ([klass id]
+   (transform-object
+     klass
+     (GET ["classes" klass id] *auth*)))
+  ([klass id & {:as more}]
+   (apply
+     find-one
+     klass
+     (apply concat
+            (update-in more [:where] assoc :object-id id)))))
+
+(defn reload
+  "Reloads object from Parse."
+  ([{:keys [class-name object-id]}]
   (retrieve class-name object-id))
+  ([{:keys [class-name object-id]} & more]
+  (apply retrieve class-name object-id more)))

 ; Creating an object


Add deadlock detection.

Add deadlock detection.

--- src/exp/asplan.clj
+++ src/exp/asplan.clj
@@ -19,8 +19,6 @@
 ; Can refine until *particular* action resolved, or *any* current action resolved.
 ;   (not just any action, steps are too small).

-;; TODO: should we allow action to fire even when there is already action scheduled on precond ?
-
 ;; TODO: think about variable orderings more.  i.e., in infinite taxi, DAG order is perfect.

 ;; TODO: also look at using landmarks to structure search ?
@@ -31,12 +29,9 @@

 ;; NOTE: greedy should come in when we choose a parent for a var.
 ; If some parent can use current var RIGHT NOW, should assign to it, not branch.
-
-;; For state abstraction, it would be better to split parent into n+1 booleans:
-; (free? v), (parent? v1 v2)
-
-;; TODO: early detection of set deadlock (a1 + a2 need l1, l2, a1 has l1; a2 has l2)
-; especially important for non-DAG ?
+ ; Except, greedy actions takes care of this.
+
+;; For state abstraction, split parent into n+1 booleans: (free? v), (parent? v1 v2)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; States, (meta)primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -78,23 +73,6 @@
      {(action-var evar) factored-primitive}
      reward)))

-
-(comment ;; Not actually needed -- use below instead.
-  (defn make-fire-action-action [{:keys [name precond-map effect-map reward] :as factored-primitive}]
-   (let [[evar eval] (util/safe-singleton (seq effect-map))]
-     (env/FactoredPrimitive
-      [::Fire name]
-      (into precond-map
-            (cons [(action-var evar) factored-primitive]
-                  (for [[pvar pval] (dissoc precond-map evar)]
-                    [(parent-var pvar evar) true])))
-      (into effect-map
-            (cons [(action-var evar) nil]
-                  (apply concat
-                         (for [[pvar pval] (dissoc precond-map evar)]
-                           [[(parent-var pvar evar) false]
-                            [(free-var evar) true]]))))
-      0))))

 (defn make-set-parent-var-action [p-var c-var]
   (env/FactoredPrimitive
@@ -149,11 +127,43 @@
       t)))

 ; TODO: take reduced arcs into account, etc.
-(defn activation-actions
-  "Return a list of activation actions for var v, ideally which are supported by
-   current state; i.e., should take reduced arcs into account, etc. "
-  [s child-map v]
-  (for [c (child-map v) #_ (util/safe-get child-map v)]
+; Problem: this breaks state abstraction for hierarchy.
+; It will need to do detection at a higher level, i.e., notice deadlock
+
+; To notice deadlock, don't select var in parent chain of another.
+; More generally, don't select var s.t. resolving leads to cycle.
+;  Specifically, assigning to action which will be deadlocked on this precond.
+;  Recipe: keep parent links, add links from a--> b where a has lock on precond needed by b.
+;  If there is a cycle in this graph, we are deadlocked.
+
+(comment
+  (defn possible-activation-actions
+   "Return a list of possible activation actions for var v possible in state s.
+   To be possible parent, must be supported from below, and not cause deadlock
+   (by pointing to action whose other precondition is needing it. "
+   [s child-map v]
+   (for [c (child-map v)]
+     (make-set-parent-var-action v c))))
+
+;; TODO: do not count parent edges where action does not actually require precondition (top-down)
+(defn deadlocked? [s child-map]
+  (let [parent-edges (for [[p cs] child-map, c cs :when (env/get-var s (parent-var p c))] [p c])
+        res-map      (into {} (filter (fn [[p c]]
+                                        (when-let [a (env/get-var s (action-var c))]
+                                          (contains? (:precond-map a) p)))
+                                      parent-edges))
+        extra-edges  (for [[p c] parent-edges
+                           :let [a (env/get-var s (action-var p))]
+                           :when a
+                           precond (remove #{p} (keys (:precond-map a)))
+                           :let [res (res-map precond)]
+                           :when res]
+                       [res p])]
+    (not (graphs/dag? (concat parent-edges extra-edges)))))
+
+(defn activation-actions  "Return a list of all activation actions for var v"
+  [child-map v]
+  (for [c (child-map v)]
     (make-set-parent-var-action v c)))

 (defn current-child [s child-var-map p-var]
@@ -197,6 +207,8 @@
     (ASPlanEnv
      (expand-initial-state (env/initial-state sas-problem) child-var-map (goal-action dtgs))
      (fn asplan-actions [s]
+      (if false ;(deadlocked? s child-var-map)
+        (do (println s) nil)
        (let [[aa-vars na-vars] (util/separate #(env/get-var s (action-var %)) vars)
              aa-parent-edges   (for [av aa-vars
                                       :let [pm (:precond-map (env/get-var s (action-var av)))]
@@ -227,7 +239,7 @@

           ;; Inactive bottom-up var -- needs to be assigned.
           (util/find-first #(env/get-var s (free-var %)) (map first aa-parent-edges))
-            (activation-actions s child-var-map x)
+            (activation-actions child-var-map x)

           ;; Active top-down var -- add actions
           (util/find-first #(not (env/get-var s (free-var %))) (map second na-tuples))
@@ -236,7 +248,7 @@

           ;; Inactive top-down var -- activate it
           (first (map second na-tuples))
-            (activation-actions s child-var-map x))));)
+            (activation-actions child-var-map x)))))
      (env/goal-map sas-problem)
      causal-graph dtgs child-var-map acyclic-succ-fn)))

@@ -346,8 +358,7 @@
 (defn make-if-deadlock-hla [hierarchy var dl-plan nodl-plan]
   (let [name [:if-deadlock var (map env/action-name dl-plan) (map env/action-name nodl-plan)]
         av   (action-var var)
-        pc   ;(:full-context hierarchy )#_
-             (util/safe-get-in hierarchy [:precondition-context-map var])]
+        pc   (util/safe-get-in hierarchy [:precondition-context-map var])]
     (reify :as this
       env/Action
        (action-name [] name)
@@ -363,8 +374,7 @@
 (defn make-achieve-precondition-hla [hierarchy var dst-val]
   (let [name [:achieve-precondition var dst-val]
         av   (action-var var)
-        pc   ;(:full-context hierarchy )#_
-             (util/safe-get-in hierarchy [:precondition-context-map var])]
+        pc   (util/safe-get-in hierarchy [:precondition-context-map var])]
     (reify :as this
       env/Action
        (action-name [] name)
@@ -404,14 +414,12 @@
   (let [name          [:fire-action effect-var]
         reduced-pm    (dissoc (:precond-map a) effect-var)
         child-var-map (:child-var-map hierarchy)
-        pc            ;(:full-context hierarchy ) #_
-                      ;(util/safe-get-in hierarchy [:precondition-context-map effect-var]) #_
-                      (into #{(action-var effect-var)}
-                            (apply concat
-                                   (for [p (keys reduced-pm)]
-                                     (cons (free-var p)
-                                           (cons (parent-var p effect-var)
-                                                 (get-in hierarchy [:precondition-context-map p]))))))]
+        pc            (into #{(action-var effect-var)}
+                        (apply concat
+                          (for [p (keys reduced-pm)]
+                            (cons (free-var p)
+                                  (cons (parent-var p effect-var)
+                                        (get-in hierarchy [:precondition-context-map p]))))))]
 ;    (println "FA" name)
   (reify :as this
     env/Action
@@ -441,7 +449,7 @@

           ;; Inactive precondition -- needs to be assigned.
           (util/find-first #(env/get-var s (free-var %)) (keys reduced-pm))
-            (for [a (activation-actions s child-var-map x)]
+            (for [a (activation-actions child-var-map x)]
               [a this])

           ;; Active top-down var -- add actions
@@ -451,7 +459,7 @@

           ;; Inactive top-down var -- activate it
           (first (map second na-tuples))
-            (for [a (activation-actions s child-var-map x)]
+            (for [a (activation-actions child-var-map x)]
               [a this])

           ;; Nothing to do here -- return upwards, or fail if goal-var
@@ -475,13 +483,6 @@
                       (for [v as] (free-var v))
                       (for [v as] (action-var v))
                       (for [v as, c (cvm v), :when (as c)] (parent-var v c))))]))]
-;    (println)
-;    (util/pp-map av-map)
-;    (println)
-;    (util/pp-map pc-map)
-;    (println)
-;    (println (env/current-context (env/initial-state env)))
-;    (println (= (env/current-context (env/initial-state env)) (get pc-map sas/goal-var-name)))
     (hierarchy/SimpleHierarchicalEnv
      env
      [(make-fire-action-hla
@@ -503,15 +504,44 @@
   [(asplan-skip-solution-name sol) rew])

+
+;; TODO: faster & early deadlock detection.
+;; TODO: detect "out-of-context" deadlock, fail immediately.
+;; TODO: precond ordering when we activate (handled by activation-actions?)
+
+
 ;  (let [e (make-random-infinite-taxi-sas2 1 2 1 2)] (println (time (run-counted #(uniform-cost-search e)))) (println (time (run-counted #(asplan-solution-pair-name (uniform-cost-search (make-asplan-env e))))))  (println (debug 0 (time (run-counted #(asplan-solution-pair-name (dsh-ucs-inverted (make-asplan-skip-henv e))))))))

 ; (let [e (make-random-infinite-taxi-sas2 1 2 1 2)] (interactive-hierarchical-search (make-asplan-skip-henv e)))

 ; (let [e (make-random-infinite-taxi-sas2 2 2 2 2)] (interactive-hierarchical-search (make-asplan-skip-henv e)))

-
-;; TODO: faster & early deadlock detection.
-;; TODO: precond ordering when we activate (handled by activation-actions?)
+; (let [e (force (nth ipc2-logistics 0))] (println (time (run-counted #(uniform-cost-search e)))) (println (time (run-counted #(asplan-solution-pair-name (uniform-cost-search (make-asplan-env e))))))  (println (debug 0 (time (run-counted #(asplan-skip-solution-pair-name (dsh-ucs-inverted (make-asplan-skip-henv e))))))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
 (comment ; May use later for more fine-grained stuff.
  (defn split-preconds
    "Return [deadlocked matching free-unmatching reserved-unmatching]"
@@ -534,12 +564,7 @@
 ; Can return either a state where precondition accomplished, or
 ; there exist a chain of actions (posisbly empy) leading to a precondition assigned
 ; outside the context of this precond.
-
-
 (comment
-
-
-
 (defn make-fire-action-hla [hierarchy var action]
   (assert (= var (key (util/safe-singleton (:effect-map action)))))
   (let [name [:fire var]
@@ -656,4 +681,24 @@
             eval true
             false)
           (can-use-next? hierarchy effect-var eval p (env/get-var s p))))
-      ((util/safe-get hierarchy :child-var-map) effect-var)))))+      ((util/safe-get hierarchy :child-var-map) effect-var)))))
+
+
+
+
+(comment ;; Not actually needed -- use below instead.
+  (defn make-fire-action-action [{:keys [name precond-map effect-map reward] :as factored-primitive}]
+   (let [[evar eval] (util/safe-singleton (seq effect-map))]
+     (env/FactoredPrimitive
+      [::Fire name]
+      (into precond-map
+            (cons [(action-var evar) factored-primitive]
+                  (for [[pvar pval] (dissoc precond-map evar)]
+                    [(parent-var pvar evar) true])))
+      (into effect-map
+            (cons [(action-var evar) nil]
+                  (apply concat
+                         (for [[pvar pval] (dissoc precond-map evar)]
+                           [[(parent-var pvar evar) false]
+                            [(free-var evar) true]]))))
+      0))))


Rewrote rating-matrix bolt in terms of data-updater's return function

--- src/storm_spec.clj
+++ src/storm_spec.clj
@@ -37,28 +37,26 @@

 (defn data-updater [update-fn & [init-fn]]
-  "This isn't hooked up yet, but I'm hoping we can use something like this for
-  abstracting the common pattern of storing/fetching results by conv-id"
-  (let [init-fn #(identity nil)]
+  "This function abstracts the common pattern of fetching (or initing if necessary) an item from a
+  data dictionary, then updating it based on the specified updated function. Useful since our bolts
+  store data by conversation id."
+  (let [init-fn (or init-fn #(identity nil))]
     (fn [data conv-id & inputs]
       (let [value (or (get data conv-id) (init-fn))
             new-value (apply update-fn value inputs)]
         (assoc data conv-id new-value)))))

+; This is a little bit of a hack. Need to get pca working on matrices with just a couple of elements still...
 (def init-matrix (->RatingMatrix ["p1" "p2" "p3"] ["c1" "c2" "c3"] [[1 1 0] [0 1 -1] [0 -1 1]]))

 (defbolt rating-matrix ["conv-id" "rating-matrix"] {:prepare true}
   [conf context collector]
   (let [data (atom {})
-        ; This is a function which we can call as a transaction to update our data atom
-        update-data (fn [data conv-id reaction]
-                      (let [rating-matrix (or (get data conv-id) init-matrix)
-                            rating-matrix (update-rating-matrix rating-matrix [reaction])]
-                        (assoc data conv-id rating-matrix)))]
     (bolt (execute [tuple]
       (let [[conv-id reaction] (.getValues tuple)]
-        (println "RUNNING BOLT")
-        (swap! data update-data conv-id reaction)
+        (swap! data
+               (data-updater #(update-rating-matrix % [reaction]) #(identity init-matrix))
+               conv-id)
         (emit-bolt! collector
                     [conv-id (ic.core/matrix (:matrix (get @data conv-id)))]
                     :anchor tuple))))))
@@ -75,7 +73,6 @@
         (let [pcs (get @data conv-id)
               proj (pca-project rating-matrix pcs)]
           (emit-bolt! collector [conv-id pcs proj])))))))
-    ;{:pca pca :components components :pc1 pc1 :pc2 pc2 :x1 x1 :x2 x2})))))

 ;(defbolt clusters ["clusters"] {:prepare true}


Move monster and player defs.

Move monster and player defs.

--- src/isla/story.clj
+++ src/isla/story.clj
@@ -12,6 +12,13 @@
 (defprotocol Queryable
   (get-all-items [this])
   (get-item [this name]))
+(defrecord Monster [name summary])
+(def monster-defaults ["" ""])
+
+(defrecord Player [name summary room])
+(def player-defaults ["" "" :undefined])
+
+

 (defprotocol Playable

@@ -37,11 +44,6 @@
           nil)))))

-(defrecord Monster [name summary])
-(def monster-defaults ["" ""])
-
-(defrecord Player [name summary room])
-(def player-defaults ["" "" :undefined])

 (defrecord Room [name summary items exit])
 (def room-defaults ["" "" [] :undefined])


Add creturn fn.  Creates hash of story and output.

--- src/isla/story.clj
+++ src/isla/story.clj
@@ -96,6 +96,10 @@
           {}
           seq-))

+(defn creturn
+  ([story] {:sto story :out nil})
+  ([story output] {:sto story :out output}))
+
 (def types
   {
    "monster" {:type isla.story.Monster :defaults monster-defaults}


Removed empty file.

Removed empty file.

--- src/kosha/core.clj
+++ src/kosha/core.clj
@@ -1,6 +0,0 @@
-(ns kosha.core)
-
-(defn foo
-  "I don't do a whole lot."
-  [x]
-  (println x "Hello, World!"))


fixing wrong license paste

fixing wrong license paste

--- src/kvm/common.clj
+++ src/kvm/common.clj
@@ -9,93 +9,11 @@
   See the License for the specific language governing permissions and
   limitations under the License.)

-(ns kvm.provider
-  (:require
-    [kvm.validations :refer (provider-validation)]
-    [clojure.core.strint :refer (<<)]
-    [kvm.clone :refer (clone-domain domain-zip)]
-    [kvm.disks :refer (clear-volumes)]
-    [kvm.common :refer (connect get-domain state)]
-    [supernal.sshj :refer (ssh-up?)]
-    [celestial.core :refer (Vm)]
-    [taoensso.timbre :as timbre]
-    [celestial.persistency.systems :as s]
-    [celestial.provider :refer (mappings selections transform os->template wait-for wait-for-ssh)]
-    [celestial.model :refer (translate vconstruct hypervisor*)])
-  (:import org.libvirt.LibvirtException))
-
-(timbre/refer-timbre)
-
-(defn connection [{:keys [host username port]}]
-  (connect (<< "qemu+ssh://~{username}@~{host}:~{port}/system")))
-
-(defmacro with-connection [& body]
-  `(let [~'connection (connection ~'node)] (do ~@body)))
-
-(defn wait-for-status [instance req-stat timeout]
-  "Waiting for ec2 machine status timeout is in mili"
-  (wait-for {:timeout timeout} #(= req-stat (.status instance))
-    {:type ::kvm:status-failed :status req-stat :timeout timeout}
-      "Timed out on waiting for status"))
-
-
-(defrecord Domain [system-id node domain]
-  Vm
-  (create [this]
-    (with-connection
-      (let [image (get-in domain [:image :template]) target (select-keys domain [:name :cpu :ram])]
-        (clone-domain connection image target)
-        (wait-for-status this "running" [5 :minute])
-         this
-        )))
-
-  (delete [this]
-    (with-connection
-      (clear-volumes connection (domain-zip connection (domain :name)))
-      (.undefine (get-domain connection (domain :name))))
-    )
-
-  (start [this]
-    (with-connection
-      (when-not (= (.status this) "running")
-        (.create (get-domain connection (domain :name))))))
-
-  (stop [this]
-    (with-connection
-      (.destroy (get-domain connection (domain :name)))
-      (wait-for-status this "shutoff" [5 :minute])
-      ))
-
-  (status [this]
-    (with-connection
-      (try
-        (state (get-domain connection (domain :name)))
-          (catch LibvirtException e (debug (.getMessage e)) false))))
-
-  (ip [this]))
-
-(defn machine-ts
-  "Construcuting machine transformations"
-  [{:keys [hostname domain] :as machine}]
-   {:name (fn [hostname] (<< "~{hostname}.~{domain}"))
-    :image (fn [os] ((os->template :kvm) os))})
-
-(defmethod translate :kvm [{:keys [machine kvm] :as spec}]
-   (-> machine
-     (mappings {:os :image :hostname :name})
-     (transform (machine-ts machine))
-     (selections [[:name :user :image :cpu :ram]])))
-
-(defmethod vconstruct :kvm [{:keys [kvm machine system-id] :as spec}]
-   (let [[domain] (translate spec) {:keys [node]} kvm]
-     (provider-validation domain)
-     (->Domain system-id (hypervisor* :kvm :nodes node) domain)))
-
 (ns kvm.common
- (:require [clojure.zip :as zip])
- (:import
-    java.text.SimpleDateFormat
-    org.libvirt.Connect))
+  (:require [clojure.zip :as zip])
+  (:import
+     java.text.SimpleDateFormat
+     org.libvirt.Connect))

 (defn connect
    "Connecting"


first version of or-elim special

first version of or-elim special

--- src/latte/prop.clj
+++ src/latte/prop.clj
@@ -364,6 +364,64 @@
     (have c C :by (b H3))
     (qed c)))

+
+;; (or A B)
+;; = (forall [C :type]
+;;       (forall [_ (forall [_ A] C)]
+;;          (forall [_ (forall [_ B C])]
+;;               C)))
+
+(defn decompose-or-type [def-env ctx t]
+  (if (clojure.core/and (seq? t)
+                        (= (count t) 3)
+                        (= (first t) #'latte.prop/or))
+    [:ok (second t) (nth t 2)]
+    (let [[t ok?] (latte.kernel.norm/delta-step def-env t)]
+      (if ok?
+        (recur def-env ctx t)
+        (let [t (latte.kernel.norm/normalize def-env ctx t)]
+          (if-not (stx/prod? t)
+            [:ko nil nil]
+            (let [[_ [C _] body] t]
+              (if-not (stx/prod? body)
+                [:ko nil nil]
+                (let [[_ [_ AC] C'] body]
+                  (if-not (and (= C' C) (stx/prod? AC))
+                    [:ko nil nil]
+                    (let [[_ [_ A] C'] AC]
+                      (if-not (and (= C' C) (stx/prod? body))
+                        [:ko nil nil]
+                        (let [[_ [_ BC] C'] body]
+                          (if-not (and (= C' C) (stx/prod? AC))
+                            [:ko nil nil]
+                            (let [[_ [_ B] C'] BC]
+                              (if-not (= C' C)
+                                [:ko nil nil]
+                                [:ok A B]))))))))))))))))
+
+(defspecial or-elim%
+  "A special elimination rule that takes a proof
+ `or-term` of type `(or A B)`, a proposition `prop`,
+a proof `left-proof` of type `(==> A prop)`,
+a proof `right-proof` of type `(==> B prop)`, and thus
+concludes that `prop` holds by `[[or-elim]]`.
+
+This is (for now) the easiest rule to use for proof-by-cases."
+  [def-env ctx or-term prop left-proof right-proof]
+  (let [[status ty] (ty/type-of-term def-env ctx or-term)]
+    (if (= status :ko)
+      (throw (ex-info "Cannot type term." {:special 'latte.prop/or-elim%
+                                           :term or-term
+                                           :from ty}))
+      (do
+        ;; (println "[and-elim-left%] ty=" ty)
+        (let [[status A B] (decompose-or-type def-env ctx ty)]
+          (if (= status :ko)
+            (throw (ex-info "Not an `or`-type." {:special 'latte.prop/or-elim%
+                                                 :term or-term
+                                                 :type ty}))
+            [(list #'or-elim A B) or-term prop left-proof right-proof]))))))
+
 (defthm or-not-elim-left
   "An elimination rule for disjunction, simpler than [[or-elim]].
 This eliminates to the left operand."


Parameterize oauth2 login expiry time

Parameterize oauth2 login expiry time

Also, extend default to 30 days

--- src/yada/oauth.clj
+++ src/yada/oauth.clj
@@ -154,9 +154,10 @@
             ;; The function that will ultimately call the third-party API for user-details.
             ;; First argument is the access-token
             :handler (s/=> {s/Any s/Any} {:access-token s/Str :openid-claims {s/Str s/Str}})
+            (s/optional-key :cookie-expiry-period)
             }]

-  (let [{:keys [access-token-url client-id client-secret secret redirect-uri handler]} opts]
+  (let [{:keys [access-token-url client-id client-secret secret redirect-uri handler cookie-expiry-period]} opts]
     (assert handler)
     (resource
      (merge
@@ -213,7 +214,7 @@
                     (d/error-deferred (ex-info "Forbidden" {:status 403}))

                     ;; TODO: Refresh tokens
-                    (let [expires (time/plus (time/now) (time/minutes 15)) ; TODO parameterize
+                    (let [expires (time/plus (time/now) (or cookie-expiry-period (time/days 30))) ; TODO parameterize
                           cookie {:value (jwe/encrypt data secret)
                                   :expires expires
                                   :http-only true}]


fix dbn

fix dbn

--- src/neuseg/dbn.clj
+++ src/neuseg/dbn.clj
@@ -8,7 +8,7 @@
   (/ (+ 1 val) 2))

 (defn- vectorize [line dim]
-  (new-vector (map #(normalize (.Double %)) (clojure.string/split line #" ")) dim))
+  (new-vector (map #(normalize (Double. %)) (clojure.string/split line #" ")) dim))

 (defn create [layers]
   (DBN. (int-array layers)))
@@ -17,14 +17,16 @@
   (with-open [rdr (clojure.java.io/reader train-file-name)]
     (let [data (line-seq rdr)
           [total idm odm] (clojure.string/split (first data) #" ")]
-      (doall (map #(.pretrain nn k lr (vectorize % idm))
+      (doall (map #(.pretrain nn k lr (vectorize % (Integer. idm)))
                   (flatten (partition 1 2 (rest (line-seq rdr)))))))))

 (defn finetune [nn lr train-file-name]
   (with-open [rdr (clojure.java.io/reader train-file-name)]
     (let [data (line-seq rdr)
-          [total idm odm] (clojure.string/split (first data) #" ")]
-      (doall (map #(.finetune lr (vectorize (first %) idm) (vectorize (second %) odm))
+          [total idm odm] (clojure.string/split (first data) #" ")
+          idm (Integer. idm)
+          odm (Integer. odm)]
+      (doall (map #(.finetune nn lr (vectorize (first %) idm) (vectorize (second %) odm))
                   (partition 2 (rest (line-seq rdr))))))))

 (defn predict [nn input dim]
@@ -38,6 +40,8 @@
   (with-open [rdr (clojure.java.io/reader test-file-name)]
     (let [data (line-seq rdr)
           [total idm odm] (clojure.string/split (first data) #" ")
+          idm (Integer. idm)
+          odm (Integer. odm)
           tfn (testfun nn idm odm)]
       (/ (reduce + (map #(tfn (vectorize (first %) idm) (vectorize (second %) odm))
                         (partition 2 (rest (line-seq rdr))))) (Double. total)))))


bumped up reagent-forms

bumped up reagent-forms

--- resources/leiningen/new/reagent_frontend/project.clj
+++ resources/leiningen/new/reagent_frontend/project.clj
@@ -7,7 +7,7 @@
   :dependencies [[org.clojure/clojure "1.8.0" :scope "provided"]
                  [org.clojure/clojurescript "1.7.228" :scope "provided"]
                  [reagent "0.5.1"]
-                 [reagent-forms "0.5.15"]
+                 [reagent-forms "0.5.21"]
                  [reagent-utils "0.1.7"]
                  [secretary "1.2.3"]]