(ns babel.generate
  (:refer-clojure :exclude [assoc-in get-in deref resolve find parents])
  (:require
   [babel.index :refer [intersection-with-identity]]
   #?(:clj [clojure.tools.logging :as log])
   #?(:cljs [babel.logjs :as log])
   [clojure.math.combinatorics :as combo]
   [clojure.string :as string]
   [dag_unify.core :refer [assoc-in assoc-in! copy create-path-in
                           dissoc-paths fail-path get-in fail? strip-refs unify unify!]]))

;; during generation, will not decend deeper than this when creating a tree:
;; TODO: should also be possible to override per-language.
(def ^:const max-depth 10)
;; use map or pmap.
(def ^:const mapfn pmap)

(def ^:const handle-unify-fail #(log/debug %))
(def ^:const throw-exception-on-unify-fail false)

(def ^:const shufflefn
  (fn [x]
    ;; deterministic generation:
;;    x
    ;; nondeterministic generation
    (lazy-seq (shuffle x))

    ))

(declare add-comp-to-bolts)
(declare add-comps-to-bolt)
(declare add-to-bolt-at-path)
(declare get-bolts-for)
(declare get-lexemes)
(declare lightning-bolts)
(declare comp-paths)
(declare gen)
(declare show-spec)

(defn generate
  "Return one expression matching spec _spec_ given the model _model_."
  [spec language-model]
  ;;
  ;; Return the tree of an expression, generated by the given model,
  ;; that satisfies given spec:
  ;;
  ;; The tree will look like:
  ;;
  ;; Where H is the head of a certain node in the tree, and C
  ;; is the complement. Terminal nodes are lexemes given by the model.
  ;;
  ;;       H
  ;;      / \
  ;;     H   C
  ;;        / \
  ;;       H   C
  ;;
  ;; A convenient wrapper around (defn gen) (below).

  (log/debug (str "(generate) with model named: " (:name language-model)))
  (first (gen spec language-model 0)))

(defn gen
  "Return a lazy sequence of every possible expression given the spec and model,
  each of whose depth is no greater than the given depth. Trees are returned in
  ascending depth."
  [spec model depth & [from-bolts]]
  ;;
  ;; Given a spec and a model, return the (potentially infinite) set
  ;; of all trees, in ascending head-depth, that satisfy the given spec.
  ;;
  ;; 'Head-depth' means the depth of the tree, measured by longest path of
  ;; only H's from the root down to a leaf, minus 1. In other words, if a tree has
  ;; head-depth=N, then it has as its longest H path within it [H..H..H] whose
  ;; length is N+1.
  ;;
  ;; These trees look like:
  ;;
  ;;  First all the head-depth=0 trees (simply lexemes) that satisfy the spec:
  ;;
  ;;         H .. H ..

  ;;   Then we have the trees of head-depth=1 that satisfy the spec:
  ;;
  ;;       H         H        H      (note that the last-shown tree has
  ;;  ..  / \  ..   / \  ..  / \  ..  a head-depth of 1, not 2, because
  ;;     H   C     C   H    C   H     there is no path [H->H->H], but
  ;;                       / \         there is a path [H->H].
  ;;                      H   C
  ;;
  ;;   And then all trees of head-depth=2 that satisfy the spec:
  ;;
  ;;
  ;;       H        H        H
  ;;      / \      / \      / \
  ;;  .. H   C .. H   C .. C   H ..
  ;;    /        / \          / \
  ;;   H        C   H        C   H
  ;;
  ;; And so on.
  ;;
  ;;
  (if (nil? spec)
    ;;    (throw (Exception. (str "wtf.")))
    nil
    (do
;;    (println (str "gen@" depth "; spec=" (dag_unify.core/strip-refs spec)))
  (log/trace (str "gen@" depth "; spec=" (show-spec spec)))
  (when (< depth max-depth)
    (let [bolts (or from-bolts
                    (get-bolts-for model spec
                                   depth))]
      (if (not (empty? bolts))
        (do
          (log/trace (str "gen@" depth "; found bolts with spec=" (dag_unify.core/strip-refs spec)))
          (lazy-cat
           (let [bolt (first bolts)]
             (or
              (and (= false (get-in bolt [:phrasal] true))
                   ;; This is not a bolt but rather simply a lexical head,
                   ;; so just return a list with this lexical head:
                   [bolt])
              ;; ..otherwise it's a phrase, so return the lazy
              ;; sequence of adding all possible complements at every possible
              ;; position at the bolt.
              (add-comps-to-bolt bolt model
                                 (reverse (comp-paths depth)))))
           (gen spec model depth (rest bolts))))
        (if (not (= false (get-in spec [:phrasal] true)))
          (gen spec model (+ 1 depth)))))))))

;; Wrapper around (defn lightning-bolts) to provide a way to
;; test indexing and memoization strategies.
(defn get-bolts-for
  "Return every possible bolt for the given model and spec."
  [model spec depth]
  (let [search-for-key
        (dag_unify.core/strip-refs
         {:synsem {:sem {:aspect (get-in spec [:synsem :sem :aspect] :top)
                         :reflexive (get-in spec [:synsem :sem :reflexive] :top)
                         :tense (get-in spec [:synsem :sem :tense] :top)}
                   :subcat (get-in spec [:synsem :subcat] :top)
                   :cat (get-in spec [:synsem :cat] :top)}
          :depth depth})

        debug (log/trace (str "looking for key: "
                             search-for-key))

        bolts ;; check for bolts compiled into model
        (get (-> model :bolts)
             search-for-key)]
    (cond
      (not (nil? bolts))
      (do
        (log/trace (str "found compiled bolts."))
        (shufflefn (->> bolts
                        (map #(unify spec %))
                        (filter #(not (= :fail %))))))
      true
      (do (log/trace (str "no compiled bolts found for: " search-for-key))
          (lazy-seq (lightning-bolts model spec 0 depth))))))

(defn lightning-bolts
  "Return every possible bolt for the given model and spec. Start at the given depth and
   keep generating until the given max-depth is reached."
  [model spec depth max-depth & [use-candidate-parents]]
  ;; 'lightning bolts' look like:
  ;;
  ;;
  ;;   H        H    H
  ;;    \      /      \
  ;;     H    H        H        ...
  ;;    /      \        \
  ;;   H        ..       ..
  ;;    \
  ;;     ..
  ;;
  ;; Each bolt is a tree with only one child per parent: the head child.
  ;; Each head child may be a leaf or
  ;; otherwise has a child with the same two options (leaf or a head child),
  ;; up to the maximum depth.
  (log/debug (str "lightning-bolts: depth=" depth (if use-candidate-parents
                                                    (str "; using ucp: " (count use-candidate-parents)))))
  (if (and (< depth max-depth)
           (not (= false (get-in spec [:phrasal] true))))
    (let [candidate-parents (or use-candidate-parents
                                (->>
                                 (:grammar model)
                                 (map (fn [rule]
                                        (let [result (unify rule spec)]
                                          (if
                                            (not (= :fail result))
                                            (log/debug (str "rule:" (:rule rule)
                                                            " => "
                                                            "OK")))
                                          result)))
                                 (filter #(not (= :fail %)))
                                 (shufflefn)))]
      (log/debug (str "candidate-parents emptiness at depth:" depth ":"
                      (empty? candidate-parents)))
      (if (not (empty? candidate-parents))
        (let [candidate-parent (first candidate-parents)]
          (lazy-cat
           (->> (lightning-bolts model
                                 (get-in candidate-parent [:head])
                                 (+ 1 depth)
                                 max-depth)
                (map (fn [head]
                       (assoc-in candidate-parent [:head] head))))
           (lightning-bolts model spec depth max-depth (rest candidate-parents))))
        (do
          (log/debug (str "no rules found at depth: " depth " for spec: "
                          (dag_unify.core/strip-refs spec)))
          candidate-parents)))
    (shufflefn (get-lexemes model spec))))

(defn add-comps-to-bolt
  "bolt + paths => trees"
  [bolt model comp-paths]
  (if (and true (not (empty? comp-paths)))
    (let [comp-path (first comp-paths)]
      (log/debug (str "add-comps-to-bolt: " ((:morph-ps model) bolt) "@[" (string/join " " comp-path) "]"))
      (add-comp-to-bolts
       (add-comps-to-bolt bolt model (rest comp-paths))
       comp-path
       model))
    [bolt]))

(defn add-comp-to-bolts
  "bolts + path => partial trees"
  [bolts path model]
  (if (not (empty? bolts))
    (let [bolt (first bolts)]
      (log/debug (str "add-comp-to-bolts: " ((:morph-ps model) bolt) "@[" (string/join " " path) "]"))
      (lazy-cat
       (add-to-bolt-at-path bolt path model)
       (add-comp-to-bolts (rest bolts) path model)))))

(defn hd [] :head)

(defn comp-paths
  "Find all paths to all complements (both terminal and non-terminal) given a depth. Returned in
   ascending length (shortest first)."
  ;; e.g., a tree of depth 2
  ;; will have the following paths:
  ;;   [:comp] [:head :comp]
  ;;   because it looks like:
  ;;
  ;;   H
  ;;  / \
  ;; C   H
  ;;    / \
  ;;   H   C
  ;;
  [depth]
  (cond
    (= depth 0)
    []
    (= depth 1)
    (list [:comp])
    true
    (cons
     (concat (take (- depth 1)
                   (repeatedly hd))
             [:comp])
     (comp-paths (- depth 1)))))

;; {:synsem {:cat :verb, :infl :imperfect, :sem {:tense :past, :aspect :progressive}, :subcat []}}

(defn add-to-bolt-at-path
  "generate all complements for bolt at given path, and create a partial tree: bolt + complement => partial tree"
  [bolt path model]
  (->>
   (gen (get-in bolt path) model 0) ;; generate all complements for _bolt_ at _path_.
   (map #(let [partial-tree
               (dag_unify.core/assoc-in! (dag_unify.core/copy bolt) path %)] ;; add the complement to the bolt at _path_.
           ;; apply model's :default-fn, if any.
           ;; TODO: default-fn should return a sequence of partial trees,
           ;; not just one.
           (if (:default-fn model)
             (first ((:default-fn model) partial-tree))
             partial-tree)))))

(defn get-lexemes [model spec]
  "Get lexemes matching the spec. Use a model's index if available, where the index is a function that we call with _spec_ to get a set of indices. otherwise use the model's entire lexeme."
  (->>
   (if (= false (get-in spec [:phrasal] false))
     (if-let [index-fn (:index-fn model)]
       (index-fn spec)
       (do
         (log/warn (str "get-lexemes: no index found: using entire lexicon."))
         (flatten (vals
                   (or (:lexicon (:generate model)) (:lexicon model)))))))
   (filter #(or (= false (get-in % [:exception] false))
                (not (= :verb (get-in % [:synsem :cat])))))
   (map #(unify % spec))
   (filter #(not (= :fail %)))))

(defn show-spec [spec]
  (str "cat=" (get-in spec [:synsem :cat])
       (if (get-in spec [:rule])
         (str "; rule=" (strip-refs (get-in spec [:rule]))))
       (if (not (= (get-in spec [:synsem :agr] ::none) ::none))
         (str "; agr=" (strip-refs (get-in spec [:synsem :agr]))))
       (if (not (= (get-in spec [:synsem :sem :pred] ::none) ::none))
         (str "; pred=" (strip-refs (get-in spec [:synsem :sem :pred]))))
       (if (get-in spec [:synsem :subcat :1 :cat])
         (str "; subcat1=" (strip-refs (get-in spec [:synsem :subcat :1 :cat]))))
       (if (get-in spec [:synsem :subcat :2 :cat])
         (str "; subcat2=" (strip-refs (get-in spec [:synsem :subcat :2 :cat]))))
       (if (get-in spec [:synsem :subcat :3 :cat])
         (str "; subcat3=" (strip-refs (get-in spec [:synsem :subcat :3 :cat]))))
       (if (not (= (get-in spec [:phrasal] ::none) ::none))
         (str "; phrasal=" (strip-refs (get-in spec [:phrasal]))))))

(ns babel.generate
  (:refer-clojure :exclude [assoc-in get-in deref resolve find parents])
  (:require
   [babel.index :refer [intersection-with-identity]]
   #?(:clj [clojure.tools.logging :as log])
   #?(:cljs [babel.logjs :as log])
   [clojure.math.combinatorics :as combo]
   [clojure.string :as string]
   [dag_unify.core :refer [assoc-in assoc-in! copy create-path-in
                           dissoc-paths fail-path get-in fail? strip-refs unify unify!]]))

;; during generation, will not decend deeper than this when creating a tree:
;; TODO: should also be possible to override per-language.
(def ^:const max-depth 10)
;; use map or pmap.
(def ^:const mapfn pmap)

(def ^:const handle-unify-fail #(log/debug %))
(def ^:const throw-exception-on-unify-fail false)

(def ^:const shufflefn
  (fn [x]
    ;; deterministic generation:
;;    x
    ;; nondeterministic generation
    (lazy-seq (shuffle x))

    ))

(declare add-comp-to-bolts)
(declare add-comps-to-bolt)
(declare add-to-bolt-at-path)
(declare get-bolts-for)
(declare get-lexemes)
(declare lightning-bolts)
(declare comp-paths)
(declare gen)
(declare show-spec)

(defn generate
  "Return one expression matching spec _spec_ given the model _model_."
  [spec language-model]
  ;;
  ;; Return the tree of an expression, generated by the given model,
  ;; that satisfies given spec:
  ;;
  ;; The tree will look like:
  ;;
  ;; Where H is the head of a certain node in the tree, and C
  ;; is the complement. Terminal nodes are lexemes given by the model.
  ;;
  ;;       H
  ;;      / \
  ;;     H   C
  ;;        / \
  ;;       H   C
  ;;
  ;; A convenient wrapper around (defn gen) (below).

  (log/debug (str "(generate) with model named: " (:name language-model)))
  (first (gen spec language-model 0)))

(defn gen
  "Return a lazy sequence of every possible expression given the spec and model,
  each of whose depth is no greater than the given depth. Trees are returned in
  ascending depth."
  [spec model depth & [from-bolts]]
  ;;
  ;; Given a spec and a model, return the (potentially infinite) set
  ;; of all trees, in ascending head-depth, that satisfy the given spec.
  ;;
  ;; 'Head-depth' means the depth of the tree, measured by longest path of
  ;; only H's from the root down to a leaf, minus 1. In other words, if a tree has
  ;; head-depth=N, then it has as its longest H path within it [H..H..H] whose
  ;; length is N+1.
  ;;
  ;; These trees look like:
  ;;
  ;;  First all the head-depth=0 trees (simply lexemes) that satisfy the spec:
  ;;
  ;;         H .. H ..

  ;;   Then we have the trees of head-depth=1 that satisfy the spec:
  ;;
  ;;       H         H        H      (note that the last-shown tree has
  ;;  ..  / \  ..   / \  ..  / \  ..  a head-depth of 1, not 2, because
  ;;     H   C     C   H    C   H     there is no path [H->H->H], but
  ;;                       / \         there is a path [H->H].
  ;;                      H   C
  ;;
  ;;   And then all trees of head-depth=2 that satisfy the spec:
  ;;
  ;;
  ;;       H        H        H
  ;;      / \      / \      / \
  ;;  .. H   C .. H   C .. C   H ..
  ;;    /        / \          / \
  ;;   H        C   H        C   H
  ;;
  ;; And so on.
  ;;
  ;;
  (if (nil? spec)
    ;;    (throw (Exception. (str "wtf.")))
    nil
    (do
;;    (println (str "gen@" depth "; spec=" (dag_unify.core/strip-refs spec)))
  (log/trace (str "gen@" depth "; spec=" (show-spec spec)))
  (when (< depth max-depth)
    (let [bolts (or from-bolts
                    (get-bolts-for model spec
                                   depth))]
      (if (not (empty? bolts))
        (do
          (log/trace (str "gen@" depth "; found bolts with spec=" (dag_unify.core/strip-refs spec)))
          (lazy-cat
           (let [bolt (first bolts)]
             (or
              (and (= false (get-in bolt [:phrasal] true))
                   ;; This is not a bolt but rather simply a lexical head,
                   ;; so just return a list with this lexical head:
                   [bolt])
              ;; ..otherwise it's a phrase, so return the lazy
              ;; sequence of adding all possible complements at every possible
              ;; position at the bolt.
              (add-comps-to-bolt bolt model
                                 (reverse (comp-paths depth)))))
           (gen spec model depth (rest bolts))))
        (if (not (= false (get-in spec [:phrasal] true)))
          (gen spec model (+ 1 depth)))))))))

;; Wrapper around (defn lightning-bolts) to provide a way to
;; test indexing and memoization strategies.
(defn get-bolts-for
  "Return every possible bolt for the given model and spec."
  [model spec depth]
  (let [search-for-key
        (dag_unify.core/strip-refs
         {:synsem {:sem {:aspect (get-in spec [:synsem :sem :aspect] :top)
                         :reflexive (get-in spec [:synsem :sem :reflexive] :top)
                         :tense (get-in spec [:synsem :sem :tense] :top)}
                   :subcat (get-in spec [:synsem :subcat] :top)
                   :cat (get-in spec [:synsem :cat] :top)}
          :depth depth})

        debug (log/trace (str "looking for key: "
                             search-for-key))

        bolts ;; check for bolts compiled into model
        (get (-> model :bolts)
             search-for-key)]
    (cond
      (not (nil? bolts))
      (do
        (log/trace (str "found compiled bolts."))
        (shufflefn (->> bolts
                        (map #(unify spec %))
                        (filter #(not (= :fail %))))))
      true
      (do (log/trace (str "no compiled bolts found for: " search-for-key))
          (lazy-seq (lightning-bolts model spec 0 depth))))))

(defn lightning-bolts
  "Return every possible bolt for the given model and spec. Start at the given depth and
   keep generating until the given max-depth is reached."
  [model spec depth max-depth & [use-candidate-parents]]
  ;; 'lightning bolts' look like:
  ;;
  ;;
  ;;   H        H    H
  ;;    \      /      \
  ;;     H    H        H        ...
  ;;    /      \        \
  ;;   H        ..       ..
  ;;    \
  ;;     ..
  ;;
  ;; Each bolt is a tree with only one child per parent: the head child.
  ;; Each head child may be a leaf or
  ;; otherwise has a child with the same two options (leaf or a head child),
  ;; up to the maximum depth.
  (log/debug (str "lightning-bolts: depth="
                  depth (if use-candidate-parents
                          (str "; using ucp: "
                               (count use-candidate-parents)))))
  (if (and (< depth max-depth)
           (not (= false (get-in spec [:phrasal] true))))
    (let [candidate-parents
          (or use-candidate-parents
              (let [filtered
                    (->>
                     (:grammar model)
                     (map (fn [rule]
                            (let [result (unify rule spec)]
                              (cond (= :fail result)
                                    (log/debug (str "rule:" (:rule rule)
                                                    " => "
                                                    "FAIL between:"
                                                    (:rule rule)
                                                    " and: "
                                                    (strip-refs spec)
                                                    "; fail path:"
                                                    (dag_unify.core/fail-path
                                                     rule
                                                     spec)))
                                    true
                                    (log/debug (str "rule:" (:rule rule)
                                                    " => "
                                                    "OK")))
                              result)))
                     (filter #(not (= :fail %)))
                     (shufflefn))]
                (if (empty? filtered)
                  (log/debug (str "no rules found for spec:"
                                  (dag_unify.core/strip-refs spec)
                                  " at depth: " depth)))
                filtered))]
      (if (not (empty? candidate-parents))
        (let [candidate-parent (first candidate-parents)]
          (log/debug (str "creating bolts with: "
                          (:rule candidate-parent)
                          " and spec: " (dag_unify.core/strip-refs
                                         (get-in candidate-parent [:head]))))
          (lazy-cat
           (->> (lightning-bolts model
                                 (get-in candidate-parent [:head])
                                 (+ 1 depth)
                                 max-depth)
                (map (fn [head]
                       (assoc-in candidate-parent [:head] head))))
           (lightning-bolts model spec depth max-depth (rest candidate-parents))))
        []))
    (let [lexemes
          (shufflefn (get-lexemes model spec))]
      (if (empty? lexemes)
        (log/debug (str "lightning-bolts: no lexemes at depth: " depth
                        " for spec: " (dag_unify.core/strip-refs spec)))
        (log/debug (str "lightning-bolts: one or more lexemes at depth: " depth
                        " for spec: " (dag_unify.core/strip-refs spec))))
      lexemes)))

(defn add-comps-to-bolt
  "bolt + paths => trees"
  [bolt model comp-paths]
  (if (and true (not (empty? comp-paths)))
    (let [comp-path (first comp-paths)]
      (log/debug (str "add-comps-to-bolt: " ((:morph-ps model) bolt) "@[" (string/join " " comp-path) "]"))
      (add-comp-to-bolts
       (add-comps-to-bolt bolt model (rest comp-paths))
       comp-path
       model))
    [bolt]))

(defn add-comp-to-bolts
  "bolts + path => partial trees"
  [bolts path model]
  (if (not (empty? bolts))
    (let [bolt (first bolts)]
      (log/debug (str "add-comp-to-bolts: " ((:morph-ps model) bolt) "@[" (string/join " " path) "]"))
      (lazy-cat
       (add-to-bolt-at-path bolt path model)
       (add-comp-to-bolts (rest bolts) path model)))))

(defn hd [] :head)

(defn comp-paths
  "Find all paths to all complements (both terminal and non-terminal) given a depth. Returned in
   ascending length (shortest first)."
  ;; e.g., a tree of depth 2
  ;; will have the following paths:
  ;;   [:comp] [:head :comp]
  ;;   because it looks like:
  ;;
  ;;   H
  ;;  / \
  ;; C   H
  ;;    / \
  ;;   H   C
  ;;
  [depth]
  (cond
    (= depth 0)
    []
    (= depth 1)
    (list [:comp])
    true
    (cons
     (concat (take (- depth 1)
                   (repeatedly hd))
             [:comp])
     (comp-paths (- depth 1)))))

;; {:synsem {:cat :verb, :infl :imperfect, :sem {:tense :past, :aspect :progressive}, :subcat []}}

(defn add-to-bolt-at-path
  "generate all complements for bolt at given path, and create a partial tree: bolt + complement => partial tree"
  [bolt path model]
  (->>
   (gen (get-in bolt path) model 0) ;; generate all complements for _bolt_ at _path_.
   (map #(let [partial-tree
               (dag_unify.core/assoc-in! (dag_unify.core/copy bolt) path %)] ;; add the complement to the bolt at _path_.
           ;; apply model's :default-fn, if any.
           ;; TODO: default-fn should return a sequence of partial trees,
           ;; not just one.
           (if (:default-fn model)
             (first ((:default-fn model) partial-tree))
             partial-tree)))))

(defn get-lexemes [model spec]
  "Get lexemes matching the spec. Use a model's index if available, where the index is a function that we call with _spec_ to get a set of indices. otherwise use the model's entire lexeme."
  (->>
   (if (= false (get-in spec [:phrasal] false))
     (if-let [index-fn (:index-fn model)]
       (index-fn spec)
       (do
         (log/warn (str "get-lexemes: no index found: using entire lexicon."))
         (flatten (vals
                   (or (:lexicon (:generate model)) (:lexicon model)))))))
   (filter #(or (= false (get-in % [:exception] false))
                (not (= :verb (get-in % [:synsem :cat])))))
   (map #(unify % spec))
   (filter #(not (= :fail %)))))

(defn show-spec [spec]
  (str "cat=" (get-in spec [:synsem :cat])
       (if (get-in spec [:rule])
         (str "; rule=" (strip-refs (get-in spec [:rule]))))
       (if (not (= (get-in spec [:synsem :agr] ::none) ::none))
         (str "; agr=" (strip-refs (get-in spec [:synsem :agr]))))
       (if (not (= (get-in spec [:synsem :sem :pred] ::none) ::none))
         (str "; pred=" (strip-refs (get-in spec [:synsem :sem :pred]))))
       (if (get-in spec [:synsem :subcat :1 :cat])
         (str "; subcat1=" (strip-refs (get-in spec [:synsem :subcat :1 :cat]))))
       (if (get-in spec [:synsem :subcat :2 :cat])
         (str "; subcat2=" (strip-refs (get-in spec [:synsem :subcat :2 :cat]))))
       (if (get-in spec [:synsem :subcat :3 :cat])
         (str "; subcat3=" (strip-refs (get-in spec [:synsem :subcat :3 :cat]))))
       (if (not (= (get-in spec [:phrasal] ::none) ::none))
         (str "; phrasal=" (strip-refs (get-in spec [:phrasal]))))))

improve logging

improve logging


(ns cheshire.custom
  (:require [cheshire.core :as core])
  (:import (java.io BufferedWriter ByteArrayOutputStream StringWriter)
           (java.util Date SimpleTimeZone)
           (java.text SimpleDateFormat)
           (org.codehaus.jackson.smile SmileFactory)
           (org.codehaus.jackson JsonFactory JsonGenerator JsonParser
                                 JsonParser$Feature)))

(set! *warn-on-reflection* true)

(def ^{:private true :tag JsonFactory} factory
  (doto (JsonFactory.)
    (.configure JsonParser$Feature/ALLOW_UNQUOTED_CONTROL_CHARS true)))

(def ^{:private true :tag SmileFactory} smile-factory
  (SmileFactory.))

(def ^{:dynamic true} *date-format* "yyyy-MM-dd'T'HH:mm:ss'Z'")

(defprotocol Jable
  (to-json [t jg]))

(defn ^String encode [obj & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [sw (StringWriter.)
          generator (.createJsonGenerator ^JsonFactory factory sw)]
      (if obj
        (to-json obj generator)
        (.writeNull generator))
      (.flush generator)
      (.toString sw))))

(defn ^String encode-stream [obj ^BufferedWriter w & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [generator (.createJsonGenerator factory w)]
      (to-json obj generator)
      (.flush generator)
      w)))

(defn encode-smile
  [obj & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [baos (ByteArrayOutputStream.)
          generator (.createJsonGenerator smile-factory baos)]
      (to-json obj generator)
      (.flush generator)
      (.toByteArray baos))))

;; there are no differences in parsing, but these are here to make
;; this a self-contained namespace if desired
(def parse core/decode)
(def parse-string core/decode)
(def parse-stream core/decode-stream)
(def parse-smile core/decode-smile)
(def parsed-seq core/parsed-seq)
(def decode core/parse-string)
(def decode-stream parse-stream)
(def decode-smile parse-smile)

;; aliases
(def generate-string encode)
(def generate-stream encode-stream)
(def generate-smile encode-smile)

(defn encode-nil [_ ^JsonGenerator jg]
  (.writeNull jg))

(extend nil
  Jable
  {:to-json encode-nil})

(defn encode-str [^String s ^JsonGenerator jg]
  (.writeString jg (str s)))

(extend java.lang.String
  Jable
  {:to-json encode-str})

(defn- encode-number [^java.lang.Number n ^JsonGenerator jg]
  (.writeNumber jg n))

(extend java.lang.Number
  Jable
  {:to-json encode-number})

(defn- encode-seq [s ^JsonGenerator jg]
  (.writeStartArray jg)
  (doseq [i s]
    (to-json i jg))
  (.writeEndArray jg))

(extend clojure.lang.ISeq
  Jable
  {:to-json encode-seq})

(extend clojure.lang.IPersistentVector
  Jable
  {:to-json encode-seq})

(extend clojure.lang.IPersistentSet
  Jable
  {:to-json encode-seq})

(defn- encode-date [^Date d ^JsonGenerator jg]
  (let [sdf (SimpleDateFormat. *date-format*)]
    (.setTimeZone sdf (SimpleTimeZone. 0 "UTC"))
    (.writeString jg (.format sdf d))))

(extend java.util.Date
  Jable
  {:to-json encode-date})

(extend java.util.UUID
  Jable
  {:to-json encode-str})

(defn- encode-bool [^Boolean b ^JsonGenerator jg]
  (.writeBoolean jg b))

(extend java.lang.Boolean
  Jable
  {:to-json encode-bool})

(defn- encode-named [^clojure.lang.Keyword k ^JsonGenerator jg]
  (.writeString jg (name k)))

(extend clojure.lang.Keyword
  Jable
  {:to-json encode-named})

(defn- encode-map [^clojure.lang.IPersistentMap m ^JsonGenerator jg]
  (.writeStartObject jg)
  (doseq [[k v] m]
    (.writeFieldName jg (if (instance? clojure.lang.Keyword k)
                          (name k)
                          (str k)))
    (to-json v jg))
  (.writeEndObject jg))

(extend clojure.lang.IPersistentMap
  Jable
  {:to-json encode-map})

(defn- encode-symbol [^clojure.lang.Symbol s ^JsonGenerator jg]
  (.writeString jg (str (:ns (meta (resolve s)))
                        "/"
                        (:name (meta (resolve s))))))

(extend clojure.lang.Symbol
  Jable
  {:to-json encode-symbol})

(defn add-encoder
  "Provide an encoder for a type not handled by Cheshire.

   ex. (add-encoder java.net.URL encode-string)

   See encode-str, encode-map, etc, in the cheshire.custom
   namespace for encoder examples."
  [cls encoder]
  (extend cls
    Jable
    {:to-json encoder}))

(defn remove-encoder [cls]
  "Remove encoder for a given type.

   ex. (remove-encoder java.net.URL)"
  (alter-var-root
   #'Jable
   #(assoc % :impls (dissoc (:impls %) cls)))
  (clojure.core/-reset-methods Jable))

(ns cheshire.custom
  (:require [cheshire.core :as core])
  (:import (java.io BufferedWriter ByteArrayOutputStream StringWriter)
           (java.util Date SimpleTimeZone)
           (java.text SimpleDateFormat)
           (org.codehaus.jackson.smile SmileFactory)
           (org.codehaus.jackson JsonFactory JsonGenerator JsonParser
                                 JsonParser$Feature)))

;;(set! *warn-on-reflection* true)

(def ^{:private true :tag JsonFactory} factory
  (doto (JsonFactory.)
    (.configure JsonParser$Feature/ALLOW_UNQUOTED_CONTROL_CHARS true)))

(def ^{:private true :tag SmileFactory} smile-factory
  (SmileFactory.))

(def ^{:dynamic true} *date-format* "yyyy-MM-dd'T'HH:mm:ss'Z'")

(defprotocol Jable
  (to-json [t jg]))

(defn ^String encode [obj & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [sw (StringWriter.)
          generator (.createJsonGenerator ^JsonFactory factory sw)]
      (if obj
        (to-json obj generator)
        (.writeNull generator))
      (.flush generator)
      (.toString sw))))

(defn ^String encode-stream [obj ^BufferedWriter w & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [generator (.createJsonGenerator factory w)]
      (to-json obj generator)
      (.flush generator)
      w)))

(defn encode-smile
  [obj & [^String date-format]]
  (binding [*date-format* (or date-format *date-format*)]
    (let [baos (ByteArrayOutputStream.)
          generator (.createJsonGenerator smile-factory baos)]
      (to-json obj generator)
      (.flush generator)
      (.toByteArray baos))))

;; there are no differences in parsing, but these are here to make
;; this a self-contained namespace if desired
(def parse core/decode)
(def parse-string core/decode)
(def parse-stream core/decode-stream)
(def parse-smile core/decode-smile)
(def parsed-seq core/parsed-seq)
(def decode core/parse-string)
(def decode-stream parse-stream)
(def decode-smile parse-smile)

;; aliases
(def generate-string encode)
(def generate-stream encode-stream)
(def generate-smile encode-smile)

(defn encode-nil [_ ^JsonGenerator jg]
  (.writeNull jg))

(extend nil
  Jable
  {:to-json encode-nil})

(defn encode-str [^String s ^JsonGenerator jg]
  (.writeString jg (str s)))

(extend java.lang.String
  Jable
  {:to-json encode-str})

(defn- encode-number [^java.lang.Number n ^JsonGenerator jg]
  (.writeNumber jg n))

(extend java.lang.Number
  Jable
  {:to-json encode-number})

(defn- encode-seq [s ^JsonGenerator jg]
  (.writeStartArray jg)
  (doseq [i s]
    (to-json i jg))
  (.writeEndArray jg))

(extend clojure.lang.ISeq
  Jable
  {:to-json encode-seq})

(extend clojure.lang.IPersistentVector
  Jable
  {:to-json encode-seq})

(extend clojure.lang.IPersistentSet
  Jable
  {:to-json encode-seq})

(defn- encode-date [^Date d ^JsonGenerator jg]
  (let [sdf (SimpleDateFormat. *date-format*)]
    (.setTimeZone sdf (SimpleTimeZone. 0 "UTC"))
    (.writeString jg (.format sdf d))))

(extend java.util.Date
  Jable
  {:to-json encode-date})

(extend java.util.UUID
  Jable
  {:to-json encode-str})

(defn- encode-bool [^Boolean b ^JsonGenerator jg]
  (.writeBoolean jg b))

(extend java.lang.Boolean
  Jable
  {:to-json encode-bool})

(defn- encode-named [^clojure.lang.Keyword k ^JsonGenerator jg]
  (.writeString jg (name k)))

(extend clojure.lang.Keyword
  Jable
  {:to-json encode-named})

(defn- encode-map [^clojure.lang.IPersistentMap m ^JsonGenerator jg]
  (.writeStartObject jg)
  (doseq [[k v] m]
    (.writeFieldName jg (if (instance? clojure.lang.Keyword k)
                          (name k)
                          (str k)))
    (to-json v jg))
  (.writeEndObject jg))

(extend clojure.lang.IPersistentMap
  Jable
  {:to-json encode-map})

(defn- encode-symbol [^clojure.lang.Symbol s ^JsonGenerator jg]
  (.writeString jg (str (:ns (meta (resolve s)))
                        "/"
                        (:name (meta (resolve s))))))

(extend clojure.lang.Symbol
  Jable
  {:to-json encode-symbol})

(defn add-encoder
  "Provide an encoder for a type not handled by Cheshire.

   ex. (add-encoder java.net.URL encode-string)

   See encode-str, encode-map, etc, in the cheshire.custom
   namespace for encoder examples."
  [cls encoder]
  (extend cls
    Jable
    {:to-json encoder}))

(defn remove-encoder [cls]
  "Remove encoder for a given type.

   ex. (remove-encoder java.net.URL)"
  (alter-var-root
   #'Jable
   #(assoc % :impls (dissoc (:impls %) cls)))
  (clojure.core/-reset-methods Jable))

remove warn-on-reflection

remove warn-on-reflection


(ns ttt.core
  "Core functionality: initialization, ticket creation, data operations"
  (:require [clojure.string :as cstr]
            [cljs.nodejs :as node]
            [cljs.reader :as reader]
            [goog.result :as result]))

;; Node modules
;; -------------
(def ^:private fs (node/require "fs"))
(def ^:private sys-exec (.-exec (node/require "child_process")))

(def ^:dynamic *repo-root* "./")

;; Base maps
;; ------------
(def base-pref-map
  {:types ["work" "bug"]
   :default-type "work"
   :points ["0" "1" "2" "3" "5" "8"]
   :default-ticket-points "0"
   :tag-on-complete? true
   :ticket-states ["open" "in-progress" "closed"] ;; these get kw-ized within ttt
   })

(def base-file-map
  {:releases {}
   :tickets []})

(def base-ticket-map
  {:summary ""
   :description ""
   :reported-by ""
   :owner ""
   :closed-by ""
   :points ""
   :type ""
   :states {}
   :current-state :open
   :history []
   :branch ""})

(def default-ticket-path (str *repo-root* "/tickets.edn"))

;; Core I/O functions
;; ------------------
;;
;; ### Safe Reading
;; Usually `safe-read` is defined as such:
;;
;;     (defn safe-read [s]
;;       (binding [*read-eval* false]
;;         (reader/read-string s))
;;
;; But ClojureScript doesn't have eval, so we get the simpler...
(defn safe-read [s]
  (reader/read-string s))

(defn read-edn-file
  "Read in a Clojure/EDN file, returning the data structure upon success.
  Throws an error if reading fails"
  [edn-file]
  (let [file-contents (.readFileSync fs edn-file "utf8")]
    (safe-read file-contents)))

(defn write-edn-file
  "Writes Clojure/EDN data to a file. Returns the data upon success.
  Throws an error when writing fails"
  [edn-file data]
  (let [file-contents (pr-str data)]
    (.writeFileSync fs edn-file file-contents)
    data))

(defn fs-exists? [fs-path]
  (.existsSync fs fs-path))

(defn file? [fs-path]
  (if (fs-exists? fs-path)
    (-> (.lstatSync fs fs-path) .isFile)
    false))

(defn directory? [fs-path]
  (if (fs-exists? fs-path)
    (-> (.lstatSync fs fs-path) .isDirectory)
    false))

;; System functions
;; ----------------
(defn exit
  ([]
   (exit 0))
  ([exit-code]
   (node/process.exit exit-code)))

;; Git functions
;; --------------
;;
;; ### The story
;; Node only allows for async command execution.
;; This quickly becomes a pain in an application like `ttt`.
;;
;; To get around this, we use Closure's `Result` - essentially a promise.
;; When coupled with an atom, we can perform system commands and await their
;; return using a blocking deference.  The trade-off is that we still need to
;; pass callbacks to the promise but at the call site (for example, in the
;; `main` namespace) where they have real context.

(defn git-config
  "Call the `git config` command to grab the value of a given key.
  Pass in a callback to handle the output/return string"
  [config-key callback]
  (sys-exec (str "git config --get " k)
              (fn [_ out _]
                (callback (cstr/trim out)))))

(defn git-config-atom
  "Call the `git config` command to grab the value of a given key.
  Return an atom that will hold the return/output string in a map {k output-value}.
  Optionally pass in an atom (allowing you to build up many returns)"
  ([k]
   (git-config-atom k (atom {})))
  ([k ret]
   (do (sys-exec (str "git config --get " (name k))
                 (fn [_ out _]
                   (swap! ret assoc (keyword k) (cstr/trim out))))
   ret)))

(defn git-root
  "Fetch the root directory of a git repo;  This relies on the `root` alias"
  []
  (let [ret (atom nil)]
    (sys-exec "git root"
              (fn [_ out _]
                (reset! ret (cstr/trim out))))
    ret))

(defn blocking-deref
  "Given atom and a Result object, attempt to cycle the process tick on derefing until `pred-fn` isn't true
  By default, `pred-fn` is nil?
  Once the condition doesn't hold, the Result will be set to @a, and @a is returned"
  ([a r]
   (blocking-deref a r nil?))
  ([a r pred-fn]
   (if (pred-fn @a)
     (node/process.nextTick #(blocking-deref a r pred-fn))
     (do (.setValue r @a)
       @a))))

;; This is the direct Result object you can use to access
;; a git config map
(def git-config-res
  (let [res (goog.result.SimpleResult.)]
    (->>
      (git-config-atom "user.email")
      (git-config-atom "user.name")
      ((fn [a] (blocking-deref a res #(< (count %) 2)))))
    res))

;;This is the direct Result object you can use to access
;; the git repo's root directory
(def git-root-res
  (let [res (goog.result.SimpleResult.)]
    (->
      (git-root)
      (blocking-deref res))
    res))

;; Last commit message: git log -n1 --pretty=format:%s
;; Last commit hash: git rev-parse HEAD

;; Lock file I/O
;; --------------
;; The lock file ensures that only one command is modifying the ticket file
;; at any given point in time.  This is similar to Vim's .swp file.

(defn lock-file! []
  (let [l-file (str *repo-root* "/.tttlock")]
    (if (file? l-file)
      (do (println "TTT is currently locked.  Is someone else trying running ttt commands?\n")
        (exit 1))
      (write-edn-file l-file ""))))

(defn unlock! []
  (let [l-file (str *repo-root* "/.tttlock")]
    (when (file? l-file)
      (.unlinkSync fs l-file)
      true)))

;; Preferences specific I/O
;; ------------------------
(defn pref-file! []
  (let [p-dir (str *repo-root* "/.ttt/")
        p-file (str p-dir "tttrc")]
    (if-not (fs-exists? p-file)
      (do (when-not (directory? p-dir)
            (.mkdirSync fs p-dir))
        (write-edn-file p-file base-pref-map))
      (read-edn-file p-file))))

;; Ticket Store/File specific I/O
;; ------------------
(defn write-ticket-file
  [ticket-file ticket-map]
  (write-edn-file ticket-file ticket-map))

(defn read-ticket-file
  [ticket-file]
  (read-edn-file ticket-file))

(defn ticket-file!
  "Ensure the ticket file exists, and return its contents as a map.
  If the ticket files does not exist, create it, and return the base map"
  ([]
   (ticket-file! default-ticket-path))
  ([t-file]
   (if-not (file? t-file)
     (write-ticket-file t-file base-file-map)
     (read-ticket-file t-file))))

(defn utc-millis []
  (let [d (js/Date.)]
    (js/Date.UTC (.getUTCFullYear d) (.getUTCMonth d) (.getUTCDay d))))

;; Ticket auxiliary
;;--------------------
;;
;; A map is used to normalize the arguments used in creating and modifying
;; tickets.  This decouples the handling of CLI args and the args passed to
;; the tickets.  While the basic substituion could be done with
;; clojure.set/rename-keys, this offers an open and composible solution
;; for external plugins as well.

(def normalize-ticket-arg
  {"-m" :summary
   "--message" :summary
   :message :summary
   "-d" :description
   "--description" :description
   "-p" :points
   "--points" :points
   "-t" :type
   "--type" :type
   "-r" :release
   "--release" :release
   "-RR" :release
   "--release*" :release})

(defn scrub-ticket-args [args]
  (map #(get normalize-ticket-arg % %) args))

(defn ticket-defaults
  "This should only be used on ticket creation"
  []
  (let [pref-file (pref-file!)
        id-num (-> (ticket-file!) :tickets count inc)
        start-state (-> pref-file :ticket-states first keyword)
        git-map (.getValue git-config-res)]
    {:id id-num
     :type (:default-type pref-file)
     :current-state start-state
     :points (get pref-file :default-ticket-points "")
     :states {start-state (utc-millis)}
     :reported-by (:user.email git-map)
     :owner (:user.email git-map)}))

(defn inc-state [ticket]
  (let [pref-file (pref-file!)
        curr-state-str (-> ticket :current-state name)
        ticket-states (:ticket-states pref-file)]
    (if-let [next-state-str (second (drop-while (complement #{curr-state-str}) ticket-states))]
      (merge ticket {:current-state (keyword next-state-str)
                     :states (assoc (:states ticket) (keyword next-state-str) (utc-millis))})
      ticket)))

(defn inc-state-on
  "Inc the state of a ticket only if the ticket's current state is a specific keyword"
  [ticket state-kw]
  (if (= state-kw (:current-state ticket))
    (inc-state ticket)
    ticket))

;(defn id-kw->pos
;  "Given a ticket's id keyword [ie :1], return its supposed position
;  DO NOT USE THIS
;  This is here only for historical reasons.  Ticket IDs are integer based"
;  [id-kw]
;  (-> id-kw name js/parseInt dec))

(defn id->pos
  "Given a ticket's integer ID, return its supposed position in the ticket vector"
  [id-int]
  (dec id-int))

(defn id-str->int
  "Given a ticket's ID string expressed like a keyword (ie: ':1'), return the integer (1)"
  [id-str]
  (js/parseInt (subs id-str 1)))

;; Ticket specific I/O
;;--------------------
(defn make-ticket [& args]
  (let [ticket (merge base-ticket-map
                      (ticket-defaults)
                      (apply hash-map (scrub-ticket-args args)))]
    ;; We may have some hooks here, if not TODO remove the `let`
    ticket))

(defn append-ticket [t-file-map ticket]
  (update-in t-file-map [:tickets] conj (assoc ticket
                                               :id (-> t-file-map :tickets count inc))))

(defn update-ticket
  "This ticket needs to have the :id key in it already"
  [t-file-map ticket]
  (update-in t-file-map [:tickets (-> ticket :id id->pos)] merge ticket))

(defn ticket-io!
  "This applies a function to the actual ticket file.
  All functions should take two args: the ticket file map, and a ticket.
  You should never lock the ticket file by hand, use this function."
  ([f ticket]
   (ticket-io! f ticket default-ticket-path))
  ([f ticket ticket-file]
   (let [l-file (lock-file!)
         t-file-map (ticket-file! ticket-file)
         res (write-ticket-file ticket-file (f t-file-map ticket))
         _ (unlock!)]
     res)))

(defn str-ticket
  "A basic single-line str for a ticket; suitable to print"
  [t]
  (str (:id t) " [" (:type t) " :: " (:points t) " points] - " (:summary t)))

;; Git interactions
;; -----------------
;;
;; Here are the auxiliary functions for various git hooks and interactions.
;; These are responsible automatically pushing a ticket through its states
;; based on git usage.

(defn process-work
  "Process a given unit of work for a ticket, given the ticket,
  a commit hash, a possible command/state, and any extra args
  to merge into the history map"
  [ticket git-hash command & extra-args]
  (let [pref-file (pref-file!)
        curr-time (utc-millis)
        ticket (update-in ticket [:history] conj (merge {:commit git-hash :at curr-time} (apply hash-map extra-args)))]
    (if-let [state-str (some #{command} (:ticket-states pref-file))]
      (let [ticket (assoc (assoc-in ticket [:states (keyword state-str)] curr-time)
                          :current-state (keyword state-str))]
        (if (= state-str (last (:ticket-states pref-file)))
          (assoc ticket :closed-by (:owner ticket))
          ticket))
      ticket)))

(defn parse-git-message [message-str]
  (if-let [hook-str (re-find #"\[.+]$" message-str)]
    (let [hook-sans-br (cstr/replace hook-str #"\[|\]" "")
          parts (cstr/split hook-sans-br #"\s")
          command (first parts) ;; Note, this could not be a command, but just the mention of a ticket
          ticket-ids (map id-str->int (filter #(= \:  (get % 0)) parts))]
      {:ids ticket-ids :maybe-command command :message message-str})))

(defn process-git [git-hash email & message-pieces]
  (let [message-map (parse-git-message (cstr/join " " message-pieces))
        command (:maybe-command message-map)
        tickets (:tickets (ticket-file!))]
    (doseq [ticket-id (:ids message-map)]
      (when-let [ticket (get tickets (id->pos ticket-id))]
        (ticket-io! update-ticket (-> (inc-state-on ticket :open)
                                    (assoc :owner email)
                                    (process-work git-hash command :message (:message message-map))))))))

(ns ttt.core
  "Core functionality: initialization, ticket creation, data operations"
  (:require [clojure.string :as cstr]
            [cljs.nodejs :as node]
            [cljs.reader :as reader]
            [goog.result :as result]))

;; Node modules
;; -------------
(def ^:private fs (node/require "fs"))
(def ^:private sys-exec (.-exec (node/require "child_process")))

(def ^:dynamic *repo-root* "./")

;; Base maps
;; ------------
(def base-pref-map
  {:types ["work" "bug"]
   :default-type "work"
   :points ["0" "1" "2" "3" "5" "8"]
   :default-ticket-points "0"
   :tag-on-complete? true
   :ticket-states ["open" "in-progress" "closed"] ;; these get kw-ized within ttt
   })

(def base-file-map
  {:releases {}
   :tickets []})

(def base-ticket-map
  {:summary ""
   :description ""
   :reported-by ""
   :owner ""
   :closed-by ""
   :points ""
   :type ""
   :states {}
   :current-state :open
   :history []
   :branch ""})

(def default-ticket-path (str *repo-root* "/tickets.edn"))

;; Core I/O functions
;; ------------------
;;
;; ### Safe Reading
;; Usually `safe-read` is defined as such:
;;
;;     (defn safe-read [s]
;;       (binding [*read-eval* false]
;;         (reader/read-string s))
;;
;; But ClojureScript doesn't have eval, so we get the simpler...
(defn safe-read [s]
  (reader/read-string s))

(defn read-edn-file
  "Read in a Clojure/EDN file, returning the data structure upon success.
  Throws an error if reading fails"
  [edn-file]
  (let [file-contents (.readFileSync fs edn-file "utf8")]
    (safe-read file-contents)))

(defn write-edn-file
  "Writes Clojure/EDN data to a file. Returns the data upon success.
  Throws an error when writing fails"
  [edn-file data]
  (let [file-contents (pr-str data)]
    (.writeFileSync fs edn-file file-contents)
    data))

(defn fs-exists? [fs-path]
  (.existsSync fs fs-path))

(defn file? [fs-path]
  (if (fs-exists? fs-path)
    (-> (.lstatSync fs fs-path) .isFile)
    false))

(defn directory? [fs-path]
  (if (fs-exists? fs-path)
    (-> (.lstatSync fs fs-path) .isDirectory)
    false))

;; System functions
;; ----------------
(defn exit
  ([]
   (exit 0))
  ([exit-code]
   (node/process.exit exit-code)))

;; Git functions
;; --------------
;;
;; ### The story
;; Node only allows for async command execution.
;; This quickly becomes a pain in an application like `ttt`.
;;
;; To get around this, we use Closure's `Result` - essentially a promise.
;; When coupled with an atom, we can perform system commands and await their
;; return using a blocking deference.  The trade-off is that we still need to
;; pass callbacks to the promise but at the call site (for example, in the
;; `main` namespace) where they have real context.

(defn git-config
  "Call the `git config` command to grab the value of a given key.
  Pass in a callback to handle the output/return string"
  [config-key callback]
  (sys-exec (str "git config --get " k)
              (fn [_ out _]
                (callback (cstr/trim out)))))

(defn git-config-atom
  "Call the `git config` command to grab the value of a given key.
  Return an atom that will hold the return/output string in a map {k output-value}.
  Optionally pass in an atom (allowing you to build up many returns)"
  ([k]
   (git-config-atom k (atom {})))
  ([k ret]
   (do (sys-exec (str "git config --get " (name k))
                 (fn [_ out _]
                   (swap! ret assoc (keyword k) (cstr/trim out))))
   ret)))

(defn git-root
  "Fetch the root directory of a git repo;  This relies on the `root` alias"
  []
  (let [ret (atom nil)]
    (sys-exec "git root"
              (fn [_ out _]
                (reset! ret (cstr/trim out))))
    ret))

(defn blocking-deref
  "Given atom and a Result object, attempt to cycle the process tick on derefing until `pred-fn` isn't true
  By default, `pred-fn` is nil?
  Once the condition doesn't hold, the Result will be set to @a, and @a is returned"
  ([a r]
   (blocking-deref a r nil?))
  ([a r pred-fn]
   (if (pred-fn @a)
     (node/process.nextTick #(blocking-deref a r pred-fn))
     (do (.setValue r @a)
       @a))))

;; This is the direct Result object you can use to access
;; a git config map
(def git-config-res
  (let [res (goog.result.SimpleResult.)]
    (->>
      (git-config-atom "user.email")
      (git-config-atom "user.name")
      ((fn [a] (blocking-deref a res #(< (count %) 2)))))
    res))

;;This is the direct Result object you can use to access
;; the git repo's root directory
(def git-root-res
  (let [res (goog.result.SimpleResult.)]
    (->
      (git-root)
      (blocking-deref res))
    res))

;; Last commit message: git log -n1 --pretty=format:%s
;; Last commit hash: git rev-parse HEAD

;; Lock file I/O
;; --------------
;; The lock file ensures that only one command is modifying the ticket file
;; at any given point in time.  This is similar to Vim's .swp file.

(defn lock-file! []
  (let [l-file (str *repo-root* "/.tttlock")]
    (if (file? l-file)
      (do (println "TTT is currently locked.  Is someone else trying running ttt commands?\n")
        (exit 1))
      (write-edn-file l-file ""))))

(defn unlock! []
  (let [l-file (str *repo-root* "/.tttlock")]
    (when (file? l-file)
      (.unlinkSync fs l-file)
      true)))

;; Preferences specific I/O
;; ------------------------
(defn pref-file! []
  (let [p-dir (str *repo-root* "/.ttt/")
        p-file (str p-dir "tttrc")]
    (if-not (fs-exists? p-file)
      (do (when-not (directory? p-dir)
            (.mkdirSync fs p-dir))
        (write-edn-file p-file base-pref-map))
      (read-edn-file p-file))))

;; Ticket Store/File specific I/O
;; ------------------
(defn write-ticket-file
  [ticket-file ticket-map]
  (write-edn-file ticket-file ticket-map))

(defn read-ticket-file
  [ticket-file]
  (read-edn-file ticket-file))

(defn ticket-file!
  "Ensure the ticket file exists, and return its contents as a map.
  If the ticket files does not exist, create it, and return the base map"
  ([]
   (ticket-file! default-ticket-path))
  ([t-file]
   (if-not (file? t-file)
     (write-ticket-file t-file base-file-map)
     (read-ticket-file t-file))))

(defn utc-millis []
  (let [d (js/Date.)]
    (js/Date.UTC (.getUTCFullYear d) (.getUTCMonth d) (.getUTCDay d))))

;; Ticket auxiliary
;;--------------------
;;
;; A map is used to normalize the arguments used in creating and modifying
;; tickets.  This decouples the handling of CLI args and the args passed to
;; the tickets.  While the basic substituion could be done with
;; clojure.set/rename-keys, this offers an open and composible solution
;; for external plugins as well.

(def normalize-ticket-arg
  {"-m" :summary
   "--message" :summary
   :message :summary
   "-d" :description
   "--description" :description
   "-p" :points
   "--points" :points
   "-t" :type
   "--type" :type
   "-r" :release
   "--release" :release
   "-RR" :release
   "--release*" :release})

(defn scrub-ticket-args [args]
  (map #(get normalize-ticket-arg % %) args))

(defn ticket-defaults
  "This should only be used on ticket creation"
  []
  (let [pref-file (pref-file!)
        id-num (-> (ticket-file!) :tickets count inc)
        start-state (-> pref-file :ticket-states first keyword)
        git-map (.getValue git-config-res)]
    {:id id-num
     :type (:default-type pref-file)
     :current-state start-state
     :points (get pref-file :default-ticket-points "")
     :states {start-state (utc-millis)}
     :reported-by (:user.email git-map)
     :owner (:user.email git-map)}))

(defn inc-state [ticket]
  (let [pref-file (pref-file!)
        curr-state-str (-> ticket :current-state name)
        ticket-states (:ticket-states pref-file)]
    (if-let [next-state-str (second (drop-while (complement #{curr-state-str}) ticket-states))]
      (merge ticket {:current-state (keyword next-state-str)
                     :states (assoc (:states ticket) (keyword next-state-str) (utc-millis))})
      ticket)))

(defn inc-state-on
  "Inc the state of a ticket only if the ticket's current state is a specific keyword"
  [ticket state-kw]
  (if (= state-kw (:current-state ticket))
    (inc-state ticket)
    ticket))

;(defn id-kw->pos
;  "Given a ticket's id keyword [ie :1], return its supposed position
;  DO NOT USE THIS
;  This is here only for historical reasons.  Ticket IDs are integer based"
;  [id-kw]
;  (-> id-kw name js/parseInt dec))

(defn id->pos
  "Given a ticket's integer ID, return its supposed position in the ticket vector"
  [id-int]
  (dec id-int))

(defn id-str->int
  "Given a ticket's ID string expressed like a keyword (ie: ':1'), return the integer (1)"
  [id-str]
  (js/parseInt (subs id-str 1)))

;; Ticket specific I/O
;;--------------------
(defn make-ticket [& args]
  (let [ticket (merge base-ticket-map
                      (ticket-defaults)
                      (apply hash-map (scrub-ticket-args args)))]
    ;; We may have some hooks here, if not TODO remove the `let`
    ticket))

(defn append-ticket [t-file-map ticket]
  (update-in t-file-map [:tickets] conj (assoc ticket
                                               :id (-> t-file-map :tickets count inc))))

(defn update-ticket
  "This ticket needs to have the :id key in it already"
  [t-file-map ticket]
  (update-in t-file-map [:tickets (-> ticket :id id->pos)] merge ticket))

(defn ticket-io!
  "This applies a function to the actual ticket file.
  All functions should take two args: the ticket file map, and a ticket.
  You should never lock the ticket file by hand, use this function."
  ([f ticket]
   (ticket-io! f ticket default-ticket-path))
  ([f ticket ticket-file]
   (let [l-file (lock-file!)
         t-file-map (ticket-file! ticket-file)
         res (write-ticket-file ticket-file (f t-file-map ticket))
         _ (unlock!)]
     res)))

(defn open-state [pref-file]
  (-> (:ticket-states pref-file) first keyword))
(defn closed-state [pref-file]
  (-> (:ticket-states pref-file) last keyword))

(defn str-ticket
  "A basic single-line str for a ticket; suitable to print"
  [t]
  (let [pref-file (pref-file!)
        status-map {(open-state pref-file) "_ "
                    (closed-state pref-file) "X "}]
    (str (get status-map (:current-state t) "> ") (:id t) " [" (:type t) " :: " (:points t) " points] - " (:summary t))))

(defn str-ticket-long
  "A full format ticket string; suitable to report on a single ticket"
  [t]
  (let [pref-file (pref-file!)
        days-opened (-> (:states t) ((open-state pref-file)) (#(- (utc-millis) %)) (/ 86400000))
        work?  (-> (:history t) last :at)
        days-since (or (and work? (-> work? (#(- (utc-millis) %)) (/ 86400000)))
                       days-opened)]
    (if t
      (str "Issue " (:id t) " - " (:summary t)
           "\n------------------------"
           "\n Description: " (:description t)
           "\n Type: " (:type t)
           "\n Status: " (:current-state t)
           "\n Points: " (:points t)
           "\n Reported by: " (:reported-by t) " - " days-opened " day(s) ago"
           "\n Owned by: " (:owner t)
           "\n Last activity: " days-since " day(s) ago"
           "\n On branch: " (:branch t)
           "\n Release: " (:release t))
      "Could not locate that ticket")))

;; Git interactions
;; -----------------
;;
;; Here are the auxiliary functions for various git hooks and interactions.
;; These are responsible automatically pushing a ticket through its states
;; based on git usage.

(defn process-work
  "Process a given unit of work for a ticket, given the ticket,
  a commit hash, a possible command/state, and any extra args
  to merge into the history map"
  [ticket git-hash command & extra-args]
  (let [pref-file (pref-file!)
        curr-time (utc-millis)
        ticket (update-in ticket [:history] conj (merge {:commit git-hash :at curr-time} (apply hash-map extra-args)))]
    (if-let [state-str (some #{command} (:ticket-states pref-file))]
      (let [ticket (assoc (assoc-in ticket [:states (keyword state-str)] curr-time)
                          :current-state (keyword state-str))]
        (if (= state-str (last (:ticket-states pref-file)))
          (assoc ticket :closed-by (:owner ticket))
          ticket))
      ticket)))

(defn parse-git-message [message-str]
  (if-let [hook-str (re-find #"\[.+]$" message-str)]
    (let [hook-sans-br (cstr/replace hook-str #"\[|\]" "")
          parts (cstr/split hook-sans-br #"\s")
          command (first parts) ;; Note, this could not be a command, but just the mention of a ticket
          ticket-ids (map id-str->int (filter #(= \:  (get % 0)) parts))]
      {:ids ticket-ids :maybe-command command :message message-str})))

(defn process-git [git-hash email & message-pieces]
  (let [message-map (parse-git-message (cstr/join " " message-pieces))
        command (:maybe-command message-map)
        tickets (:tickets (ticket-file!))]
    (doseq [ticket-id (:ids message-map)]
      (when-let [ticket (get tickets (id->pos ticket-id))]
        (ticket-io! update-ticket (-> (inc-state-on ticket :open)
                                    (assoc :owner email)
                                    (process-work git-hash command :message (:message message-map))))))))

Add the two forms of printing; long and short [:17]


(ns replme.web.repl
  (:require [clojure.core.async :refer [go <! >! <!! >!! chan close! go-loop alts! timeout]]
            [org.httpkit.server :refer [send! with-channel on-receive on-close open? websocket?]]
            [http.async.client :as http]
            [clojure.tools.logging :as log]
            [replme.web.resp :refer :all]
            [clojure.tools.nrepl :as repl]
            [docker.container :as container]))

(def nrepl-sentinel #"server started")

(defn- docker-attach
  [client id]
  (let [output (chan)
        url (str "http://" (:host client) "/containers/" id "/logs?stdout=1&follow=1")]
    (go
      (log/info "Reading logs from: " url)
      (with-open  [http-client (http/create-client)]
        (doseq [msg (http/string (http/stream-seq http-client :get url :timeout -1))]
          (log/info "Container" id "logs:" msg)
          (>! output msg))))
    output))

(defn- docker-cmd
  [args]
  (let [args (if args (vector args) [])]
    (log/info "Starting container from repo" args)
    {:Image "edpaget/lein"
     :Tty true
     :Memory "256M"
     :Cmd args}))

(defn- start-docker
  [client args]
  (let [container (container/create client (docker-cmd args))
        id (:Id container)
        logs (docker-attach client id)]
    (container/start client id)
    (log/info (str "Started container:" id))
    [id logs]))

(defn- docker-ip
  [client id]
  (-> (container/inspect client id)
      :NetworkSettings
      :IPAddress))

(defn- stop-docker
  [client id]
  (container/kill client id)
  (container/remove client id :force true))

(defn- out-msg
  [msg destination]
  {:message msg :destination destination})

(defn- timeout-stdout
  [stdout]
  (go (or (first (alts! [stdout (timeout 30000)] :priority true)) "server started")))

(defn- docker-repl
  [client args in-chan out-chan]
  (let [[id stdout] (start-docker client args)
        ip (docker-ip client id)
        port 8081]
    (go-loop [msg (<! (timeout-stdout stdout))]
      (log/info "MESSAGE" msg)
      (if (re-find nrepl-sentinel msg)
        (do
          (log/info (str "Connecting to docker nrepl at" ip ":" port))
          (>! out-chan (out-msg "REPL OK" :command))
          (go-loop [command (<! in-chan)]
            (when command
              (with-open [repl-conn (repl/connect :host ip :port port)]
                (>! out-chan
                    (-> (repl/client repl-conn 1000)
                        (repl/message {:op :eval :code command})
                        (out-msg :repl)))))
            (recur (<! in-chan))))

        (do (>! out-chan (out-msg msg :console))
            (recur (<! stdout)))))
    id))

(defn- handle-input
  [in-chan]
  (fn [data]
    (log/info (str "Received:" data))
    (>!! in-chan data)))

(defn- handle-close
  [client id http-client & chans]
  (fn [_]
    (log/info "Closing Repl Connnection")
    (stop-docker client id)
    (doseq [c chans] (close! c))
    (log/info "Connection Closed!")))

(defn- handle-out
  [channel out-chan]
  (go-loop [msg (<! out-chan)]
    (log/info "Sending" msg)
    (send! channel msg false)
    (when (open? channel)
      (recur (<! out-chan)))))

(defn- not-empty?
  [{:keys [message]}]
  (cond
   (= "\n" message) false
   (= "\r\n" message) false
   (= "" message) false
   :else true))

(defn- msg-hash
  []
  {:error {} :out "" :value nil :namespace nil})

(defn formatter
  [out-hash in-hash]
  (reduce (fn [out-hash [k v]]
            (cond
             (some #{k} [:ex :root-ex :err]) (update-in out-hash [:error] assoc k v)
             (= k :out) (update-in out-hash [:out] str v)
             (= k :ns) (assoc out-hash :namespace v)
             (= k :value) (assoc out-hash :value v)
             :else out-hash))
          out-hash in-hash))

(defn- format-msgs
  [{:keys [message] :as msg}]
  (cond
   (string? message) msg
   (seq? message) (assoc msg :message (reduce formatter (msg-hash) message))))

(def format-out (comp (filter not-empty?) (map format-msgs) (map pr-str)))

(defn open-websocket
  [docker-client req repo]
  (let [in-chan (chan)
        out-chan (chan 1 format-out)]
    (with-channel req channel
      (if (websocket? channel)
        (let [[docker-id http-client] (docker-repl docker-client repo in-chan out-chan)
              send-chan (handle-out channel out-chan)]
          (log/info "Websocket Connected")
          (on-receive channel (handle-input in-chan))
          (on-close channel (handle-close docker-client docker-id http-client in-chan out-chan send-chan)))
        (send! channel (resp-bad-request))))))

(ns replme.web.repl
  (:require [clojure.core.async :refer [go <! >! <!! >!! chan close! go-loop alts! timeout]]
            [org.httpkit.server :refer [send! with-channel on-receive on-close open? websocket?]]
            [http.async.client :as http]
            [clojure.tools.logging :as log]
            [replme.web.resp :refer :all]
            [clojure.tools.nrepl :as repl]
            [docker.container :as container]))

(def nrepl-sentinel #"server started")

(defn- docker-attach
  [client id]
  (let [output (chan)
        url (str "http://" (:host client) "/containers/" id "/logs?stdout=1&follow=1")]
    (go
      (log/info "Reading logs from: " url)
      (with-open  [http-client (http/create-client)]
        (doseq [msg (http/string (http/stream-seq http-client :get url :timeout -1))]
          (log/info "Container" id "logs:" msg)
          (>! output msg))))
    output))

(defn- docker-cmd
  [args]
  (let [args (if args (vector args) [])]
    (log/info "Starting container from repo" args)
    {:Image "edpaget/lein"
     :Tty true
     :Memory "256M"
     :Cmd args}))

(defn- start-docker
  [client args]
  (let [container (container/create client (docker-cmd args))
        id (:Id container)
        logs (docker-attach client id)]
    (container/start client id)
    (log/info (str "Started container:" id))
    [id logs]))

(defn- docker-ip
  [client id]
  (-> (container/inspect client id)
      :NetworkSettings
      :IPAddress))

(defn- stop-docker
  [client id]
  (container/kill client id)
  (container/remove client id :force true))

(defn- out-msg
  [msg destination]
  {:message msg :destination destination})

(defn- timeout-stdout
  [stdout]
  (go (or (first (alts! [stdout (timeout 30000)] :priority true)) "server started")))

(defn- docker-repl
  [client args in-chan out-chan]
  (let [[id stdout] (start-docker client args)
        ip (docker-ip client id)
        port 8081]
    (go-loop [msg (<! (timeout-stdout stdout))]
      (if (re-find nrepl-sentinel msg)
        (do
          (log/info (str "Connecting to docker nrepl at" ip ":" port))
          (>! out-chan (out-msg "REPL OK" :command))
          (go-loop [command (<! in-chan)]
            (when command
              (with-open [repl-conn (repl/connect :host ip :port port)]
                (>! out-chan
                    (-> (repl/client repl-conn 1000)
                        (repl/message {:op :eval :code command})
                        (out-msg :repl)))))
            (recur (<! in-chan))))

        (do (>! out-chan (out-msg msg :console))
            (recur (<! stdout)))))
    id))

(defn- handle-input
  [in-chan]
  (fn [data]
    (log/info (str "Received:" data))
    (>!! in-chan data)))

(defn- handle-close
  [client id http-client & chans]
  (fn [_]
    (log/info "Closing Repl Connnection")
    (stop-docker client id)
    (doseq [c chans] (close! c))
    (log/info "Connection Closed!")))

(defn- handle-out
  [channel out-chan]
  (go-loop [msg (<! out-chan)]
    (log/info "Sending" msg)
    (send! channel msg false)
    (when (open? channel)
      (recur (<! out-chan)))))

(defn- not-empty?
  [{:keys [message]}]
  (cond
   (= "\n" message) false
   (= "\r\n" message) false
   (= "" message) false
   :else true))

(defn- msg-hash
  []
  {:error {} :out "" :value nil :namespace nil})

(defn formatter
  [out-hash in-hash]
  (reduce (fn [out-hash [k v]]
            (cond
             (some #{k} [:ex :root-ex :err]) (update-in out-hash [:error] assoc k v)
             (= k :out) (update-in out-hash [:out] str v)
             (= k :ns) (assoc out-hash :namespace v)
             (= k :value) (assoc out-hash :value v)
             :else out-hash))
          out-hash in-hash))

(defn- format-msgs
  [{:keys [message] :as msg}]
  (cond
   (string? message) msg
   (seq? message) (assoc msg :message (reduce formatter (msg-hash) message))))

(def format-out (comp (filter not-empty?) (map format-msgs) (map pr-str)))

(defn open-websocket
  [docker-client req repo]
  (let [in-chan (chan)
        out-chan (chan 1 format-out)]
    (with-channel req channel
      (if (websocket? channel)
        (let [[docker-id http-client] (docker-repl docker-client repo in-chan out-chan)
              send-chan (handle-out channel out-chan)]
          (log/info "Websocket Connected")
          (on-receive channel (handle-input in-chan))
          (on-close channel (handle-close docker-client docker-id http-client in-chan out-chan send-chan)))
        (send! channel (resp-bad-request))))))

Remove unnecessary logging

Remove unnecessary logging


(ns berry.parsing.scan-literal-test
  (:require [berry.parsing.context-handler :as context]
            [berry.parsing.scan-literal :refer :all]
            berry.parsing.token
            [clojure.test :refer :all])
  (:import [berry.parsing.token Token Location]))

(deftest scan-literal-test

  (testing "With a true literal."

           (let [true-literal (Token. "literal" "true" (Location. 1 1) (Location. 1 4))]

             (is (= true-literal
                    (scan-literal '("t" "r" "u" "e") context/begin)))))

  (testing "With a false literal."

           (let [false-literal (Token. "literal" "false" (Location. 1 1) (Location. 1 5))]

             (is (= false-literal
                    (scan-literal '("f" "a" "l" "s" "e") context/begin)))))

  (testing "With a null literal."

           (let [null-literal (Token. "literal" "null" (Location. 1 1) (Location. 1 4))]

             (is (= null-literal
                    (scan-literal '("n" "u" "l" "l") context/begin)))))

  )

(ns berry.parsing.scan-literal-test
  (:require [berry.parsing.context-handler :as context]
            [berry.parsing.scan-literal :refer :all]
            berry.parsing.token
            [clojure.test :refer :all])
  (:import [berry.parsing.token Token Location]))

(deftest scan-literal-test

  (testing "When a true literal is analyzed."

           (let [true-literal (Token. "literal" "true" (Location. 1 1) (Location. 1 4))]

             (is (= true-literal
                    (scan-literal '("t" "r" "u" "e") context/begin)))))

  (testing "When a false literal is analyzed."

           (let [false-literal (Token. "literal" "false" (Location. 1 1) (Location. 1 5))]

             (is (= false-literal
                    (scan-literal '("f" "a" "l" "s" "e") context/begin)))))

  (testing "When a null literal is analyzed."

           (let [null-literal (Token. "literal" "null" (Location. 1 1) (Location. 1 4))]

             (is (= null-literal
                    (scan-literal '("n" "u" "l" "l") context/begin)))))

  (testing "When an unexpected token is found in the sequence."

           (is (thrown-with-msg? java.text.ParseException #"Unexpected token y at line 1, column 3."
                                 (scan-literal '("t" "r" "y" "e") context/begin)))

           (testing "When the input terminates unexpectedly."

                    (is (thrown-with-msg? java.text.ParseException #"Unexpected end of input at line 1, column 4."

                                          (scan-literal '("f" "a" "l" "s") context/begin))))))

Add unit tests for checking error conditions.


(ns rdf-path-examples.distance-test
  (:require [rdf-path-examples.distance :as distance]
            [rdf-path-examples.prefixes :refer [xsd]]
            [clojure.test :refer :all]))

(deftest parse-duration
  (are [s period] (= (distance/parse-duration s) period)
       "P1M" (distance/->period :months 1)
       "P2000Y5M30D" (distance/->period :years 2000 :months 5 :days 30)
       "-P120D" (distance/->period :days -120)
       "P1Y2MT2H" (distance/->period :years 1 :months 2 :hours 2)
       "PT0.5S" (distance/->period :seconds 0.5))
  (is (thrown? IllegalArgumentException (distance/parse-duration ""))
      "Parsing malformed duration throws an exception."))

(deftest date->seconds
  (is (zero? (distance/date->seconds "1970-01-01"))
      "Dates are casted to seconds from the Unix time's start.")
  (is (thrown? IllegalArgumentException (distance/date->seconds ""))
      "Parsing malformed dates throws an exception."))

(deftest compute-distance
  (let [maximum 10 ; Fixed maximum range for all properties
        distance-fn (fn [a b] (distance/compute-distance (fn [])
                                                         {nil maximum}
                                                         [nil a]
                                                         [nil b]))] ; Mocked distance function
    (testing "Equivalent resources have no distance."
      (are [resource] (== (distance-fn resource resource) 0)
           {"@value" 1}
           {"@value" "2015-12-30"}
           {"@value" "https://example.com:3030/path/to/resource"}))
    (testing "Distance is symmetric"
      (are [a b] (= (distance-fn a b) (distance-fn b a))
           {"@value" 1} {"@value" 3}
           {"@value" "http://example.com/path/to/a/file"} {"@value" "https://example.com/path/to/another/file"}
           {"@id" "_:b1"} {"@id" "_:b2"}))
    (testing "Mismatching types have maximum distance."
      (are [a b] (== (distance-fn a b) 1)
           {"@type" (xsd "decimal")
            "@value" 1.23}
           {"@type" "http://purl.org/goodrelations/v1#BusinessEntity"
            "@id" "_:b1"}))
    (testing "Numeric distance"
      (are [a b distance] (== (distance-fn a b) distance)
           {"@value" 0} {"@value" 1} 0.1
           {"@value" -10} {"@value" 5} 1.5))
    (testing "Distance between dates and date-times"
      (are [a b c d] (= (distance-fn a b) (distance-fn c d))
           ; A day difference
           {"@value" "2015-01-01"} {"@value" "2015-01-02"}
           {"@value" "2014-01-01"} {"@value" "2014-01-02"}
           ; A year difference
           {"@value" "2013-01-01"} {"@value" "2014-01-01"}
           {"@value" "2014-01-01"} {"@value" "2015-01-01"}
           ; A minutes difference
           {"@value" "2015-01-01T12:00:00.000Z"} {"@value" "2015-01-01T12:01:00.000Z"}
           {"@value" "2015-01-01T12:01:00.000Z"} {"@value" "2015-01-01T12:02:00.000Z"}))
    (testing "Malformed literals have maximum distance."
      (are [a b] (== (distance-fn a b) 1)
           {"@type" (xsd "date") "@value" "2016-04-31"} {"@type" (xsd "date") "@value" "2016-04-30"}
           {"@type" (xsd "duration") "@value" "BRRAP"} {"@type" (xsd "duration") "@value" "P5Y"}))))

(ns rdf-path-examples.distance-test
  (:require [rdf-path-examples.distance :as distance]
            [rdf-path-examples.prefixes :refer [xsd]]
            [clojure.test :refer :all]))

(deftest parse-duration
  (are [s period] (= (distance/parse-duration s) period)
       "P1M" (distance/->period :months 1)
       "P2000Y5M30D" (distance/->period :years 2000 :months 5 :days 30)
       "-P120D" (distance/->period :days -120)
       "P1Y2MT2H" (distance/->period :years 1 :months 2 :hours 2)
       "PT0.5S" (distance/->period :seconds 0.5))
  (is (thrown? IllegalArgumentException (distance/parse-duration ""))
      "Parsing malformed duration throws an exception."))

(deftest date->seconds
  (is (zero? (distance/date->seconds "1970-01-01"))
      "Dates are casted to seconds from the Unix time's start.")
  (is (thrown? IllegalArgumentException (distance/date->seconds ""))
      "Parsing malformed dates throws an exception."))

(deftest compute-distance
  (let [maximum 10 ; Fixed maximum range for all properties
        distance-fn (fn [a b] (distance/compute-distance (fn [])
                                                         {nil maximum}
                                                         [nil a]
                                                         [nil b]))] ; Mocked distance function
    (testing "Equivalent resources have no distance."
      (are [resource] (== (distance-fn resource resource) 0)
           {"@value" 1}
           {"@value" "2015-12-30"}
           {"@value" "https://example.com:3030/path/to/resource"}))
    (testing "Distance is symmetric"
      (are [a b] (= (distance-fn a b) (distance-fn b a))
           {"@value" 1} {"@value" 3}
           {"@value" "http://example.com/path/to/a/file"} {"@value" "https://example.com/path/to/another/file"}
           {"@id" "_:b1"} {"@id" "_:b2"}))
    (testing "Mismatching types have maximum distance."
      (are [a b] (== (distance-fn a b) 1)
           {"@type" (xsd "decimal")
            "@value" 1.23}
           {"@type" "http://purl.org/goodrelations/v1#BusinessEntity"
            "@id" "_:b1"}))
    (testing "Numeric distance"
      (are [a b distance] (== (distance-fn a b) distance)
           {"@value" 0} {"@value" 1} 0.1
           {"@value" -10} {"@value" 5} 1.5))
    (testing "Distance between dates, date-times, and durations."
      (are [a b c d] (= (distance-fn a b) (distance-fn c d))
           ; A day difference
           {"@value" "2015-01-01"} {"@value" "2015-01-02"}
           {"@value" "2014-01-01"} {"@value" "2014-01-02"}
           ; A year difference
           {"@value" "2013-01-01"} {"@value" "2014-01-01"}
           {"@value" "2014-01-01"} {"@value" "2015-01-01"}
           ; A minutes difference
           {"@value" "2015-01-01T12:00:00.000Z"} {"@value" "2015-01-01T12:01:00.000Z"}
           {"@value" "2015-01-01T12:01:00.000Z"} {"@value" "2015-01-01T12:02:00.000Z"}
           ; A month difference
           {"@value" "P5Y"} {"@value" "P4Y11M"}
           {"@value" "P1M"} {"@value" "P2M"}))
    (testing "Malformed literals have maximum distance."
      (are [a b] (== (distance-fn a b) 1)
           {"@type" (xsd "date") "@value" "2016-04-31"} {"@type" (xsd "date") "@value" "2016-04-30"}
           {"@type" (xsd "duration") "@value" "BRRAP"} {"@type" (xsd "duration") "@value" "P5Y"}))))

Test xsd:duration distance

Test xsd:duration distance


(ns oc.storage.resources.label
  (:require [oc.lib.schema :as lib-schema]
            [oc.lib.html :as lib-html]
            [taoensso.timbre :as timbre]
            [schema.core :as schema]
            [oc.storage.resources.common :as common]
            [oc.lib.slugify :as slug]
            [oc.lib.db.common :as db-common]))

;; Table, props and primary key

(def table-name common/label-table-name)
(def primary-key :uuid)

(def reserved-slugs #{})

(def ignored-properties
  "Properties of a resource that are ignored during an update."
  common/reserved-properties)

(defn ignore-props
  "Remove any ignored properties from the org."
  [label]
  (apply dissoc label ignored-properties))

(defn clean-input [label]
  (as-> label l
    (if (:name l)
      (update l :name #(lib-html/strip-xss-tags (or % "")))
      l)))

;; Utilities

(declare list-labels-by-org)
(defn taken-slugs
  "Return all org slugs which are in use as a set."
  [conn org-uuid]
  {:pre [(db-common/conn? conn)]}
  (into reserved-slugs (map :slug (list-labels-by-org conn org-uuid))))

(defn- slug-available?
  "Return true if the slug is not used by any org in the system."
  [conn slug org-uuid]
  {:pre [(db-common/conn? conn)
         (slug/valid-slug? slug)
         (lib-schema/unique-id? org-uuid)]}
  (not (contains? (taken-slugs conn org-uuid) slug)))

(schema/defn entry-label :- (schema/maybe common/EntryLabel)
  [label :- (schema/maybe common/Entry)]
  (select-keys label [:uuid :name :slug]))

(schema/defn ^:always-validate get-label :- (schema/maybe common/Label)
  "Given the slug of the label, return the label object, or return nil if it doesn't exist."
  ([conn label-uuid]
   {:pre [(db-common/conn? conn)]}
   (db-common/read-resource conn table-name label-uuid))

  ([conn org-uuid :- lib-schema/UniqueID label-slug]
   {:pre [(db-common/conn? conn)]}
   (first (db-common/read-resources conn table-name :org-label [[org-uuid label-slug]]))))

(defn label-slug-for-org [conn org-uuid label-name]
  (slug/find-available-slug label-name (taken-slugs conn org-uuid)))

(schema/defn ^:always-validate ->label :- common/Label
  [label-name :- common/LabelName
   org-uuid :- lib-schema/UniqueID
   author :- lib-schema/Author]
  (let [ts (db-common/current-timestamp)]
    (-> {primary-key (db-common/unique-id)}
        (assoc :created-at ts)
        (assoc :updated-at ts)
        (assoc :org-uuid org-uuid)
        (assoc :name label-name)
        (clean-input)
        (assoc :slug (slug/slugify label-name)) ;; Will be adjusted later during save
        (assoc :author author)
        (assoc :used-by [{:user-id (:user-id author) :count 0}]))))

(schema/defn ^:always-validate create-label!
  "
  Create an org in the system. Throws a runtime exception if the org doesn't conform to the common/Org schema.

  Check the slug in the response as it may change if there is a conflict with another org.
  "
  [conn label :- common/Label]
  {:pre [(db-common/conn? conn)]}
  (timbre/infof "Creating label %s for org %s user %s" (:name label) (:org-uuid label) (-> label :author :user-id))
  (db-common/create-resource conn table-name (assoc label :slug (label-slug-for-org conn (:org-uuid label) (:name label)))
                             (db-common/current-timestamp)))

(schema/defn ^:always-validate update-label! :- (schema/maybe common/Label)
  "
  Given the UUID of a label and a map containing the update, apply the changes to the object and return it on success.

  Throws an exception if the merge doesn't conform to the common/Label schema.
  "
  [conn label-uuid :- common/Slug updating-label :- {schema/Keyword schema/Any}]
  {:pre [(db-common/conn? conn)]}
  (timbre/debugf "Updating label %s (%s) for org %s user %s" (:name updating-label) (:uuid updating-label) (:org-uuid updating-label) (-> updating-label :author :user-id))
  (when-let [original-label (get-label conn label-uuid)]
    (let [updated-label (->> updating-label
                             ignore-props
                             clean-input
                            (merge original-label))]
      (schema/validate common/Label updated-label)
      (db-common/update-resource conn table-name primary-key label-uuid updated-label))))

(schema/defn ^:always-validate list-labels-by-org :- [common/Label]
  [conn org-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/read-resources conn table-name :org-uuid org-uuid))

(schema/defn ^:always-validate delete-label!
  "Given the slug of the label, delete it."
  [conn label-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (timbre/infof "Deleting label %s" label-uuid)
  (db-common/delete-resource conn table-name label-uuid))

(schema/defn ^:always-validate delete-org-labels! [conn org-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/delete-resource conn table-name :org-uuid org-uuid))

(def UsedByUpdateStrategy (schema/enum :inc :dec))

(schema/defn ^:always-validate update-label-used-by! :- common/Label
  [conn label-uuid :- lib-schema/UniqueID org-uuid :- lib-schema/UniqueID user :- lib-schema/User update-strategy :- UsedByUpdateStrategy]
  {:pre [(db-common/conn? conn)]}
  (if-let [original-label (get-label conn label-uuid)]
    (do
      (timbre/debugf "Increment label %s use for org %s by user %s" label-uuid org-uuid (:user-id user))
      (let [found? (atom false)
            update-fn (if (= update-strategy :inc)
                        inc
                        dec)
            updated-used-by (update original-label
                                    :used-by (fn [used-by]
                                               (mapv (fn [{user-id :user-id use-count :count :or {use-count 0} :as used-by-row}]
                                                       (if (= user-id (:user-id user))
                                                         (let [next-count (max 0 (update-fn use-count))]
                                                           (reset! found? true)
                                                           {:user-id user-id :count next-count})
                                                         used-by-row))
                                                     used-by)))
            updated-label (if @found?
                            updated-used-by
                            (update original-label
                                    :used-by #(concat (vec %) [{:user-id (:user-id user) :count 1}])))]
        (db-common/update-resource conn table-name primary-key label-uuid updated-label)))
    (do
      (timbre/errorf "No label found for user %s and org %s." (:user-id user) org-uuid)
      (throw (ex-info "Invalid label uuid." {:label-uuid label-uuid :org-uuid org-uuid :user user})))))

(defn label-used-by! [conn label-uuid org-uuid user]
  (update-label-used-by! conn label-uuid org-uuid user :inc))

(defn label-unused-by! [conn label-uuid org-uuid user]
  (update-label-used-by! conn label-uuid org-uuid user :dec))

(defn labels-used-by! [conn label-uuids org-uuid user]
  (mapv #(update-label-used-by! conn % org-uuid user :inc) (vec label-uuids)))

(defn labels-unused-by! [conn label-uuids org-uuid user]
  (mapv #(update-label-used-by! conn % org-uuid user :dec) (vec label-uuids)))

(schema/defn ^:always-validate list-labels-by-org-user :- [common/Label]
  [conn org-uuid :- lib-schema/UniqueID user-id :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/read-resources conn table-name :org-uuid-user-id-labels [[org-uuid user-id]]))

(comment
  (require '[oc.storage.resources.org :as org])
  (require '[oc.storage.resources.entry :as entry])
  (require '[clojure.pprint :refer (pprint)])

  (def carrot (org/get-org conn "carrot"))
  (def author (:author carrot))
  (println (create-label! conn (->label "My label test" (:uuid carrot) author)))

  (def test-xss (create-label! conn (->label "<style>Test</style>out" (:uuid carrot) author)))
  (delete-label! conn (:uuid test-xss))

  (def test-label (get-label conn (:uuid carrot) "my-label-test"))

  (update-label! conn (:uuid test-label) {:name "My label test updated"})
  (:name (get-label conn (:uuid carrot) "my-label-test"))

  (pprint (list-labels-by-org conn (:uuid carrot)))

  (label-slug-for-org conn (:uuid carrot) "My label test") ;; => my-label-test-1

  (label-used-by! conn (:uuid test-label) (:uuid carrot) author)

  (def tmp-labels (list-labels-by-org-user conn (:uuid carrot) (:user-id author)))

  (labels-used-by! conn (mapv :uuid (take 2 tmp-labels)) (:uuid carrot) author)

  (labels-unused-by! conn (mapv :uuid (take 2 tmp-labels)) (:uuid carrot) author)

  (delete-label! conn (:uuid test-label))

  (get-label conn (:uuid carrot) "my-label-test"))

(ns oc.storage.resources.label
  (:require [oc.lib.schema :as lib-schema]
            [oc.lib.html :as lib-html]
            [taoensso.timbre :as timbre]
            [schema.core :as schema]
            [oc.storage.resources.common :as common]
            [oc.lib.slugify :as slug]
            [oc.lib.db.common :as db-common]))

;; Table, props and primary key

(def table-name common/label-table-name)
(def primary-key :uuid)

(def reserved-slugs #{})

(def ignored-properties
  "Properties of a resource that are ignored during an update."
  common/reserved-properties)

(defn ignore-props
  "Remove any ignored properties from the org."
  [label]
  (apply dissoc label ignored-properties))

(defn clean-input [label]
  (as-> label l
    (if (:name l)
      (update l :name #(lib-html/strip-xss-tags (or % "")))
      l)))

;; Utilities

(declare list-labels-by-org)
(defn taken-slugs
  "Return all org slugs which are in use as a set."
  [conn org-uuid]
  {:pre [(db-common/conn? conn)]}
  (into reserved-slugs (map :slug (list-labels-by-org conn org-uuid))))

(defn- slug-available?
  "Return true if the slug is not used by any org in the system."
  [conn slug org-uuid]
  {:pre [(db-common/conn? conn)
         (slug/valid-slug? slug)
         (lib-schema/unique-id? org-uuid)]}
  (not (contains? (taken-slugs conn org-uuid) slug)))

(schema/defn entry-label :- (schema/maybe common/EntryLabel)
  [label :- (schema/maybe common/Entry)]
  (select-keys label [:uuid :name :slug]))

(schema/defn ^:always-validate get-label :- (schema/maybe common/Label)
  "Given the slug of the label, return the label object, or return nil if it doesn't exist."
  ([conn label-uuid]
   {:pre [(db-common/conn? conn)]}
   (db-common/read-resource conn table-name label-uuid))

  ([conn org-uuid :- lib-schema/UniqueID label-slug]
   {:pre [(db-common/conn? conn)]}
   (first (db-common/read-resources conn table-name :org-label [[org-uuid label-slug]]))))

(defn label-slug-for-org [conn org-uuid label-name]
  (slug/find-available-slug label-name (taken-slugs conn org-uuid)))

(schema/defn ^:always-validate ->label :- common/Label
  [label-name :- common/LabelName
   org-uuid :- lib-schema/UniqueID
   author :- lib-schema/Author]
  (let [ts (db-common/current-timestamp)]
    (-> {primary-key (db-common/unique-id)}
        (assoc :created-at ts)
        (assoc :updated-at ts)
        (assoc :org-uuid org-uuid)
        (assoc :name label-name)
        (clean-input)
        (assoc :slug (slug/slugify label-name)) ;; Will be adjusted later during save
        (assoc :author author)
        (assoc :used-by [{:user-id (:user-id author) :count 0}]))))

(schema/defn ^:always-validate create-label!
  "
  Create an org in the system. Throws a runtime exception if the org doesn't conform to the common/Org schema.

  Check the slug in the response as it may change if there is a conflict with another org.
  "
  [conn label :- common/Label]
  {:pre [(db-common/conn? conn)]}
  (timbre/infof "Creating label %s for org %s user %s" (:name label) (:org-uuid label) (-> label :author :user-id))
  (db-common/create-resource conn table-name (assoc label :slug (label-slug-for-org conn (:org-uuid label) (:name label)))
                             (db-common/current-timestamp)))

(schema/defn ^:always-validate update-label! :- (schema/maybe common/Label)
  "
  Given the UUID of a label and a map containing the update, apply the changes to the object and return it on success.

  Throws an exception if the merge doesn't conform to the common/Label schema.
  "
  [conn label-uuid :- common/Slug updating-label :- {schema/Keyword schema/Any}]
  {:pre [(db-common/conn? conn)]}
  (timbre/debugf "Updating label %s (%s) for org %s user %s" (:name updating-label) (:uuid updating-label) (:org-uuid updating-label) (-> updating-label :author :user-id))
  (when-let [original-label (get-label conn label-uuid)]
    (let [updated-label (->> updating-label
                             ignore-props
                             clean-input
                            (merge original-label))]
      (schema/validate common/Label updated-label)
      (db-common/update-resource conn table-name primary-key label-uuid updated-label))))

(schema/defn ^:always-validate list-labels-by-org :- [common/Label]
  [conn org-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/read-resources conn table-name :org-uuid org-uuid))

(schema/defn ^:always-validate delete-label!
  "Given the slug of the label, delete it."
  [conn label-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (timbre/infof "Deleting label %s" label-uuid)
  (db-common/delete-resource conn table-name label-uuid))

(schema/defn ^:always-validate delete-org-labels! [conn org-uuid :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/delete-resource conn table-name :org-uuid org-uuid))

(def UsedByUpdateStrategy (schema/enum :inc :dec))

(schema/defn ^:always-validate update-label-used-by! :- common/Label
  [conn label-uuid :- lib-schema/UniqueID org-uuid :- lib-schema/UniqueID user :- lib-schema/User update-strategy :- UsedByUpdateStrategy]
  {:pre [(db-common/conn? conn)]}
  (if-let [original-label (get-label conn label-uuid)]
    (do
      (timbre/debugf "Increment label %s use for org %s by user %s" label-uuid org-uuid (:user-id user))
      (let [found? (atom false)
            update-fn (if (= update-strategy :inc)
                        inc
                        dec)
            updated-used-by (update original-label
                                    :used-by (fn [used-by]
                                               (mapv (fn [{user-id :user-id use-count :count :or {use-count 0} :as used-by-row}]
                                                       (if (= user-id (:user-id user))
                                                         (let [next-count (max 0 (update-fn use-count))]
                                                           (reset! found? true)
                                                           {:user-id user-id :count next-count})
                                                         used-by-row))
                                                     used-by)))
            updated-label (if @found?
                            updated-used-by
                            (update original-label
                                    :used-by #(concat (vec %) [{:user-id (:user-id user) :count 1}])))]
        (db-common/update-resource conn table-name primary-key label-uuid updated-label)))
    (do
      (timbre/errorf "No label found for user %s and org %s." (:user-id user) org-uuid)
      (throw (ex-info "Invalid label uuid." {:label-uuid label-uuid :org-uuid org-uuid :user user})))))

(defn label-used-by! [conn label-uuid org-uuid user]
  (update-label-used-by! conn label-uuid org-uuid user :inc))

(defn label-unused-by! [conn label-uuid org-uuid user]
  (update-label-used-by! conn label-uuid org-uuid user :dec))

(defn labels-used-by! [conn label-uuids org-uuid user]
  (mapv #(update-label-used-by! conn % org-uuid user :inc) (vec label-uuids)))

(defn labels-unused-by! [conn label-uuids org-uuid user]
  (mapv #(update-label-used-by! conn % org-uuid user :dec) (vec label-uuids)))

(schema/defn ^:always-validate list-labels-by-org-user :- [common/Label]
  [conn org-uuid :- lib-schema/UniqueID user-id :- lib-schema/UniqueID]
  {:pre [(db-common/conn? conn)]}
  (db-common/read-resources conn table-name :org-uuid-user-id-labels [[org-uuid user-id]]))

(comment
  (require '[oc.storage.resources.org :as org])
  (require '[clojure.pprint :refer (pprint)])

  (def carrot (org/get-org conn "carrot"))
  (def author (:author carrot))
  (println (create-label! conn (->label "My label test" (:uuid carrot) author)))

  (def test-xss (create-label! conn (->label "<style>Test</style>out" (:uuid carrot) author)))
  (delete-label! conn (:uuid test-xss))

  (def test-label (get-label conn (:uuid carrot) "my-label-test"))

  (update-label! conn (:uuid test-label) {:name "My label test updated"})
  (:name (get-label conn (:uuid carrot) "my-label-test"))

  (pprint (list-labels-by-org conn (:uuid carrot)))

  (label-slug-for-org conn (:uuid carrot) "My label test") ;; => my-label-test-1

  (label-used-by! conn (:uuid test-label) (:uuid carrot) author)

  (def tmp-labels (list-labels-by-org-user conn (:uuid carrot) (:user-id author)))

  (labels-used-by! conn (mapv :uuid (take 2 tmp-labels)) (:uuid carrot) author)

  (labels-unused-by! conn (mapv :uuid (take 2 tmp-labels)) (:uuid carrot) author)

  (delete-label! conn (:uuid test-label))

  (get-label conn (:uuid carrot) "my-label-test"))

Remove not needd require.

Remove not needd require.