(ns web.components.nodes
  (:require [om.next :as om :refer-macros [defui]]
            [om.dom :as dom]
            [web.components.markdown :refer [markdown]]
            [web.components.node-link :refer [NodeLink node-link
                                              node->route]]
            [web.routing :as routing]))

(declare node)

(defui Node
  static om/Ident
  (ident [this props]
    [:node (:name props)])
  static om/IQuery
  (query [this]
    [:name :title :kind :description
     {:parent (om/get-query NodeLink)}
     {:children '...}
     {:mapped-here (om/get-query NodeLink)}
     {:mapped-to (om/get-query NodeLink)}
     :ui/expanded])
  Object
  (toggle-expanded [this]
    (let [ident (om/get-ident this)]
      (om/transact! this `[(app/toggle-node-expanded {:node ~ident})])))

  (set-permalink [this]
    (let [route (node->route (om/props this))]
      (routing/activate-route! route)))

  (satisfied? [this]
    (let [{:keys [kind mapped-here mapped-to]} (om/props this)]
      (case kind
        "requirement" (not (empty? mapped-to))
        "component" (and (not (empty? mapped-here))
                         (not (empty? mapped-to)))
        "work-item" (not (empty? mapped-here))
        "tag" true)))

  (render [this]
    (let [{:keys [name title kind description children
                  mapped-to mapped-here ui/expanded]} (om/props this)
          {:keys [parent]} (om/get-computed this)]
      (dom/div #js {:className
                    (str "node"
                         (when-not parent
                           " node-root")
                         (if (.satisfied? this)
                           " node-satisfied"
                           " node-unsatisfied"))}
        (dom/h2 #js {:className "node-header"}
          (dom/span #js {:className "node-header-title"
                         :onClick #(.toggle-expanded this)}
            title)
          (dom/a #js {:className "node-header-name"
                      :onClick #(.set-permalink this)}
            name))
        (dom/div #js {:className
                      (str "node-details"
                           (if expanded
                             " node-details-expanded"
                             " node-details-collapsed"))}
          (dom/div #js {:className "node-details-table"}
            (when description
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Description")
                (dom/div #js {:className "node-detail-content"}
                  (markdown {:text description}))))
            (when parent
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Parent")
                (dom/div #js {:className "node-detail-content"}
                  (node-link parent))))
            (when-not (= kind "requirement")
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Mapped here")
                (dom/div #js {:className "node-detail-content"}
                  (if (empty? mapped-here)
                    (dom/div #js {:className "error"}
                      "No requirements have been mapped here yet.")
                    (for [source mapped-here]
                      (node-link source))))))
            (when-not (some #{kind} ["work-item" "tag"])
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Mapped to")
                (dom/div #js {:className "node-detail-content"}
                  (if (empty? mapped-to)
                    (dom/div #js {:className "error"}
                      "Not mapped to any components yet.")
                    (for [target mapped-to]
                      (node-link target))))))))
        (dom/div #js {:className "node-subnodes"}
          (for [child children]
            (node
              (om/computed child {:parent (om/props this)}))))))))

(def node (om/factory Node {:key-fn :name}))

(defui Nodes
  Object
  (render [this]
    (let [nodes (:nodes (om/props this))]
      (dom/div #js {:className "nodes"}
        (for [node' (filter #(nil? (:parent %)) nodes)]
          (node node'))))))

(def nodes (om/factory Nodes))

(ns web.components.nodes
  (:require [om.next :as om :refer-macros [defui]]
            [om.dom :as dom]
            [web.components.markdown :refer [markdown]]
            [web.components.node-link :refer [NodeLink node-link
                                              node->route]]
            [web.routing :as routing]))

(declare node)

(defui Node
  static om/Ident
  (ident [this props]
    [:node (:name props)])
  static om/IQuery
  (query [this]
    [:name :title :kind :description
     {:parent (om/get-query NodeLink)}
     {:children '...}
     {:mapped-here (om/get-query NodeLink)}
     {:mapped-to (om/get-query NodeLink)}
     :ui/expanded])
  Object
  (toggle-expanded [this]
    (let [ident (om/get-ident this)]
      (om/transact! this `[(app/toggle-node-expanded {:node ~ident})])))

  (set-permalink [this]
    (let [route (node->route (om/props this))]
      (routing/activate-route! route)))

  (satisfied? [this]
    (let [{:keys [kind mapped-here mapped-to]} (om/props this)]
      (case kind
        "requirement" (not (empty? mapped-to))
        "component" (and (not (empty? mapped-here))
                         (not (empty? mapped-to)))
        "work-item" (not (empty? mapped-here))
        "tag" true)))

  (render [this]
    (let [{:keys [name title kind description children
                  mapped-to mapped-here ui/expanded]} (om/props this)
          {:keys [parent]} (om/get-computed this)]
      (dom/div #js {:className
                    (str "node"
                         (when-not parent
                           " node-root")
                         (if (.satisfied? this)
                           " node-satisfied"
                           " node-unsatisfied"))}
        (dom/h2 #js {:className "node-header"}
          (dom/span #js {:className "node-header-title"
                         :onClick #(.toggle-expanded this)}
            title)
          (dom/a #js {:className "node-header-name"
                      :onClick #(.set-permalink this)}
            name))
        (dom/div #js {:className
                      (str "node-details"
                           (if expanded
                             " node-details-expanded"
                             " node-details-collapsed"))}
          (dom/div #js {:className "node-details-table"}
            (when description
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Description")
                (dom/div #js {:className "node-detail-content"}
                  (markdown {:text description}))))
            (when parent
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Parent")
                (dom/div #js {:className "node-detail-content"}
                  (node-link parent))))
            (when-not (= kind "requirement")
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Mapped here")
                (dom/div #js {:className "node-detail-content"}
                  (if (empty? mapped-here)
                    (dom/div #js {:className "error"}
                      (if (= "component" kind)
                        "No requirements have been mapped here yet."
                        (str "No requirements or components have been "
                             "mapped here yet.")))
                    (for [source mapped-here]
                      (node-link source))))))
            (when-not (some #{kind} ["work-item" "tag"])
              (dom/div #js {:className "node-detail"}
                (dom/div #js {:className "node-detail-label"}
                  "Mapped to")
                (dom/div #js {:className "node-detail-content"}
                  (if (empty? mapped-to)
                    (dom/div #js {:className "error"}
                      (if (= "requirement" kind)
                        (str "Not mapped to any components or "
                             "work items yet.")
                        (str "Not mapped to any work items yet.")))
                    (for [target mapped-to]
                      (node-link target))))))))
        (dom/div #js {:className "node-subnodes"}
          (for [child children]
            (node
              (om/computed child {:parent (om/props this)}))))))))

(def node (om/factory Node {:key-fn :name}))

(defui Nodes
  Object
  (render [this]
    (let [nodes (:nodes (om/props this))]
      (dom/div #js {:className "nodes"}
        (for [node' (filter #(nil? (:parent %)) nodes)]
          (node node'))))))

(def nodes (om/factory Nodes))

Fix description for when mappings are incomplete


(defmacro unless [test ifnil iftrue]
  `(if ~test ~iftrue ~ifnil))

(unless false (println "TRUE") (println "FALSE"))

;; 关于 macro，可以看看这篇
;; http://blog.csdn.net/ithomer/article/details/17590193

(defmacro unless [test ifnil iftrue]
  `(if ~test ~iftrue ~ifnil))

;; List 实现

(defmacro unless [test ifnil iftrue]
  (list 'if test iftrue ifnil))

(unless false (println "TRUE") (println "FALSE"))

add macro unless (using list)

add macro unless (using list)


(ns random-access-map.core-test
  (:require [clojure.test :refer :all]
            [clojure.core.match :refer [match]]
            [random-access-map.core :refer :all]))

(defn violates-red-invariant?
  "Determines whether there are any red-red parent-child pairs in the tree."
  [tree]
  (if (ram-empty? tree)
    false
    (if (and (= (color tree) :red)
             (or (and (not (ram-empty? (ltree tree)))
                      (= :red (color (ltree tree))))
                 (and (not (ram-empty? (rtree tree)))
                      (= :red (color (rtree tree))))))
      true
      (or (violates-red-invariant? (ltree tree))
          (violates-red-invariant? (rtree tree))))))

(defn find-red-violation
  "Determines whether there are any red-red parent-child pairs in the tree."
  [tree]
  (let [list-builder (fn list-builder [t l]
                       (if (ram-empty? t)
                         l
                         (if (and (= (color t) :red)
                                  (or (and (not (ram-empty? (ltree t)))
                                           (= :red (color (ltree t))))
                                      (and (not (ram-empty? (rtree t)))
                                           (= :red (color (rtree t))))))
                           (list-builder (rtree t) (list-builder (ltree t) (cons t l))))))]
    (list-builder tree '())))

(defn height
  "Computes the height of a tree."
  [tree]
  (if (ram-empty? tree)
    0
    (max (inc (height (ltree tree)))
         (inc (height (rtree tree))))))

(defn black-height
  "Computes the black height of a tree."
  [tree]
  (if (ram-empty? tree)
    1
    (let [node-count
          (if (= :black (color tree))
            1
            0)]
      (+ node-count
         (max (black-height (ltree tree))
              (black-height (rtree tree)))))))

(defn violates-black-invariant?
  "Determines whether tree has unequal black heights for its branches."
  [tree]
  (if (ram-empty? tree)
    false
    (if (= (black-height (ltree tree)) (black-height (rtree tree)))
      false
      true)))

(defn naive-balanced?
  [t]
    (if (ram-empty? t)
      true
      ;; check heights recursively
      (let [l (ltree t)
            r (rtree t)
            lh (height l)
            rh (height r)]
        (and
         (if (< lh rh)
           (<= rh (+ (* 2 lh) 1))
           (if (< rh lh)
             (<= lh (+ (* 2 rh) 1))
             true))
         (naive-balanced? l)
         (naive-balanced? r)))))

(defn balanced?
  "Determines if a red-black tree is balanced"
  [tree]
  (let [t (.tree tree)]
    (and (not (or (violates-red-invariant? t)
                  (violates-black-invariant? t)))
         (naive-balanced? t))))

(defn k [a]
  (keyword (str a)))

(defn i [a b]
  (assoc a (k b) b))

(defn r [a b]
  (dissoc a (keyword (str b))))

(defn rn [a b]
  (disjoin-nth a b))

(defn actual-count [tree]
  (let [t (.tree tree)
        rec (fn rec [t]
              (let [t (.tree tree)]
                (match [t]
                       [:black-leaf] 0
                       [:double-black-leaf] 0
                       [[c l k v s r]] (+ (rec l) (rec r) 1)
                       :else
                       (ex-info "Actual count called on a non-tree."
                                {:type :ram-test/actual-count/invalid-input
                                 :tree tree}))))]
    (rec t)))

(defn valid-colors?
  "Checks to see if all colors are either red or black."
  [tree]
  (let [t (.tree tree)
        f (fn f [t]
            (if (keyword? t)
              (= t :black-leaf)
              (let [[c l k v s r] t]
                (and (or (= :black c) (= :red c))
                     (f l)
                     (f r)))))]
    (f t)))

(defn vec-remove-nth
  [v i]
  (vec (concat (subvec v 0 i) (subvec v (inc i) (count v)))))

(defn set->map
  [s]
  (reduce conj {}
          (map (fn [k v] (clojure.lang.MapEntry. k v))
               (range (count s))
               (sort (seq s)))))

(defn standard-tests [name m s]
  (testing (str "Testing the basics of " name "...")
    (is (balanced? m))
    (is (valid-colors? m))
    (is (= (count m) (actual-count m))))
  (testing (str "Testing find and get of " name "...")
    (doseq [thing (seq s)]
      (is (= (find m (k thing)) (clojure.lang.MapEntry. (k thing) thing)))
      (is (= (get m (k thing)) thing))))
  (testing (str "Testing nth of " name "...")
    (let [e (vec (sort (seq s)))
          f (fn f [v x]
              (if (>= x (count v))
                nil
                (do
                  (is (= (nth m x) (nth v x)))
                  (recur v (inc x)))))]
      (f e 0))))

(defn test-ranges [name
                   ins-range
                   rm-range
                   rmn-range]
  (let [first-map (reduce i (->RandomAccessMap) ins-range)
        first-img (reduce conj #{} ins-range)]
    (standard-tests (str "insert on " name) first-map first-img)
    (let [r-map (reduce r first-map rm-range)
          r-img (reduce disj first-img rm-range)]
      (standard-tests (str "remove on " name) r-map r-img))
    (let [rn-map (reduce rn first-map rmn-range)
          rn-img (set (reduce vec-remove-nth (vec (sort first-img)) rmn-range))]
      (standard-tests (str "remove-nth on " name) rn-map rn-img))))
(deftest empty-tests
  "Testing the empty maps."
  (test-ranges "empty" '() '() '()))
(deftest small-tests
  "Testing the small maps."
  (test-ranges "increasing order, 0 through 9" (range 10) '(1 3 5 6) '(5 4 3 2 1))
  (test-ranges "decreasing order, 9 through 0" (range 9 -1 -1) '(0 3 2 4) (repeat 3 0)))

(ns random-access-map.core-test
  (:require [clojure.test :refer :all]
            [clojure.core.match :refer [match]]
            [random-access-map.core :refer :all]))

(defn violates-red-invariant?
  "Determines whether there are any red-red parent-child pairs in the tree."
  [tree]
  (if (ram-empty? tree)
    false
    (if (and (= (color tree) :red)
             (or (and (not (ram-empty? (ltree tree)))
                      (= :red (color (ltree tree))))
                 (and (not (ram-empty? (rtree tree)))
                      (= :red (color (rtree tree))))))
      true
      (or (violates-red-invariant? (ltree tree))
          (violates-red-invariant? (rtree tree))))))

(defn find-red-violation
  "Determines whether there are any red-red parent-child pairs in the tree."
  [tree]
  (let [list-builder (fn list-builder [t l]
                       (if (ram-empty? t)
                         l
                         (if (and (= (color t) :red)
                                  (or (and (not (ram-empty? (ltree t)))
                                           (= :red (color (ltree t))))
                                      (and (not (ram-empty? (rtree t)))
                                           (= :red (color (rtree t))))))
                           (list-builder (rtree t) (list-builder (ltree t) (cons t l))))))]
    (list-builder tree '())))

(defn height
  "Computes the height of a tree."
  [tree]
  (if (ram-empty? tree)
    0
    (max (inc (height (ltree tree)))
         (inc (height (rtree tree))))))

(defn black-height
  "Computes the black height of a tree."
  [tree]
  (if (ram-empty? tree)
    1
    (let [node-count
          (if (= :black (color tree))
            1
            0)]
      (+ node-count
         (max (black-height (ltree tree))
              (black-height (rtree tree)))))))

(defn violates-black-invariant?
  "Determines whether tree has unequal black heights for its branches."
  [tree]
  (if (ram-empty? tree)
    false
    (if (= (black-height (ltree tree)) (black-height (rtree tree)))
      false
      true)))

(defn naive-balanced?
  [t]
    (if (ram-empty? t)
      true
      ;; check heights recursively
      (let [l (ltree t)
            r (rtree t)
            lh (height l)
            rh (height r)]
        (and
         (if (< lh rh)
           (<= rh (+ (* 2 lh) 1))
           (if (< rh lh)
             (<= lh (+ (* 2 rh) 1))
             true))
         (naive-balanced? l)
         (naive-balanced? r)))))

(defn balanced?
  "Determines if a red-black tree is balanced"
  [tree]
  (let [t (.tree tree)]
    (and (not (or (violates-red-invariant? t)
                  (violates-black-invariant? t)))
         (naive-balanced? t))))

(defn k [a]
  (keyword (str a)))

(defn i [a b]
  (assoc a (k b) b))

(defn r [a b]
  (dissoc a (keyword (str b))))

(defn rn [a b]
  (disjoin-nth a b))

(defn actual-count [tree]
  (let [t (.tree tree)
        rec (fn rec [t]
              (match [t]
                       [:black-leaf] 0
                       [:double-black-leaf] 0
                       [[c l k v s r]] (+ (rec l) (rec r) 1)
                       :else
                       (ex-info "Actual count called on a non-tree."
                                {:type :ram-test/actual-count/invalid-input
                                 :tree tree})))]
    (rec t)))
(defn kvp
  ([v]
     (clojure.lang.MapEntry. (k v) v))
  ([a b]
     (clojure.lang.MapEntry. (k a) b)))

(defn valid-colors?
  "Checks to see if all colors are either red or black."
  [tree]
  (let [t (.tree tree)
        f (fn f [t]
            (if (keyword? t)
              (= t :black-leaf)
              (let [[c l k v s r] t]
                (and (or (= :black c) (= :red c))
                     (f l)
                     (f r)))))]
    (f t)))

(defn vec-remove-nth
  [v i]
  (vec (concat (subvec v 0 i) (subvec v (inc i) (count v)))))

(defn set->map
  [s]
  (reduce conj {}
          (map (fn [k v] (kvp k v))
               (range (count s))
               (sort (seq s)))))
(defn standard-print [m s]
  (str "\nThe tested map is:\n" m "\n\nThe tested coll is:\n" s))

(defn standard-tests [name m s]
  (testing (str "Testing the basics of " name "." (standard-print m s))
    (is (balanced? m))
    (is (valid-colors? m))
    (is (= (count m) (actual-count m))))
  (doseq [thing (seq s)]
    (testing (str "Testing find and get of " thing " in " name "." (standard-print m s))
      (is (= (find m (k thing)) (kvp thing)))
      (is (= (get m (k thing)) thing))))
  (let [e (vec (sort (seq s)))]
    ((fn [v x]
            (if (>= x (count v))
              nil
              (do
                (testing (str "Testing nth of " x " in " name "." (standard-print m v))
                  (is (= (nth m x) (kvp x (nth v x)))))
                  (recur v (inc x))))) e 0)))

(defn test-ranges [name
                   ins-range
                   rm-range
                   rmn-range]
  (let [first-map (reduce i (->RandomAccessMap) ins-range)
        first-img (reduce conj #{} ins-range)]
    (standard-tests (str "insert on " name) first-map first-img)
    (let [r-map (reduce r first-map rm-range)
          r-img (reduce disj first-img rm-range)]
      (standard-tests (str "remove on " name) r-map r-img))
    (let [rn-map (reduce rn first-map rmn-range)
          rn-img (set (reduce vec-remove-nth (vec (sort first-img)) rmn-range))]
      (standard-tests (str "remove-nth on " name) rn-map rn-img))))
(deftest empty-tests
  "Testing the empty maps."
  (test-ranges "empty" '() '() '()))
(deftest small-tests
  "Testing the small maps."
  (test-ranges "increasing order, 0 through 9" (range 10) '(1 3 5 6) '(5 4 3 2 1))
  (test-ranges "decreasing order, 9 through 0" (range 9 -1 -1) '(0 3 2 4) (repeat 3 0)))

Improve the printout on the tests when they fail. clip.


(ns cmr.search.services.parameters.converters.shapefile
  "Contains parameter converters for shapefile parameter"
  (:require
   [clojure.java.io :as io]
   [cmr.common.config :as cfg :refer [defconfig]]
   [cmr.common.log :refer [debug info]]
   [cmr.common.mime-types :as mt]
   [cmr.common.util :as util]
   [cmr.common-app.services.search.group-query-conditions :as gc]
   [cmr.common-app.services.search.params :as p]
   [cmr.common.services.errors :as errors]
   [cmr.search.services.parameters.converters.geojson :as geojson]
   [cmr.search.services.parameters.converters.geometry :as geo])
  (:import
   (java.io File FileInputStream)
   (java.nio.file Files)
   (java.nio.file.attribute FileAttribute)
   (java.util ArrayList)
   (java.util.zip ZipFile)
   (org.apache.commons.io FilenameUtils)
   (org.geotools.data FileDataStoreFinder)
   (org.geotools.data.geojson GeoJSONDataStore)
   (org.geotools.geometry.jts JTS)
   (org.geotools.kml.v22 KMLConfiguration)
   (org.geotools.referencing CRS)
   (org.geotools.util URLs)
   (org.geotools.xsd PullParser)
   (org.locationtech.jts.geom Geometry)
   (org.opengis.feature.simple SimpleFeature)))

(def EPSG-4326-CRS
  "The CRS object for WGS 84"
  (CRS/decode "EPSG:4326" true))

(defconfig enable-shapefile-parameter-flag
  "Flag that indicates if we allow spatial searching by shapefile."
  {:default false :type Boolean})

(defconfig max-shapefile-features
  "The maximum number of feature a shapefile can have"
  {:default 500 :type Long})

(defconfig max-shapefile-points
  "The maximum number of points a shapefile can have"
  {:default 5000 :type Long})

(defn winding-opts
  "Get the opts for a call to `normalize-polygon-winding` based on file type"
  [mime-type]
  (case mime-type
    "application/shapefile+zip" {:boundary-winding :cw}
    "application/vnd.google-earth.kml+xml" {}
    "application/geo+json" {:hole-winding :cw}))

(defn unzip-file
  "Unzip a file (of type File) into a temporary directory and return the directory path as a File"
  [source]
  (let [target-dir (Files/createTempDirectory "Shapes" (into-array FileAttribute []))]
    (try
      (with-open [zip (ZipFile. source)]
        (let [entries (enumeration-seq (.entries zip))
              target-file #(File. (.toString target-dir) (str %))]
          (doseq [entry entries :when (not (.isDirectory ^java.util.zip.ZipEntry entry))
                  :let [f (target-file entry)]]
            (debug (format "Zip file entry: [%s]" (.getName entry)))
            (io/copy (.getInputStream zip entry) f))))
      (.toFile target-dir)
      (catch Exception e
        (.delete (.toFile target-dir))
        (errors/throw-service-error :bad-request (str "Error while uncompressing zip file: " (.getMessage e)))))))

(defn find-shp-file
  "Find the .shp file in the given directory (File) and return it as a File"
  [dir]
  (let [files (file-seq dir)]
    (first (filter #(= "shp" (FilenameUtils/getExtension (.getAbsolutePath %))) files))))

(defn geometry->conditions
  "Get one or more conditions for the given Geometry. This will only
  return more than one condition if the Geometry is a GeometryCollection.
  The `options` map can be used to provided additional information."
  [^Geometry geometry options]
  (let [num-geometries (.getNumGeometries geometry)]
    (debug (format "NUM SUB GEOMETRIES: [%d]" num-geometries))
    (for [index (range 0 num-geometries)
          :let [sub-geometry (.getGeometryN geometry index)]]
      (geo/geometry->condition sub-geometry options))))

(defn geometry-point-count
  "Get the number of points in the given Geometry"
  [^Geometry geometry]
  (let [num-geometries (.getNumGeometries geometry)
        all-geometries  (for [index (range 0 num-geometries)
                              :let [sub-geometry (.getGeometryN geometry index)]]
                          sub-geometry)]
    (reduce (fn [count geometry] (+ count (.getNumPoints geometry))) 0 all-geometries)))

(defn transform-to-epsg-4326
  "Transform the geometry to WGS84 CRS if is not already"
  [geometry src-crs]
  ;; if the source CRS is defined and not already WGS84 then transform the geometry to WGS84
  (if (and src-crs
           (not (= (.getName src-crs) (.getName EPSG-4326-CRS))))
    (let [src-crs-name (.getName src-crs)]
      (debug (format "Source CRS: [%s]" src-crs-name))
      (debug (format "Source axis order: [%s]" (CRS/getAxisOrder src-crs)))
      (debug (format "Destination CRS: [%s]" (.getName EPSG-4326-CRS)))
      (debug (format "Destination axis order: [%s]" (CRS/getAxisOrder EPSG-4326-CRS)))
      ; If we find a transform use it to transform the geometry,
      ; otherwise send an error message
      (if-let [transform (try
                           (CRS/findMathTransform src-crs EPSG-4326-CRS false)
                           (catch Exception e))]
        (let [new-geometry (JTS/transform geometry transform)]
          (debug (format "New geometry: [%s" new-geometry))
          new-geometry)
        (errors/throw-service-error :bad-request (format "Cannot transform source CRS [%s] to WGS 84" src-crs-name))))
    geometry))

(defn feature-point-count
  "Get the number of points in the Feature"
  [feature]
  (let [crs (when (.getDefaultGeometryProperty feature)
              (-> feature .getDefaultGeometryProperty .getDescriptor .getCoordinateReferenceSystem))
        properties (.getProperties feature)
        geometry-props (filter (fn [p] (geo/geometry? (.getValue p))) properties)
        geometries (map #(-> % .getValue (transform-to-epsg-4326 crs)) geometry-props)]
    (apply + (map geometry-point-count geometries))))

(defn features-point-count
  "Compute the number of points in a list of Features"
  [features]
  (reduce (fn [total feature] (+ total (feature-point-count feature)))
          0
          features))

(defn validate-point-count
  "Validate that the number of points in the features is greater than zero and less than the limit"
  [features]
  (let [point-count (features-point-count features)]
    (if (= point-count 0)
      "Shapefile has no points"
      (when (> point-count (max-shapefile-points))
        (format "Number of points in shapefile exceeds the limit of %d"
          (max-shapefile-points))))))

(defn- validate-feature-count
  "Validates that the number of features is greater than zero and less than the limit"
  [features]
  (let [feature-count (count features)]
    (if (= feature-count 0)
      "Shapefile has no features"
      (when (> feature-count (max-shapefile-features))
        (format "Shapefile feature count [%d] exceeds the %d feature limit"
          feature-count
          (max-shapefile-features))))))

(defn validate-features
  "Validate this list of features in terms of shapefile limits"
  [features]
  (when-let [message (or (validate-feature-count features) (validate-point-count features))]
    (errors/throw-service-error :bad-request message)))

(defn feature->conditions
  "Process the contents of a Feature to return query conditions along with number of points in
  the processed Feature. The `context` map can be used to pass along additional info."
  [feature context]
  (let [crs (when (.getDefaultGeometryProperty feature)
              (-> feature .getDefaultGeometryProperty .getDescriptor .getCoordinateReferenceSystem))
        properties (.getProperties feature)
        _ (doseq [p properties] (debug (.getName p)) (debug (.getValue p)))
        geometry-props (filter (fn [p] (geo/geometry? (.getValue p))) properties)
        _ (debug (format "Found [%d] geometries" (count geometry-props)))
        geometries (map #(-> % .getValue (transform-to-epsg-4326 crs)) geometry-props)
        _ (debug (format "Transformed [%d] geometries" (count geometries)))
        point-count (apply + (map geometry-point-count geometries))
        conditions (mapcat (fn [g] (geometry->conditions g context)) geometries)]
    (debug (format "CONDITIONS: %s" conditions))
    [conditions point-count]))

(defn features->conditions
  "Converts a list of features into a vector of SpatialConditions"
  [features mime-type]
  (validate-features features)
  (let [iterator (.iterator features)]
    (loop [conditions []]
      (if (.hasNext iterator)
        (let [feature (.next iterator)
              [feature-conditions _] (feature->conditions feature (winding-opts mime-type))]
          (if (> (count feature-conditions) 0)
            (recur (conj conditions (gc/or-conds feature-conditions)))
            (recur conditions)))
        conditions))))

(defn error-if
  "Throw a service error with the given message if `f` applied to `item` is true.
  Otherwise just return `item`. Removes the temporary file/directory `temp-file` first."
  [item f message ^File temp-file]
  (if (f item)
    (do
      (when temp-file (.delete temp-file))
      (errors/throw-service-error :bad-request message))
    item))

(defn esri-shapefile->condition-vec
  "Converts a shapefile to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          ^File temp-dir (unzip-file file)
          shp-file (error-if
                    (find-shp-file temp-dir)
                    nil?
                    "Incomplete shapefile: missing .shp file"
                    temp-dir)
          data-store (FileDataStoreFinder/getDataStore shp-file)
          feature-source (.getFeatureSource data-store)
          features (.getFeatures feature-source)
          feature-count (error-if (.size features)
                                  #(< % 1)
                                  "Shapefile has no features"
                                  temp-dir)
          _ (error-if feature-count
                      #(> % (max-shapefile-features))
                      (format "Shapefile feature count [%d] exceeds the %d feature limit"
                              feature-count
                              (max-shapefile-features))
                      nil)
          _ (debug (format "Found [%d] features" feature-count))
          iterator (.features features)]
      (try
        (loop [conditions [] total-point-count 0]
          (if (.hasNext iterator)
            (let [feature (.next iterator)
                  [feature-conditions num-points] (feature->conditions feature {:boundary-winding :cw})
                  new-point-count (+ total-point-count num-points)]
              (when (> new-point-count (max-shapefile-points))
                (errors/throw-service-error :bad-request
                                            (format "Number of points in shapefile exceeds the limit of %d"
                                                    (max-shapefile-points))))
              (if (> (count feature-conditions) 0)
                (recur (conj conditions (gc/or-conds feature-conditions)) new-point-count)
                (recur conditions total-point-count)))
            conditions))
        (finally
          (.close iterator)
          (-> data-store .getFeatureReader .close)
          (.delete temp-dir))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn geojson->conditions-vec
  "Converts a geojson file to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          _ (geojson/sanitize-geojson file)
          url (URLs/fileToUrl file)
          data-store (GeoJSONDataStore. url)
          feature-source (.getFeatureSource data-store)
          features (.getFeatures feature-source)
          ;; Fail fast
          _ (when (or (nil? features)
                      (nil? (.getSchema features))
                      (.isEmpty features))
              (errors/throw-service-error :bad-request "Shapefile has no features"))
          iterator (.features features)
          feature-list (ArrayList.)]
      (try
        (while (.hasNext iterator)
          (let [feature (.next iterator)]
            (.add feature-list feature)))
        (features->conditions feature-list mt/geojson)
        (finally
          (.close iterator)
          (-> data-store .getFeatureReader .close)
          (.delete file))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn kml->conditions-vec
  "Converts a kml file to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          input-stream (FileInputStream. file)
          parser (PullParser. (KMLConfiguration.) input-stream SimpleFeature)
          feature-list (ArrayList.)]
      (try
        (util/while-let [feature (.parse parser)]
          (when (> (feature-point-count feature) 0)
            (.add feature-list feature)))
        (features->conditions feature-list mt/kml)
        (finally
          (.delete file))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn in-memory->conditions-vec
  "Converts a group of features produced by simplification to a vector of SpatialConditions"
  [shapefile-info]
  (let [^ArrayList features (:tempfile shapefile-info)
        mime-type (:content-type shapefile-info)]
    (features->conditions features mime-type)))

(defmulti shapefile->conditions
  "Converts a shapefile to query conditions based on shapefile format"
  (fn [shapefile-info]
    (info (format "SHAPEFILE FORMAT: %s" (:contenty-type shapefile-info)))
    (if (:in-memory shapefile-info)
      :in-memory
      (:content-type shapefile-info))))

;; ESRI shapefiles
(defmethod shapefile->conditions mt/shapefile
  [shapefile-info]
  (let [conditions-vec (esri-shapefile->condition-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; GeoJSON
(defmethod shapefile->conditions mt/geojson
  [shapefile-info]
  (let [conditions-vec (geojson->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; KML
(defmethod shapefile->conditions mt/kml
  [shapefile-info]
  (let [conditions-vec (kml->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; Simplfied and stored in memory
(defmethod shapefile->conditions :in-memory
  [shapefile-info]
  (let [conditions-vec (in-memory->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

(defmethod p/parameter->condition :shapefile
  [_context _concept-type _param value _options]
  (if (enable-shapefile-parameter-flag)
    (shapefile->conditions value)
    (errors/throw-service-error :bad-request "Searching by shapefile is not enabled")))

(ns cmr.search.services.parameters.converters.shapefile
  "Contains parameter converters for shapefile parameter"
  (:require
   [clojure.java.io :as io]
   [cmr.common.config :as cfg :refer [defconfig]]
   [cmr.common.log :refer [debug info]]
   [cmr.common.mime-types :as mt]
   [cmr.common.util :as util]
   [cmr.common-app.services.search.group-query-conditions :as gc]
   [cmr.common-app.services.search.params :as p]
   [cmr.common.services.errors :as errors]
   [cmr.search.services.parameters.converters.geojson :as geojson]
   [cmr.search.services.parameters.converters.geometry :as geo])
  (:import
   (java.io File FileInputStream)
   (java.nio.file Files)
   (java.nio.file.attribute FileAttribute)
   (java.util ArrayList)
   (java.util.zip ZipFile)
   (org.apache.commons.io FilenameUtils)
   (org.geotools.data FileDataStoreFinder)
   (org.geotools.data.geojson GeoJSONDataStore)
   (org.geotools.geometry.jts JTS)
   (org.geotools.kml.v22 KMLConfiguration)
   (org.geotools.referencing CRS)
   (org.geotools.util URLs)
   (org.geotools.xsd PullParser)
   (org.locationtech.jts.geom Geometry)
   (org.opengis.feature.simple SimpleFeature)))

(def EPSG-4326-CRS
  "The CRS object for WGS 84"
  (CRS/decode "EPSG:4326" true))

(defconfig enable-shapefile-parameter-flag
  "Flag that indicates if we allow spatial searching by shapefile."
  {:default false :type Boolean})

(defconfig max-shapefile-features
  "The maximum number of feature a shapefile can have"
  {:default 500 :type Long})

(defconfig max-shapefile-points
  "The maximum number of points a shapefile can have"
  {:default 5000 :type Long})

(defn winding-opts
  "Get the opts for a call to `normalize-polygon-winding` based on file type"
  [mime-type]
  (case mime-type
    "application/shapefile+zip" {:boundary-winding :cw}
    "application/vnd.google-earth.kml+xml" {}
    "application/geo+json" {:hole-winding :cw}))

(defn unzip-file
  "Unzip a file (of type File) into a temporary directory and return the directory path as a File"
  [source]
  (let [target-dir (Files/createTempDirectory "Shapes" (into-array FileAttribute []))]
    (try
      (with-open [zip (ZipFile. source)]
        (let [entries (enumeration-seq (.entries zip))
              target-file #(File. (.toString target-dir) (str %))]
          (doseq [entry entries :when (not (.isDirectory ^java.util.zip.ZipEntry entry))
                  :let [f (target-file entry)]]
            (debug (format "Zip file entry: [%s]" (.getName entry)))
            (io/copy (.getInputStream zip entry) f))))
      (.toFile target-dir)
      (catch Exception e
        (.delete (.toFile target-dir))
        (errors/throw-service-error :bad-request (str "Error while uncompressing zip file: " (.getMessage e)))))))

(defn find-shp-file
  "Find the .shp file in the given directory (File) and return it as a File"
  [dir]
  (let [files (file-seq dir)]
    (first (filter #(= "shp" (FilenameUtils/getExtension (.getAbsolutePath %))) files))))

(defn geometry->conditions
  "Get one or more conditions for the given Geometry. This will only
  return more than one condition if the Geometry is a GeometryCollection.
  The `options` map can be used to provided additional information."
  [^Geometry geometry options]
  (let [num-geometries (.getNumGeometries geometry)]
    (debug (format "NUM SUB GEOMETRIES: [%d]" num-geometries))
    (for [index (range 0 num-geometries)
          :let [sub-geometry (.getGeometryN geometry index)]]
      (geo/geometry->condition sub-geometry options))))

(defn geometry-point-count
  "Get the number of points in the given Geometry"
  [^Geometry geometry]
  (let [num-geometries (.getNumGeometries geometry)
        all-geometries  (for [index (range 0 num-geometries)
                              :let [sub-geometry (.getGeometryN geometry index)]]
                          sub-geometry)]
    (reduce (fn [count geometry] (+ count (.getNumPoints geometry))) 0 all-geometries)))

(defn transform-to-epsg-4326
  "Transform the geometry to WGS84 CRS if is not already"
  [geometry src-crs]
  ;; if the source CRS is defined and not already WGS84 then transform the geometry to WGS84
  (if (and src-crs
           (not (= (.getName src-crs) (.getName EPSG-4326-CRS))))
    (let [src-crs-name (.getName src-crs)]
      (debug (format "Source CRS: [%s]" src-crs-name))
      (debug (format "Source axis order: [%s]" (CRS/getAxisOrder src-crs)))
      (debug (format "Destination CRS: [%s]" (.getName EPSG-4326-CRS)))
      (debug (format "Destination axis order: [%s]" (CRS/getAxisOrder EPSG-4326-CRS)))
      ; If we find a transform use it to transform the geometry,
      ; otherwise send an error message
      (if-let [transform (try
                           (CRS/findMathTransform src-crs EPSG-4326-CRS false)
                           (catch Exception e))]
        (let [new-geometry (JTS/transform geometry transform)]
          (debug (format "New geometry: [%s" new-geometry))
          new-geometry)
        (errors/throw-service-error :bad-request (format "Cannot transform source CRS [%s] to WGS 84" src-crs-name))))
    geometry))

(defn feature-point-count
  "Get the number of points in the Feature"
  [feature]
  (let [crs (when (.getDefaultGeometryProperty feature)
              (-> feature .getDefaultGeometryProperty .getDescriptor .getCoordinateReferenceSystem))
        properties (.getProperties feature)
        geometry-props (filter (fn [p] (geo/geometry? (.getValue p))) properties)
        geometries (map #(-> % .getValue (transform-to-epsg-4326 crs)) geometry-props)]
    (apply + (map geometry-point-count geometries))))

(defn features-point-count
  "Compute the number of points in a list of Features"
  [features]
  (reduce (fn [total feature] (+ total (feature-point-count feature)))
          0
          features))

(defn validate-point-count
  "Validate that the number of points in the features is greater than zero and less than the limit"
  [features]
  (let [point-count (features-point-count features)]
    (if (= point-count 0)
      "Shapefile has no points"
      (when (> point-count (max-shapefile-points))
        (format "Number of points in shapefile exceeds the limit of %d"
          (max-shapefile-points))))))

(defn- validate-feature-count
  "Validates that the number of features is greater than zero and less than the limit"
  [features]
  (let [feature-count (count features)]
    (if (= feature-count 0)
      "Shapefile has no features"
      (when (> feature-count (max-shapefile-features))
        (format "Shapefile feature count [%d] exceeds the %d feature limit"
          feature-count
          (max-shapefile-features))))))

(defn validate-features
  "Validate this list of features in terms of shapefile limits"
  [features]
  (when-let [message (or (validate-feature-count features) (validate-point-count features))]
    (errors/throw-service-error :bad-request message)))

(defn feature->conditions
  "Process the contents of a Feature to return query conditions along with number of points in
  the processed Feature. The `context` map can be used to pass along additional info."
  [feature context]
  (let [crs (when (.getDefaultGeometryProperty feature)
              (-> feature .getDefaultGeometryProperty .getDescriptor .getCoordinateReferenceSystem))
        properties (.getProperties feature)
        _ (doseq [p properties] (debug (.getName p)) (debug (.getValue p)))
        geometry-props (filter (fn [p] (geo/geometry? (.getValue p))) properties)
        _ (debug (format "Found [%d] geometries" (count geometry-props)))
        geometries (map #(-> % .getValue (transform-to-epsg-4326 crs)) geometry-props)
        _ (debug (format "Transformed [%d] geometries" (count geometries)))
        point-count (apply + (map geometry-point-count geometries))
        conditions (mapcat (fn [g] (geometry->conditions g context)) geometries)]
    (debug (format "CONDITIONS: %s" conditions))
    [conditions point-count]))

(defn features->conditions
  "Converts a list of features into a vector of SpatialConditions"
  [features mime-type]
  (validate-features features)
  (let [iterator (.iterator features)]
    (loop [conditions []]
      (if (.hasNext iterator)
        (let [feature (.next iterator)
              [feature-conditions _] (feature->conditions feature (winding-opts mime-type))]
          (if (> (count feature-conditions) 0)
            (recur (conj conditions (gc/or-conds feature-conditions)))
            (recur conditions)))
        conditions))))

(defn error-if
  "Throw a service error with the given message if `f` applied to `item` is true.
  Otherwise just return `item`. Removes the temporary file/directory `temp-file` first."
  [item f message ^File temp-file]
  (if (f item)
    (do
      (when temp-file (.delete temp-file))
      (errors/throw-service-error :bad-request message))
    item))

(defn esri-shapefile->condition-vec
  "Converts a shapefile to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          ^File temp-dir (unzip-file file)
          shp-file (error-if
                    (find-shp-file temp-dir)
                    nil?
                    "Incomplete shapefile: missing .shp file"
                    temp-dir)
          data-store (FileDataStoreFinder/getDataStore shp-file)
          feature-source (.getFeatureSource data-store)
          features (.getFeatures feature-source)
          iterator (.features features)
          feature-list (ArrayList.)]
      (try
        (while (.hasNext iterator)
          (let [feature (.next iterator)]
            (.add feature-list feature)))
        (features->conditions feature-list mt/shapefile)
        (finally
          (.close iterator)
          (-> data-store .getFeatureReader .close)
          (.delete temp-dir))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn geojson->conditions-vec
  "Converts a geojson file to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          _ (geojson/sanitize-geojson file)
          url (URLs/fileToUrl file)
          data-store (GeoJSONDataStore. url)
          feature-source (.getFeatureSource data-store)
          features (.getFeatures feature-source)
          ;; Fail fast
          _ (when (or (nil? features)
                      (nil? (.getSchema features))
                      (.isEmpty features))
              (errors/throw-service-error :bad-request "Shapefile has no features"))
          iterator (.features features)
          feature-list (ArrayList.)]
      (try
        (while (.hasNext iterator)
          (let [feature (.next iterator)]
            (.add feature-list feature)))
        (features->conditions feature-list mt/geojson)
        (finally
          (.close iterator)
          (-> data-store .getFeatureReader .close)
          (.delete file))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn kml->conditions-vec
  "Converts a kml file to a vector of SpatialConditions"
  [shapefile-info]
  (try
    (let [file (:tempfile shapefile-info)
          input-stream (FileInputStream. file)
          parser (PullParser. (KMLConfiguration.) input-stream SimpleFeature)
          feature-list (ArrayList.)]
      (try
        (util/while-let [feature (.parse parser)]
          (when (> (feature-point-count feature) 0)
            (.add feature-list feature)))
        (features->conditions feature-list mt/kml)
        (finally
          (.delete file))))
    (catch Exception e
      (let [{:keys [type errors]} (ex-data e)]
        (if (and type errors)
          (throw e) ;; This was a more specific service error so just re-throw it
          (errors/throw-service-error :bad-request "Failed to parse shapefile"))))))

(defn in-memory->conditions-vec
  "Converts a group of features produced by simplification to a vector of SpatialConditions"
  [shapefile-info]
  (let [^ArrayList features (:tempfile shapefile-info)
        mime-type (:content-type shapefile-info)]
    (features->conditions features mime-type)))

(defmulti shapefile->conditions
  "Converts a shapefile to query conditions based on shapefile format"
  (fn [shapefile-info]
    (info (format "SHAPEFILE FORMAT: %s" (:contenty-type shapefile-info)))
    (if (:in-memory shapefile-info)
      :in-memory
      (:content-type shapefile-info))))

;; ESRI shapefiles
(defmethod shapefile->conditions mt/shapefile
  [shapefile-info]
  (let [conditions-vec (esri-shapefile->condition-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; GeoJSON
(defmethod shapefile->conditions mt/geojson
  [shapefile-info]
  (let [conditions-vec (geojson->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; KML
(defmethod shapefile->conditions mt/kml
  [shapefile-info]
  (let [conditions-vec (kml->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

;; Simplfied and stored in memory
(defmethod shapefile->conditions :in-memory
  [shapefile-info]
  (let [conditions-vec (in-memory->conditions-vec shapefile-info)]
    (gc/or-conds (flatten conditions-vec))))

(defmethod p/parameter->condition :shapefile
  [_context _concept-type _param value _options]
  (if (enable-shapefile-parameter-flag)
    (shapefile->conditions value)
    (errors/throw-service-error :bad-request "Searching by shapefile is not enabled")))

CMR-6499: Change ESRI shapefile processing to be more generic


(ns figwheel-sidecar.auto-builder
  (:require
   [clojure.pprint :as p]
   [figwheel-sidecar.core :as fig]
   [figwheel-sidecar.config :as config]
   [cljs.repl]
   [cljs.analyzer :as ana]
   [cljs.env]
   #_[clj-stacktrace.repl]
   [clojure.stacktrace :as stack]
   [clojurescript-build.core :as cbuild]
   [clojurescript-build.auto :as auto]
   [clojure.java.io :as io]
   [clojure.string :as string]
   [clojure.set :refer [intersection]]
   [cljsbuild.util :as util]))

(defn notify-cljs [command message]
  (when (seq (:shell command))
    (try
      (util/sh (update-in command [:shell] (fn [old] (concat old [message]))))
      (catch Throwable e
        (println (auto/red "Error running :notify-command:"))
        (stack/print-stack-trace e 30)
        (flush)
        #_(clj-stacktrace.repl/pst+ e)))))

(defn notify-on-complete [{:keys [build-options parsed-notify-command]}]
  (let [{:keys [output-to]} build-options]
    (notify-cljs
     parsed-notify-command
     (str "Successfully compiled " output-to))))

(defn merge-build-into-server-state [figwheel-server {:keys [id build-options]}]
  (merge figwheel-server
         (if id {:build-id id} {})
         (select-keys build-options [:output-dir :output-to :recompile-dependents])))

(defn check-changes [figwheel-server build]
  (let [{:keys [additional-changed-ns build-options id old-mtimes new-mtimes]} build]
    (binding [cljs.env/*compiler* (:compiler-env build)]
      (fig/check-for-changes
       (merge-build-into-server-state figwheel-server build)
       old-mtimes
       new-mtimes
       additional-changed-ns))))

(defmulti report-exception (fn [exception cause] (:type cause)))

(defmethod report-exception :reader-exception [e {:keys [file line column]}]
  (println (format "ERROR: %s on file %s, line %d, column %d"
                   (some-> e (.getCause) (.getMessage))
                   file line column)))

(defmethod report-exception :default [e _]
  (stack/print-stack-trace e 30))

(defn handle-exceptions [figwheel-server {:keys [build-options exception id] :as build}]
  (println (auto/red (str "Compiling \"" (:output-to build-options) "\" failed.")))
  (let [cause (ex-data (.getCause exception))]
    (report-exception exception cause)
    (flush)
    #_(clj-stacktrace.repl/pst+ exception)
    (fig/compile-error-occured
      (merge-build-into-server-state figwheel-server build)
      exception
      cause)))

(defn warning [builder warn-handler]
  (fn [build]
    (binding [cljs.analyzer/*cljs-warning-handlers* (conj cljs.analyzer/*cljs-warning-handlers*
                                                          (warn-handler build))]
      (builder build))))

(defn default-build-options [builder default-options]
  (fn [build]
    (builder
     (update-in build [:build-options] (partial merge default-options)))))

;; connection

(defn connect-script-temp-dir [build]
  (str "target/figwheel_temp/" (name (:id build))))

(defn connect-script-path [build]
  (str (connect-script-temp-dir build) "/figwheel/connect.cljs"))

(def figwheel-client-hook-keys [:on-jsload
                                :before-jsload
                                :on-cssload
                                :on-compile-fail
                                :on-compile-fail])

(defn extract-connection-requires [{:keys [figwheel] :as build}]
  (let [names (set
               (map #(symbol (namespace (symbol %)))
                    (vals (select-keys figwheel figwheel-client-hook-keys))))
        ;; if there is a main defined then add it
        main-ns  (get-in build [:build-options :main])
        names (if main-ns
                (conj names (symbol (str main-ns)))
                names)]
    (conj names 'figwheel.client 'figwheel.client.utils)))

(defn extract-connection-script-required-ns [{:keys [figwheel] :as build}]
  (list 'ns 'figwheel.connect
        (cons :require (map vector (extract-connection-requires build)))))

(defn hook-name-to-js [hook-name]
  (symbol
   (str "js/"
        (string/join "." (string/split (str hook-name) #"/")))))

(defn try-jsreload-hook [k hook-name]
  ;; change hook to js form to avoid compile warnings when it doesn't
  ;; exist, these compile warnings are confusing and prevent code loading
  (let [hook-name' (hook-name-to-js hook-name)]
    (list 'fn '[& x]
          (list 'if hook-name'
                (list 'apply hook-name' 'x)
                (list 'figwheel.client.utils/log :debug (str "Figwheel: " k " hook '" hook-name "' is missing"))))))

(defn extract-connection-script-figwheel-start [{:keys [figwheel]}]
  (let [func-map (select-keys figwheel figwheel-client-hook-keys)
        func-map (into {} (map (fn [[k v]] [k (try-jsreload-hook k v)]) func-map))
        res (merge figwheel func-map)]
    (list 'figwheel.client/start res)))

(comment

  (extract-connection-script-required-ns {:figwheel {:on-jsload "blah.blah/on-jsload"}})

  (extract-connection-script-required-ns {:figwheel {}})

  (extract-connection-script-figwheel-start {:figwheel {:on-jsload "blah.blah/on-jsload" :websocket-url "hey"}})

  )

(defn create-connect-script! [build]
  ;;; consider doing this is the system temp dir
  (let [temp-file (io/file (connect-script-path build))]
    (.mkdirs (.getParentFile temp-file))
    (.deleteOnExit temp-file)
    (with-open [file (io/writer temp-file)]
      (binding [*out* file]
        (println
         (apply str (mapcat
                     prn-str
                     (list (extract-connection-script-required-ns build)
                           (extract-connection-script-figwheel-start build)))))))
    temp-file))

(defn create-connect-script-if-needed! [build]
  (when (config/figwheel-build? build)
    (when-not (.exists (io/file (connect-script-path build)))
      (create-connect-script! build))))

(defn add-connect-script! [figwheel-server build]
  (if (config/figwheel-build? build)
    (let [build (config/update-figwheel-connect-options figwheel-server build)]
      (create-connect-script-if-needed! build)
      (update-in build [:source-paths] conj (connect-script-temp-dir build)))
    build))

(defn require-connection-script-js [build]
  (let [node? (and (:target build) (== (:target build) :nodejs))
        main? (get-in build [:build-options :main])]
    (if (and main? (not node?))
      "\ndocument.write(\"<script>if (typeof goog != \\\"undefined\\\") { goog.require(\\\"figwheel.connect\\\"); }</script>\");"
      "\ngoog.require(\"figwheel.connect\");")))

(defn append-connection-init! [build]
  (when (config/figwheel-build? build)
    (when-let [output-to (get-in build [:build-options :output-to])]
      (spit output-to (require-connection-script-js build) :append true))))

(defn insert-figwheel-connect-script [builder figwheel-server]
  (fn [build]
    (let [res (builder (add-connect-script! figwheel-server build))]
      (append-connection-init! build)
      res)))

(defn builder [figwheel-server]
  (-> cbuild/build-source-paths*
    (default-build-options {:recompile-dependents false})
    (insert-figwheel-connect-script figwheel-server)
    (warning
     (fn [build]
       (auto/warning-message-handler
        (partial fig/compile-warning-occured
                 (merge-build-into-server-state figwheel-server build)))))
    auto/time-build
    (auto/after auto/compile-success)
    (auto/after (partial check-changes figwheel-server))
    (auto/after notify-on-complete)
    (auto/error (partial handle-exceptions figwheel-server))
    (auto/before auto/compile-start)))

(defn delete-connect-scripts! [builds]
  (doseq [b builds]
    (when (config/figwheel-build? b)
      (let [f (io/file (connect-script-path b))]
        (when (.exists f) (.delete f))))))

(defn autobuild* [{:keys [builds figwheel-server]}]
  (delete-connect-scripts! builds)
  (auto/autobuild*
   {:builds  builds
    :builder (builder figwheel-server)
    :each-iteration-hook (fn [_ build]
                           (fig/check-for-css-changes figwheel-server))}))

(defn check-autobuild-config [all-builds build-ids figwheel-server]
  (let [builds (config/narrow-builds* all-builds build-ids)]
    (config/check-config figwheel-server builds :print-warning true)))

(defn autobuild-ids [{:keys [all-builds build-ids figwheel-server]}]
  (let [builds (config/narrow-builds* all-builds build-ids)
        errors (config/check-config figwheel-server builds :print-warning true)]
    (if (empty? errors)
      (do
        (println (str "Figwheel: focusing on build-ids ("
                      (string/join " " (map :id builds)) ")"))
        (autobuild* {:builds builds
                     :figwheel-server figwheel-server}))
      (do
        (mapv println errors)
        false))))

(defn autobuild [src-dirs build-options figwheel-options]
  (autobuild* {:builds [{:source-paths src-dirs
                         :build-options build-options}]
               :figwheel-server (fig/start-server figwheel-options)}))

(comment

  (def builds [{ :id "example"
                 :source-paths ["src" "../support/src"]
                 :build-options { :output-to "resources/public/js/compiled/example.js"
                                  :output-dir "resources/public/js/compiled/out"
                                  :source-map true
                                  :cache-analysis true
                                  ;; :reload-non-macro-clj-files false
                                  :optimizations :none}}])

  (def env-builds (map (fn [b] (assoc b :compiler-env
                                      (cljs.env/default-compiler-env
                                        (:compiler b))))
                        builds))

  (def figwheel-server (fig/start-server))

  (fig/stop-server figwheel-server)

  (def bb (autobuild* {:builds env-builds
                       :figwheel-server figwheel-server}))

  (auto/stop-autobuild! bb)

  (fig-repl/eval-js figwheel-server "1 + 1")

  (def build-options (:build-options (first builds)))

  #_(cljs.repl/repl (repl-env figwheel-server) )
)

(ns figwheel-sidecar.auto-builder
  (:require
   [clojure.pprint :as p]
   [figwheel-sidecar.core :as fig]
   [figwheel-sidecar.config :as config]
   [cljs.repl]
   [cljs.analyzer :as ana]
   [cljs.env]
   #_[clj-stacktrace.repl]
   [clojure.stacktrace :as stack]
   [clojurescript-build.core :as cbuild]
   [clojurescript-build.auto :as auto]
   [clojure.java.io :as io]
   [clojure.string :as string]
   [clojure.set :refer [intersection]]
   [cljsbuild.util :as util]))

(defn notify-cljs [command message]
  (when (seq (:shell command))
    (try
      (util/sh (update-in command [:shell] (fn [old] (concat old [message]))))
      (catch Throwable e
        (println (auto/red "Error running :notify-command:"))
        (stack/print-stack-trace e 30)
        (flush)
        #_(clj-stacktrace.repl/pst+ e)))))

(defn notify-on-complete [{:keys [build-options parsed-notify-command]}]
  (let [{:keys [output-to]} build-options]
    (notify-cljs
     parsed-notify-command
     (str "Successfully compiled " output-to))))

(defn merge-build-into-server-state [figwheel-server {:keys [id build-options]}]
  (merge figwheel-server
         (if id {:build-id id} {})
         (select-keys build-options [:output-dir :output-to :recompile-dependents])))

(defn check-changes [figwheel-server build]
  (let [{:keys [additional-changed-ns build-options id old-mtimes new-mtimes]} build]
    (binding [cljs.env/*compiler* (:compiler-env build)]
      (fig/check-for-changes
       (merge-build-into-server-state figwheel-server build)
       old-mtimes
       new-mtimes
       additional-changed-ns))))

(defmulti report-exception (fn [exception cause] (:type cause)))

(defmethod report-exception :reader-exception [e {:keys [file line column]}]
  (println (format "ERROR: %s on file %s, line %d, column %d"
                   (some-> e (.getCause) (.getMessage))
                   file line column)))

(defmethod report-exception :default [e _]
  (stack/print-stack-trace e 30))

(defn handle-exceptions [figwheel-server {:keys [build-options exception id] :as build}]
  (println (auto/red (str "Compiling \"" (:output-to build-options) "\" failed.")))
  (let [cause (ex-data (.getCause exception))]
    (report-exception exception cause)
    (flush)
    #_(clj-stacktrace.repl/pst+ exception)
    (fig/compile-error-occured
      (merge-build-into-server-state figwheel-server build)
      exception
      cause)))

(defn warning [builder warn-handler]
  (fn [build]
    (binding [cljs.analyzer/*cljs-warning-handlers* (conj cljs.analyzer/*cljs-warning-handlers*
                                                          (warn-handler build))]
      (builder build))))

(defn default-build-options [builder default-options]
  (fn [build]
    (builder
     (update-in build [:build-options] (partial merge default-options)))))

;; connection

(defn connect-script-temp-dir [build]
  (assert (:id build) (str "Following build needs an id: " build))
  (str "target/figwheel_temp/" (name (:id build))))

(defn connect-script-path [build]
  (str (connect-script-temp-dir build) "/figwheel/connect.cljs"))

(def figwheel-client-hook-keys [:on-jsload
                                :before-jsload
                                :on-cssload
                                :on-compile-fail
                                :on-compile-fail])

(defn extract-connection-requires [{:keys [figwheel] :as build}]
  (let [names (set
               (map #(symbol (namespace (symbol %)))
                    (vals (select-keys figwheel figwheel-client-hook-keys))))
        ;; if there is a main defined then add it
        main-ns  (get-in build [:build-options :main])
        names (if main-ns
                (conj names (symbol (str main-ns)))
                names)]
    (conj names 'figwheel.client 'figwheel.client.utils)))

(defn extract-connection-script-required-ns [{:keys [figwheel] :as build}]
  (list 'ns 'figwheel.connect
        (cons :require (map vector (extract-connection-requires build)))))

(defn hook-name-to-js [hook-name]
  (symbol
   (str "js/"
        (string/join "." (string/split (str hook-name) #"/")))))

(defn try-jsreload-hook [k hook-name]
  ;; change hook to js form to avoid compile warnings when it doesn't
  ;; exist, these compile warnings are confusing and prevent code loading
  (let [hook-name' (hook-name-to-js hook-name)]
    (list 'fn '[& x]
          (list 'if hook-name'
                (list 'apply hook-name' 'x)
                (list 'figwheel.client.utils/log :debug (str "Figwheel: " k " hook '" hook-name "' is missing"))))))

(defn extract-connection-script-figwheel-start [{:keys [figwheel]}]
  (let [func-map (select-keys figwheel figwheel-client-hook-keys)
        func-map (into {} (map (fn [[k v]] [k (try-jsreload-hook k v)]) func-map))
        res (merge figwheel func-map)]
    (list 'figwheel.client/start res)))

(comment

  (extract-connection-script-required-ns {:figwheel {:on-jsload "blah.blah/on-jsload"}})

  (extract-connection-script-required-ns {:figwheel {}})

  (extract-connection-script-figwheel-start {:figwheel {:on-jsload "blah.blah/on-jsload" :websocket-url "hey"}})

  )

(defn create-connect-script! [build]
  ;;; consider doing this is the system temp dir
  (let [temp-file (io/file (connect-script-path build))]
    (.mkdirs (.getParentFile temp-file))
    (.deleteOnExit temp-file)
    (with-open [file (io/writer temp-file)]
      (binding [*out* file]
        (println
         (apply str (mapcat
                     prn-str
                     (list (extract-connection-script-required-ns build)
                           (extract-connection-script-figwheel-start build)))))))
    temp-file))

(defn create-connect-script-if-needed! [build]
  (when (config/figwheel-build? build)
    (when-not (.exists (io/file (connect-script-path build)))
      (create-connect-script! build))))

(defn add-connect-script! [figwheel-server build]
  (if (config/figwheel-build? build)
    (let [build (config/update-figwheel-connect-options figwheel-server build)]
      (create-connect-script-if-needed! build)
      (update-in build [:source-paths] conj (connect-script-temp-dir build)))
    build))

(defn require-connection-script-js [build]
  (let [node? (and (:target build) (== (:target build) :nodejs))
        main? (get-in build [:build-options :main])]
    (if (and main? (not node?))
      "\ndocument.write(\"<script>if (typeof goog != \\\"undefined\\\") { goog.require(\\\"figwheel.connect\\\"); }</script>\");"
      "\ngoog.require(\"figwheel.connect\");")))

(defn append-connection-init! [build]
  (when (config/figwheel-build? build)
    (when-let [output-to (get-in build [:build-options :output-to])]
      (spit output-to (require-connection-script-js build) :append true))))

(defn insert-figwheel-connect-script [builder figwheel-server]
  (fn [build]
    (let [res (builder (add-connect-script! figwheel-server build))]
      (append-connection-init! build)
      res)))

(defn builder [figwheel-server]
  (-> cbuild/build-source-paths*
    (default-build-options {:recompile-dependents false})
    (insert-figwheel-connect-script figwheel-server)
    (warning
     (fn [build]
       (auto/warning-message-handler
        (partial fig/compile-warning-occured
                 (merge-build-into-server-state figwheel-server build)))))
    auto/time-build
    (auto/after auto/compile-success)
    (auto/after (partial check-changes figwheel-server))
    (auto/after notify-on-complete)
    (auto/error (partial handle-exceptions figwheel-server))
    (auto/before auto/compile-start)))

(defn delete-connect-scripts! [builds]
  (doseq [b builds]
    (when (config/figwheel-build? b)
      (let [f (io/file (connect-script-path b))]
        (when (.exists f) (.delete f))))))

(defn autobuild* [{:keys [builds figwheel-server]}]
  (delete-connect-scripts! builds)
  (auto/autobuild*
   {:builds  builds
    :builder (builder figwheel-server)
    :each-iteration-hook (fn [_ build]
                           (fig/check-for-css-changes figwheel-server))}))

(defn check-autobuild-config [all-builds build-ids figwheel-server]
  (let [builds (config/narrow-builds* all-builds build-ids)]
    (config/check-config figwheel-server builds :print-warning true)))

(defn autobuild-ids [{:keys [all-builds build-ids figwheel-server]}]
  (let [builds (config/narrow-builds* all-builds build-ids)
        errors (config/check-config figwheel-server builds :print-warning true)]
    (if (empty? errors)
      (do
        (println (str "Figwheel: focusing on build-ids ("
                      (string/join " " (map :id builds)) ")"))
        (autobuild* {:builds builds
                     :figwheel-server figwheel-server}))
      (do
        (mapv println errors)
        false))))

(defn autobuild [src-dirs build-options figwheel-options]
  (autobuild* {:builds [{:source-paths src-dirs
                         :build-options build-options}]
               :figwheel-server (fig/start-server figwheel-options)}))

(comment

  (def builds [{ :id "example"
                 :source-paths ["src" "../support/src"]
                 :build-options { :output-to "resources/public/js/compiled/example.js"
                                  :output-dir "resources/public/js/compiled/out"
                                  :source-map true
                                  :cache-analysis true
                                  ;; :reload-non-macro-clj-files false
                                  :optimizations :none}}])

  (def env-builds (map (fn [b] (assoc b :compiler-env
                                      (cljs.env/default-compiler-env
                                        (:compiler b))))
                        builds))

  (def figwheel-server (fig/start-server))

  (fig/stop-server figwheel-server)

  (def bb (autobuild* {:builds env-builds
                       :figwheel-server figwheel-server}))

  (auto/stop-autobuild! bb)

  (fig-repl/eval-js figwheel-server "1 + 1")

  (def build-options (:build-options (first builds)))

  #_(cljs.repl/repl (repl-env figwheel-server) )
)

Add assertion for build id

Add assertion for build id


(ns engulf.core
  (:gen-class)
  (:require [engulf.benchmark :as benchmark]
            [noir.server :as nr-server])
  (:use aleph.http
        noir.core
        lamina.core))

(defn start-webserver [args]
  (nr-server/load-views "src/engulf/views")

  (let [mode (keyword (or (first args) :dev))
          port (Integer. (get (System/getenv) "PORT" "3000"))
          noir-handler (nr-server/gen-handler {:mode mode})]
      (start-http-server
        (wrap-ring-handler noir-handler)
        {:port port :websocket true})))

(defn -main [& args]
  (start-webserver args)
  (println "Engulf Started!"))

(ns engulf.core
  (:gen-class)
  (:require [engulf.benchmark :as benchmark]
            [noir.server :as nr-server])
  (:use aleph.http
        noir.core
        lamina.core))

(defn start-webserver [args]
  (nr-server/load-views "src/engulf/views")

  (let [mode (keyword (or (first args) :prod))
          port (Integer. (get (System/getenv) "PORT" "3000"))
          noir-handler (nr-server/gen-handler {:mode mode})]
      (start-http-server
        (wrap-ring-handler noir-handler)
        {:port port :websocket true})))

(defn -main [& args]
  (start-webserver args)
  (println "Engulf Started!"))

Make prod mode the default for noir

Make prod mode the default for noir


(ns asciinema-player.core
  (:require [reagent.core :as reagent :refer [atom]]
            [asciinema-player.view :as view]
            [asciinema-player.util :as util]
            [cljs.core.async :refer [chan >! <! timeout close!]]
            [clojure.walk :as walk]
            [clojure.set :refer [rename-keys]]
            [ajax.core :refer [GET]])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

(defn make-player-state
  "Returns Reagent atom with fresh player state."
  [width height frames-url duration {:keys [speed snapshot auto-play loop font-size theme] :or {speed 1 snapshot [] auto-play false loop false font-size "small" theme "seti"}}]
  (atom {
         :width width
         :height height
         :duration duration
         :frames-url frames-url
         :font-size font-size
         :theme theme
         :lines (into (sorted-map) (map-indexed vector snapshot))
         :cursor {:on true}
         :play-from 0
         :current-time 0
         :autoplay auto-play
         :loop loop
         :speed speed}))

(defn elapsed-time-since
  "Returns wall time (in seconds) elapsed since then."
  [then]
  (/ (- (.getTime (js/Date.)) (.getTime then)) 1000))

(defn apply-diff
  "Applies given diff (line content and cursor position changes) to player's
  state."
  [state {:keys [lines cursor]}]
  (merge-with merge state {:lines lines :cursor cursor}))

(defn coll->chan
  "Returns a channel that emits frames from the given collection.
  The difference from core.async/to-chan is this function expects elements of
  the collection to be tuples of [delay data], and it emits data after delay
  (sec) for each element. It tries to always stay 'on the schedule' by measuring
  elapsed time and skipping elements if necessary. When reducer and init given
  it reduces consecutive elements instead of skipping."
  ([coll] (coll->chan coll (fn [_ v] v) nil))
  ([coll reducer init]
   (let [ch (chan)
         start (js/Date.)
         reducer (fnil reducer init)]
     (go
       (loop [coll coll
              virtual-time 0
              wall-time (elapsed-time-since start)
              acc nil]
         (if-let [[delay data] (first coll)]
           (let [new-virtual-time (+ virtual-time delay)
                 ahead (- new-virtual-time wall-time)]
             (if (pos? ahead)
               (do
                 (when-not (nil? acc)
                   (>! ch acc))
                 (<! (timeout (* 1000 ahead)))
                 (>! ch data)
                 (recur (rest coll) new-virtual-time (elapsed-time-since start) nil))
               (recur (rest coll) new-virtual-time wall-time (reducer acc data)))))
         (when-not (nil? acc)
           (>! ch acc)))
       (close! ch))
     ch)))

(defn prev-diff
  "Returns a combined diff from frames up to (and including) given time (in
  seconds)."
  [frames seconds]
  (loop [frames frames
         seconds seconds
         candidate nil]
    (let [[delay diff :as frame] (first frames)]
      (if (or (nil? frame) (< seconds delay))
        candidate
        (recur (rest frames) (- seconds delay) (merge-with merge candidate diff))))))

(defn next-frames
  "Returns a lazy sequence of frames starting from given time (in seconds)."
  [frames seconds]
  (lazy-seq
    (if (seq frames)
      (let [[delay diff] (first frames)]
        (if (<= delay seconds)
          (next-frames (rest frames) (- seconds delay))
          (cons [(- delay seconds) diff] (rest frames))))
      frames)))

(defn reset-blink
  "Makes cursor 'block' visible."
  [state]
  (assoc-in state [:cursor :on] true))

(defn make-cursor-blink-chan
  "Returns a channel emitting true/false/true/false/... in 0.5 sec periods."
  []
  (coll->chan (cycle [[0.5 false] [0.5 true]])))

(defn frames-at-speed [frames speed]
  (map (fn [[delay diff]] [(/ delay speed) diff]) frames))

(defn start-playback
  "The heart of the player. Coordinates dispatching of state update events like
  terminal line updating, time reporting and cursor blinking.
  Returns function which stops the playback and returns time of the playback."
  [state dispatch]
  (let [start (js/Date.)
        play-from (:play-from state)
        speed (:speed state)
        frames (-> (:frames state) (next-frames play-from) (frames-at-speed speed))
        diff-chan (coll->chan frames (partial merge-with merge) {})
        timer-chan (coll->chan (repeat [0.3 true]))
        stop-playback-chan (chan)
        elapsed-time #(* (elapsed-time-since start) speed)
        stop-fn (fn []
                  (close! stop-playback-chan)
                  (elapsed-time))]
    (go
      (loop [cursor-blink-chan (make-cursor-blink-chan)]
        (let [[v c] (alts! [diff-chan timer-chan cursor-blink-chan stop-playback-chan])]
          (condp = c
            timer-chan (let [t (+ play-from (elapsed-time))]
                         (dispatch [:update-state assoc :current-time t])
                         (recur cursor-blink-chan))
            cursor-blink-chan (do
                                (dispatch [:update-state assoc-in [:cursor :on] v])
                                (recur cursor-blink-chan))
            diff-chan (if v
                        (do
                          (dispatch [:update-state #(-> % (apply-diff v) reset-blink)])
                          (recur (make-cursor-blink-chan)))
                        (do
                          (dispatch [:finished])
                          (print (str "finished in " (elapsed-time-since start)))))
            stop-playback-chan nil))) ; do nothing, break the loop
      (dispatch [:update-state reset-blink]))
    (-> state
        (apply-diff (prev-diff (:frames state) play-from))
        (assoc :stop stop-fn))))

(defn stop-playback
  "Stops the playback and returns updated state with new start position."
  [state]
  (let [t ((:stop state))]
    (-> state
        (dissoc :stop)
        (update-in [:play-from] + t))))

(defn fetch-frames
  "Fetches frames, setting :loading to true at the start,
  dispatching :frames-response event on success, :bad-response event on
  failure."
  [state dispatch]
  (let [url (:frames-url state)]
    (GET
     url
     {:response-format :raw
      :handler #(dispatch [:frames-response %])
      :error-handler #(dispatch [:bad-response %])})
    (assoc state :loading true)))

(defn new-position
  "Returns time adjusted by given offset, clipped to the range 0..total-time."
  [current-time total-time offset]
  (/ (util/adjust-to-range (+ current-time offset) 0 total-time) total-time))

(defn handle-toggle-play
  "Toggles the playback. Fetches frames if they were not loaded yet."
  [state dispatch]
  (if (contains? state :frames)
    (if (contains? state :stop)
      (stop-playback state)
      (start-playback state dispatch))
    (fetch-frames state dispatch)))

(defn handle-seek
  "Jumps to a given position (in seconds)."
  [state dispatch [position]]
  (let [new-time (* position (:duration state))
        diff (prev-diff (:frames state) new-time)
        playing? (contains? state :stop)]
    (when playing?
      ((:stop state)))
    (let [new-state (-> state
                        (assoc :current-time new-time :play-from new-time)
                        (apply-diff diff))]
      (if playing?
        (start-playback new-state dispatch)
        new-state))))

(defn handle-rewind
  "Rewinds the playback by 5 seconds."
  [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) -5)]
    (handle-seek state dispatch [position])))

(defn handle-fast-forward
  "Fast-forwards the playback by 5 seconds."
  [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) 5)]
    (handle-seek state dispatch [position])))

(defn handle-finished
  "Prepares player to be ready for playback from the beginning. Starts the
  playback immediately when loop option is true."
  [state dispatch]
  (when (:loop state)
    (dispatch [:toggle-play]))
  (-> state
      (dissoc :stop)
      (assoc :play-from 0)
      (assoc :current-time (:duration state))))

(defn speed-up [speed]
  (* speed 2))

(defn speed-down [speed]
  (/ speed 2))

(defn handle-speed-change
  "Alters the speed of the playback by applying change-fn to the current speed."
  [change-fn state dispatch]
  (if-let [stop (:stop state)]
    (let [t (stop)]
      (-> state
          (update-in [:play-from] + t)
          (update-in [:speed] change-fn)
          (start-playback dispatch)))
    (update-in state [:speed] change-fn)))

(defn- fix-line-diff-keys [line-diff]
  (into {} (map (fn [[k v]] [(js/parseInt (name k) 10) v]) line-diff)))

(defn fix-frames
  "Converts integer keys referring to line numbers in line diff (which are
  keywords) to actual integers."
  [frames]
  (map #(update-in % [1 :lines] fix-line-diff-keys) frames))

(defn handle-frames-response
  "Merges frames into player state, hides loading indicator and starts the
  playback."
  [state dispatch [json]]
  (dispatch [:toggle-play])
  (let [frames (-> json
                   js/JSON.parse
                   (util/faster-js->clj :keywordize-keys true)
                   fix-frames)]
    (assoc state :loading false :frames frames)))

(defn handle-update-state
  "Applies given function (with args) to the player state."
  [state _ [f & args]]
  (apply f state args))

(def event-handlers {:toggle-play handle-toggle-play
                     :seek handle-seek
                     :rewind handle-rewind
                     :fast-forward handle-fast-forward
                     :finished handle-finished
                     :speed-up (partial handle-speed-change speed-up)
                     :speed-down (partial handle-speed-change speed-down)
                     :frames-response handle-frames-response
                     :update-state handle-update-state})

(defn process-event
  "Finds handler for the given event and applies it to the player state."
  [state dispatch [event-name & args]]
  (if-let [handler (get event-handlers event-name)]
    (swap! state handler dispatch args)
    (print (str "unhandled event: " event-name))))

(defn create-player-with-state
  "Creates the player with given state by starting event processing loop and
  mounting Reagent component in DOM."
  [state dom-node]
  (let [events (chan)
        dispatch (fn [event] (go (>! events event)))]
    (go-loop []
      (when-let [event (<! events)]
        (process-event state dispatch event)
        (recur)))
    (reagent/render-component [view/player state dispatch] dom-node)
    (when (:autoplay @state)
      (dispatch [:toggle-play]))
    (clj->js {:toggle (fn [] true)})))

(defn create-player
  "Creates the player with the state built from given options by starting event
  processing loop and mounting Reagent component in DOM."
  [dom-node width height frames-url duration options]
  (let [dom-node (if (string? dom-node) (.getElementById js/document dom-node) dom-node)
        state (make-player-state width height frames-url duration options)]
    (create-player-with-state state dom-node)))

(defn ^:export CreatePlayer
  "JavaScript API for creating the player, delegating to create-player."
  [dom-node width height frames-url duration options]
  (let [options (-> options
                    (js->clj :keywordize-keys true)
                    (rename-keys {:autoPlay :auto-play :fontSize :font-size}))]
    (create-player dom-node width height frames-url duration options)))

(enable-console-print!)

(ns asciinema-player.core
  (:require [reagent.core :as reagent :refer [atom]]
            [asciinema-player.view :as view]
            [asciinema-player.util :as util]
            [cljs.core.async :refer [chan >! <! timeout close!]]
            [clojure.walk :as walk]
            [clojure.set :refer [rename-keys]]
            [ajax.core :refer [GET]])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

(defn make-player-state
  "Returns Reagent atom with fresh player state."
  [width height frames-url duration {:keys [speed snapshot auto-play loop font-size theme] :or {speed 1 snapshot [] auto-play false loop false font-size "small" theme "seti"}}]
  (atom {
         :width width
         :height height
         :duration duration
         :frames-url frames-url
         :font-size font-size
         :theme theme
         :lines (into (sorted-map) (map-indexed vector snapshot))
         :cursor {:on true}
         :play-from 0
         :current-time 0
         :autoplay auto-play
         :loop loop
         :speed speed}))

(defn elapsed-time-since
  "Returns wall time (in seconds) elapsed since then."
  [then]
  (/ (- (.getTime (js/Date.)) (.getTime then)) 1000))

(defn apply-diff
  "Applies given diff (line content and cursor position changes) to player's
  state."
  [state {:keys [lines cursor]}]
  (merge-with merge state {:lines lines :cursor cursor}))

(defn coll->chan
  "Returns a channel that emits frames from the given collection.
  The difference from core.async/to-chan is this function expects elements of
  the collection to be tuples of [delay data], and it emits data after delay
  (sec) for each element. It tries to always stay 'on the schedule' by measuring
  elapsed time and skipping elements if necessary. When reducer and init given
  it reduces consecutive elements instead of skipping."
  ([coll] (coll->chan coll (fn [_ v] v) nil))
  ([coll reducer init]
   (let [ch (chan)
         start (js/Date.)
         reducer (fnil reducer init)]
     (go
       (loop [coll coll
              virtual-time 0
              wall-time (elapsed-time-since start)
              acc nil]
         (if-let [[delay data] (first coll)]
           (let [new-virtual-time (+ virtual-time delay)
                 ahead (- new-virtual-time wall-time)]
             (if (pos? ahead)
               (do
                 (when-not (nil? acc)
                   (>! ch acc))
                 (<! (timeout (* 1000 ahead)))
                 (>! ch data)
                 (recur (rest coll) new-virtual-time (elapsed-time-since start) nil))
               (recur (rest coll) new-virtual-time wall-time (reducer acc data)))))
         (when-not (nil? acc)
           (>! ch acc)))
       (close! ch))
     ch)))

(defn prev-diff
  "Returns a combined diff from frames up to (and including) given time (in
  seconds)."
  [frames seconds]
  (loop [frames frames
         seconds seconds
         candidate nil]
    (let [[delay diff :as frame] (first frames)]
      (if (or (nil? frame) (< seconds delay))
        candidate
        (recur (rest frames) (- seconds delay) (merge-with merge candidate diff))))))

(defn next-frames
  "Returns a lazy sequence of frames starting from given time (in seconds)."
  [frames seconds]
  (lazy-seq
    (if (seq frames)
      (let [[delay diff] (first frames)]
        (if (<= delay seconds)
          (next-frames (rest frames) (- seconds delay))
          (cons [(- delay seconds) diff] (rest frames))))
      frames)))

(defn reset-blink
  "Makes cursor 'block' visible."
  [state]
  (assoc-in state [:cursor :on] true))

(defn make-cursor-blink-chan
  "Returns a channel emitting true/false/true/false/... in 0.5 sec periods."
  []
  (coll->chan (cycle [[0.5 false] [0.5 true]])))

(defn frames-at-speed [frames speed]
  (map (fn [[delay diff]] [(/ delay speed) diff]) frames))

(defn start-playback
  "The heart of the player. Coordinates dispatching of state update events like
  terminal line updating, time reporting and cursor blinking.
  Returns function which stops the playback and returns time of the playback."
  [state dispatch]
  (let [start (js/Date.)
        play-from (:play-from state)
        speed (:speed state)
        frames (-> (:frames state) (next-frames play-from) (frames-at-speed speed))
        diff-chan (coll->chan frames (partial merge-with merge) {})
        timer-chan (coll->chan (repeat [0.3 true]))
        stop-playback-chan (chan)
        elapsed-time #(* (elapsed-time-since start) speed)
        stop-fn (fn []
                  (close! stop-playback-chan)
                  (elapsed-time))]
    (go
      (loop [cursor-blink-chan (make-cursor-blink-chan)]
        (let [[v c] (alts! [diff-chan timer-chan cursor-blink-chan stop-playback-chan])]
          (condp = c
            timer-chan (let [t (+ play-from (elapsed-time))]
                         (dispatch [:update-state assoc :current-time t])
                         (recur cursor-blink-chan))
            cursor-blink-chan (do
                                (dispatch [:update-state assoc-in [:cursor :on] v])
                                (recur cursor-blink-chan))
            diff-chan (if v
                        (do
                          (dispatch [:update-state #(-> % (apply-diff v) reset-blink)])
                          (recur (make-cursor-blink-chan)))
                        (do
                          (dispatch [:finished])
                          (print (str "finished in " (elapsed-time-since start)))))
            stop-playback-chan nil))) ; do nothing, break the loop
      (dispatch [:update-state reset-blink]))
    (-> state
        (apply-diff (prev-diff (:frames state) play-from))
        (assoc :stop stop-fn))))

(defn stop-playback
  "Stops the playback and returns updated state with new start position."
  [state]
  (let [t ((:stop state))]
    (-> state
        (dissoc :stop)
        (update-in [:play-from] + t))))

(defn fetch-frames
  "Fetches frames, setting :loading to true at the start,
  dispatching :frames-response event on success, :bad-response event on
  failure."
  [state dispatch]
  (let [url (:frames-url state)]
    (GET
     url
     {:response-format :raw
      :handler #(dispatch [:frames-response %])
      :error-handler #(dispatch [:bad-response %])})
    (assoc state :loading true)))

(defn new-position
  "Returns time adjusted by given offset, clipped to the range 0..total-time."
  [current-time total-time offset]
  (/ (util/adjust-to-range (+ current-time offset) 0 total-time) total-time))

(defn handle-toggle-play
  "Toggles the playback. Fetches frames if they were not loaded yet."
  [state dispatch]
  (if (contains? state :frames)
    (if (contains? state :stop)
      (stop-playback state)
      (start-playback state dispatch))
    (fetch-frames state dispatch)))

(defn handle-seek
  "Jumps to a given position (in seconds)."
  [state dispatch [position]]
  (let [new-time (* position (:duration state))
        diff (prev-diff (:frames state) new-time)
        playing? (contains? state :stop)]
    (when playing?
      ((:stop state)))
    (let [new-state (-> state
                        (assoc :current-time new-time :play-from new-time)
                        (apply-diff diff))]
      (if playing?
        (start-playback new-state dispatch)
        new-state))))

(defn handle-rewind
  "Rewinds the playback by 5 seconds."
  [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) -5)]
    (handle-seek state dispatch [position])))

(defn handle-fast-forward
  "Fast-forwards the playback by 5 seconds."
  [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) 5)]
    (handle-seek state dispatch [position])))

(defn handle-finished
  "Prepares player to be ready for playback from the beginning. Starts the
  playback immediately when loop option is true."
  [state dispatch]
  (when (:loop state)
    (dispatch [:toggle-play]))
  (-> state
      (dissoc :stop)
      (assoc :play-from 0)
      (assoc :current-time (:duration state))))

(defn speed-up [speed]
  (* speed 2))

(defn speed-down [speed]
  (/ speed 2))

(defn handle-speed-change
  "Alters the speed of the playback by applying change-fn to the current speed."
  [change-fn state dispatch]
  (if-let [stop (:stop state)]
    (let [t (stop)]
      (-> state
          (update-in [:play-from] + t)
          (update-in [:speed] change-fn)
          (start-playback dispatch)))
    (update-in state [:speed] change-fn)))

(defn- fix-line-diff-keys [line-diff]
  (into {} (map (fn [[k v]] [(js/parseInt (name k) 10) v]) line-diff)))

(defn fix-frames
  "Converts integer keys referring to line numbers in line diff (which are
  keywords) to actual integers."
  [frames]
  (map #(update-in % [1 :lines] fix-line-diff-keys) frames))

(defn handle-frames-response
  "Merges frames into player state, hides loading indicator and starts the
  playback."
  [state dispatch [json]]
  (dispatch [:toggle-play])
  (let [frames (-> json
                   js/JSON.parse
                   (util/faster-js->clj :keywordize-keys true)
                   fix-frames)]
    (assoc state :loading false :frames frames)))

(defn handle-update-state
  "Applies given function (with args) to the player state."
  [state _ [f & args]]
  (apply f state args))

(def event-handlers {:toggle-play handle-toggle-play
                     :seek handle-seek
                     :rewind handle-rewind
                     :fast-forward handle-fast-forward
                     :finished handle-finished
                     :speed-up (partial handle-speed-change speed-up)
                     :speed-down (partial handle-speed-change speed-down)
                     :frames-response handle-frames-response
                     :update-state handle-update-state})

(defn process-event
  "Finds handler for the given event and applies it to the player state."
  [state dispatch [event-name & args]]
  (if-let [handler (get event-handlers event-name)]
    (swap! state handler dispatch args)
    (print (str "unhandled event: " event-name))))

(defn create-player-with-state
  "Creates the player with given state by starting event processing loop and
  mounting Reagent component in DOM."
  [state dom-node]
  (let [events (chan)
        dispatch (fn [event] (go (>! events event)))]
    (go-loop []
      (when-let [event (<! events)]
        (process-event state dispatch event)
        (recur)))
    (reagent/render-component [view/player state dispatch] dom-node)
    (when (:autoplay @state)
      (dispatch [:toggle-play]))
    (clj->js {:toggle (fn [] true)})))

(defn create-player
  "Creates the player with the state built from given options by starting event
  processing loop and mounting Reagent component in DOM."
  [dom-node width height frames-url duration options]
  (let [dom-node (if (string? dom-node) (.getElementById js/document dom-node) dom-node)
        state (make-player-state width height frames-url duration options)]
    (create-player-with-state state dom-node)))

(defn ^:export CreatePlayer
  "JavaScript API for creating the player, delegating to create-player."
  ([dom-node width height frames-url duration] (CreatePlayer dom-node width height frames-url duration {}))
  ([dom-node width height frames-url duration options]
   (let [options (-> options
                     (js->clj :keywordize-keys true)
                     (rename-keys {:autoPlay :auto-play :fontSize :font-size}))]
     (create-player dom-node width height frames-url duration options))))

(enable-console-print!)

Make options argument optional

Make options argument optional