(ns leiningen.new
  "Create a new project skeleton.
lein new [group-id/]artifact-id [project-dir]
Group-id is optional. Project-dir defaults to artifact-id if not given.
Neither group-id nor artifact-id may contain slashes."
  (:use [leiningen.core :only [ns->path]]
        [clojure.java.io :only [file]]
        [clojure.contrib.string :only [join]]))

(defn write-project [project-dir project-name]
  (.mkdirs (file project-dir))
  (spit (file project-dir "project.clj")
        (str "(defproject " project-name " \"1.0.0-SNAPSHOT\"\n"
             "  :description \"FIXME: write\"\n"
             "  :dependencies [[org.clojure/clojure \"1.2.0-beta1\"]\n  "
             "               [org.clojure/clojure-contrib \"1.2.0-beta1\"]])")))

(defn write-implementation [project-dir project-clj project-ns]
  (.mkdirs (.getParentFile (file project-dir "src" project-clj)))
  (spit (file project-dir "src" project-clj)
        (str "(ns " project-ns ")\n")))

(defn write-test [project-dir test-ns project-ns]
  (.mkdirs (.getParentFile (file project-dir "test" (ns->path test-ns))))
  (spit (file project-dir "test" (ns->path test-ns))
        (str "(ns " (str test-ns)
             "\n  (:use [" project-ns "] :reload-all)"
             "\n  (:use [clojure.test]))\n\n"
             "(deftest replace-me ;; FIXME: write\n  (is false "
             "\"No tests have been written.\"))\n")))

(defn write-readme [project-dir artifact-id]
  (spit (file project-dir "README")
        (join "\n\n" [(str "# " artifact-id)
                      "FIXME: write description"
                      "## Usage" "FIXME: write"
                      "## Installation" "FIXME: write"
                      "## License" "Copyright (C) 2010 FIXME"
                      (str "Distributed under the Eclipse Public"
                           " License, the same as Clojure.\n")])))

(defn new
  "Create a new project skeleton.
lein new [group-id/]artifact-id [project-dir]
Group-id is optional. Project-dir defaults to artifact-id if not given.
Neither group-id nor artifact-id may contain slashes."
  ([project-name project-dir]
     (when (re-find #"(?<!clo)jure" project-name)
       (throw (IllegalArgumentException. "*jure names are no longer allowed.")))
     (let [project-name (symbol project-name)
           group-id (namespace project-name)
           artifact-id (name project-name)]
       (write-project project-dir project-name)
       (let [prefix (.replace (str project-name) "/" ".")
             project-ns (str prefix ".core")
             test-ns (str prefix ".test.core")
             project-clj (ns->path project-ns)]
         (spit (file project-dir ".gitignore")
               (join "\n" ["pom.xml" "*jar" "lib" "classes"]))
         (write-implementation project-dir project-clj project-ns)
         (write-test project-dir test-ns project-ns)
         (write-readme project-dir artifact-id)
         (println "Created new project in:" project-dir))))
  ([project-name] (leiningen.new/new project-name
                                     (name (symbol project-name)))))

(ns leiningen.new
  "Create a new project skeleton.
lein new [group-id/]artifact-id [project-dir]
Group-id is optional. Project-dir defaults to artifact-id if not given.
Neither group-id nor artifact-id may contain slashes."
  (:use [leiningen.core :only [ns->path]]
        [clojure.java.io :only [file]]
        [clojure.contrib.string :only [join]]))

(defn write-project [project-dir project-name]
  (.mkdirs (file project-dir))
  (spit (file project-dir "project.clj")
        (str "(defproject " project-name " \"1.0.0-SNAPSHOT\"\n"
             "  :description \"FIXME: write\"\n"
             "  :dependencies [[org.clojure/clojure \"1.2.0-beta1\"]\n  "
             "               [org.clojure/clojure-contrib \"1.2.0-beta1\"]])")))

(defn write-implementation [project-dir project-clj project-ns]
  (.mkdirs (.getParentFile (file project-dir "src" project-clj)))
  (spit (file project-dir "src" project-clj)
        (str "(ns " project-ns ")\n")))

(defn write-test [project-dir test-ns project-ns]
  (.mkdirs (.getParentFile (file project-dir "test" (ns->path test-ns))))
  (spit (file project-dir "test" (ns->path test-ns))
        (str "(ns " (str test-ns)
             "\n  (:use [" project-ns "] :reload)"
             "\n  (:use [clojure.test]))\n\n"
             "(deftest replace-me ;; FIXME: write\n  (is false "
             "\"No tests have been written.\"))\n")))

(defn write-readme [project-dir artifact-id]
  (spit (file project-dir "README")
        (join "\n\n" [(str "# " artifact-id)
                      "FIXME: write description"
                      "## Usage" "FIXME: write"
                      "## Installation" "FIXME: write"
                      "## License" "Copyright (C) 2010 FIXME"
                      (str "Distributed under the Eclipse Public"
                           " License, the same as Clojure.\n")])))

(defn new
  "Create a new project skeleton.
lein new [group-id/]artifact-id [project-dir]
Group-id is optional. Project-dir defaults to artifact-id if not given.
Neither group-id nor artifact-id may contain slashes."
  ([project-name project-dir]
     (when (re-find #"(?<!clo)jure" project-name)
       (throw (IllegalArgumentException. "*jure names are no longer allowed.")))
     (let [project-name (symbol project-name)
           group-id (namespace project-name)
           artifact-id (name project-name)]
       (write-project project-dir project-name)
       (let [prefix (.replace (str project-name) "/" ".")
             project-ns (str prefix ".core")
             test-ns (str prefix ".test.core")
             project-clj (ns->path project-ns)]
         (spit (file project-dir ".gitignore")
               (join "\n" ["pom.xml" "*jar" "lib" "classes"]))
         (write-implementation project-dir project-clj project-ns)
         (write-test project-dir test-ns project-ns)
         (write-readme project-dir artifact-id)
         (println "Created new project in:" project-dir))))
  ([project-name] (leiningen.new/new project-name
                                     (name (symbol project-name)))))

Use :reload instead of :reload-all in test skeleton.


(ns name-bazaar.ui.core
  (:require
    [cljs-time.extend]
    [cljs.spec.alpha :as s]
    [cljsjs.web3]
    [district0x.ui.events]
    [district0x.ui.history :as history]
    [district0x.ui.subs]
    [district0x.ui.utils :as d0x-ui-utils]
    [district0x.ui.logging :as d0x-logging]
    [madvas.re-frame.google-analytics-fx :as google-analytics-fx]
    [name-bazaar.ui.components.main-panel :refer [main-panel]]
    [name-bazaar.ui.constants :as constants]
    [name-bazaar.ui.db :as ui-db]
    [name-bazaar.ui.events]
    [name-bazaar.ui.subs]
    [print.foo :include-macros true]
    [re-frame.core :refer [dispatch dispatch-sync clear-subscription-cache!]]
    [re-frisk.core :refer [enable-re-frisk!]]
    [reagent.core :as r]))

(def debug?
  ^boolean js/goog.DEBUG)

(defn dev-setup []
  (when debug?
    (enable-console-print!)
    (d0x-logging/setup! ui-db/log-level)
    (enable-re-frisk!)))

(defn mount-root []
  (google-analytics-fx/set-enabled! (not debug?))
  (clear-subscription-cache!)
  (r/render [main-panel] (.getElementById js/document "app")))

(defn ^:export init []
  (s/check-asserts goog.DEBUG)
  (dev-setup)
  (google-analytics-fx/set-enabled! (not debug?))
  (if history/hashroutes?
    (set! (.-onhashchange js/window)
          #(dispatch [:district0x/set-active-page (d0x-ui-utils/match-current-location constants/routes)]))
     (history/start! constants/routes))
  (dispatch-sync [:district0x/initialize
                  {:default-db name-bazaar.ui.db/default-db
                   :effects
                   {:async-flow {:first-dispatch [:district0x/load-smart-contracts {:version constants/contracts-version}]
                                 :rules [{:when :seen?
                                          :events [:district0x/smart-contracts-loaded :district0x/my-addresses-loaded]
                                          :dispatch-n [[:district0x/watch-my-eth-balances]
                                                       [:try-resolving-address]
                                                       [:active-page-changed]]}]}
                    :forward-events {:register :active-page-changed
                                     :events #{:district0x/set-active-page}
                                     :dispatch-to [:active-page-changed]}
                    :dispatch-n [[:setup-update-now-interval]
                                 [:district0x/load-conversion-rates [:USD]]
                                  [:district0x.config/load]]}}])
  (mount-root))

(ns name-bazaar.ui.core
  (:require
    [cljs-time.extend]
    [cljs.spec.alpha :as s]
    [cljsjs.web3]
    [district0x.ui.events]
    [district0x.ui.history :as history]
    [district0x.ui.subs]
    [district0x.ui.utils :as d0x-ui-utils]
    [district0x.ui.logging :as d0x-logging]
    [madvas.re-frame.google-analytics-fx :as google-analytics-fx]
    [name-bazaar.ui.components.main-panel :refer [main-panel]]
    [name-bazaar.ui.constants :as constants]
    [name-bazaar.ui.db :as ui-db]
    [name-bazaar.ui.events]
    [name-bazaar.ui.subs]
    [print.foo :include-macros true]
    [re-frame.core :refer [dispatch dispatch-sync clear-subscription-cache!]]
    [re-frisk.core :refer [enable-re-frisk!]]
    [reagent.core :as r]))

(def debug?
  ^boolean js/goog.DEBUG)

(defn dev-setup []
  (when debug?
    (enable-console-print!)
    (d0x-logging/setup! ui-db/log-level)
    (enable-re-frisk!)))

(defn mount-root []
  (google-analytics-fx/set-enabled! (not debug?))
  (clear-subscription-cache!)
  (r/render [main-panel] (.getElementById js/document "app")))

(defn ^:export init []
  (s/check-asserts goog.DEBUG)
  (dev-setup)
  (google-analytics-fx/set-enabled! (not debug?))
  (if history/hashroutes?
    (set! (.-onhashchange js/window)
          #(dispatch [:district0x/set-active-page (d0x-ui-utils/match-current-location constants/routes)]))
     (history/start! constants/routes))
  (dispatch-sync [:district0x/initialize
                  {:default-db name-bazaar.ui.db/default-db
                   :effects
                   {:async-flow {:first-dispatch [:district0x/load-smart-contracts {:version constants/contracts-version}]
                                 :rules [{:when :seen?
                                          :events [:district0x/smart-contracts-loaded :district0x/my-addresses-loaded]
                                          :dispatch-n [[:district0x/watch-my-eth-balances]
                                                       [:try-resolving-address]
                                                       [:active-page-changed]]}]}
                    :forward-events {:register :active-page-changed
                                     :events #{:district0x/set-active-page}
                                     :dispatch-to [:active-page-changed]}
                    :dispatch-n [[:setup-update-now-interval]
                                 [:district0x/load-conversion-rates [:USD]]
                                 [:district0x.config/load]
                                 [:offerings.total-count/load]]}}])
  (mount-root))

test request sooner for prerenderer

test request sooner for prerenderer


(ns longshi.core
  "Public API for the Fressian port of ClojureScript"
  (:refer-clojure :exclude (read))
  (:require [longshi.fressian.byte-stream-protocols :as bsp]
            [longshi.fressian.protocols :as p]
            [longshi.fressian.handlers :as fh]
            [longshi.fressian.byte-stream :as bs]
            [longshi.fressian.js :as bjs]))
;;Fressian Writer protocol namespace aliasing
(def write-footer p/write-footer!)
(def write-object p/write-object!)
(def write-tag p/write-tag!)
(def write-list p/write-list!)
(def write-boolean p/write-boolean!)
(def write-null p/write-null!)
(def write-int p/write-int!)
(def write-long p/write-long!)
(def write-float p/write-float!)
(def write-double p/write-double!)
(def write-bytes p/write-bytes!)
;;Fressian Reader protocol namespace aliasing
(def read-boolean p/read-boolean!)
(def read-int p/read-int!)
(def read-float p/read-float!)
(def read-double p/read-int!)
(def read-object p/read-object!)
;;Fressian Streaming protocol namespace aliasing
(def begin-open-list p/begin-open-list!)
(def begin-closed-list p/begin-closed-list!)
(def end-list p/end-list!)
;;Fressian Caching namespace aliasing
(def cache bjs/cache)
;;Fressian Tagged namespace aliasing
(def tagged-object fh/tagged-object)
(def tagged-array fh/tagged-array)

(defn write-record
  "Generic writer for ClojureScript Records

  writer (FressianWriter) - Fressian Writer for the record
  name (string) - Fressian name for the record
  record (object) - ClojureScript record to be written

  Currently the ClojureScript port of Fressian can't get the type name
  of ClojureScript records so the name of the record has to be passed in"
  [writer name record]
  (write-tag writer "record" 2)
  (write-object writer name true)
  (write-tag writer "map" 1)
  (begin-closed-list writer)
  (reduce-kv
    (fn [writer k v]
      (write-object writer k true)
      (write-object writer v))
    writer
    record)
  (end-list writer))

(defn map-write-handler [writer cljs-map]
  "Writes out a ClojureScript map to fressian

  writer (FressianWriter) - Fressian Writer for the record
  cljs-map (IMap) - ClojureScript map to be written

  Freesian maps are written internally as one list of alternating keys
  and values.  This method flattens the ClojureScript map sequence of key value
  pairs to a single list."
  (let [map-list (make-array (* 2 (count cljs-map)))]
    (do
      (write-tag writer "map" 1)
      (loop [map-seq (seq cljs-map) i 0]
        (if (empty? map-seq)
          map-list
          (let [[k v] (first map-seq)]
            (do
              (aset map-list i k)
              (aset map-list (inc i) v)
              (recur (rest map-seq) (+ i 2))))))
      (write-list writer map-list))))

(defn seq-write-handler [writer name cljs-seq]
  "Writes out a purely sequential ClojureScript type

  writer (FressianWriter) - Fressian Writer for the record
  cljs-seq (ISeq) - ClojureScript sequence to be written"
  (do
    (write-tag writer name 1)
    (write-list writer cljs-seq)))
;;ClojureScript base writers
(def clojure-write-handlers
  {Keyword
   {"key"
    (fn [writer k]
      (do
        (write-tag writer "key" 2)
        (write-object writer (namespace k) true)
        (write-object writer (name k) true)))}

   Symbol
   {"sym"
    (fn [writer k]
      (do
        (write-tag writer "sym" 2)
        (write-object writer (namespace k) true)
        (write-object writer (name k) true)))}

   PersistentHashMap
   {"map" map-write-handler}

   PersistentArrayMap
   {"map" map-write-handler}

   PersistentHashSet
   {"set"
    (fn [writer s]
      (seq-write-handler writer "set" s))}

   PersistentVector
   {"vector"
    (fn [writer v]
      (seq-write-handler writer "vector" v))}})

(defn create-writer [& {:keys [handlers]}]
  "Creates a fressian writer

   Optional parameters;
     handlers (ILookup) - Lookup table for finding the appropiate handler for a given
                          type"
  (let [write-handlers (or handlers clojure-write-handlers)
        handler-seq (mapv (fn [[k v]] (into [k] (first v))) write-handlers)]
    (bs/byte-output-stream 32 (fh/create-handler handler-seq))))
(defn write
  "Convience function to write out a single object

  obj (object) - object to be wriiten out
  options (ILookup) - Optional paramters
    footer? (boolean) - Write out a footer after the object is written"
  [obj & options]
  (let [{:keys [footer?]} (when options (apply hash-map options))
        writer (apply create-writer options)]
    (do
      (write-object writer obj)
      (when footer?
        (write-footer writer))
      writer)))
;;ClojureScript base readers
(def clojure-read-handlers
  {"key"
   (fn [reader tag component-count]
     (keyword (read-object reader) (read-object reader)))
  "sym"
   (fn [reader tag component-count]
     (symbol (read-object reader) (read-object reader)))
   "char"
   (fn [reader tag component-count]
     (read-object reader))
   "byte"
   (fn [reader tag component-count]
     (read-object reader))
   "map"
   (fn [reader tag component-count]
     (apply hash-map (read-object reader)))
   "set"
   (fn [reader tag component-count]
     (into #{} (read-object reader)))
   "vector"
   (fn [reader tag component-count]
     (into [] (read-object reader)))})
(defn create-reader [input-stream & {:keys [handlers checksum?]}]
  "Creates a fressian reader

   input-stream ([byte]|ByteBuffer) - Array of bytes or byte buffer containg a fressian stream
   Optional parameters:
     handlers (ILookup) - Lookup table for the read handler of a given type
     checksum? (boolean) - Should the checksum be validated when the footer is validated"
  (let [byte-buffer (if (satisfies? bsp/ByteBuffer input-stream) (bsp/duplicate-bytes input-stream) input-stream)]
    (bs/byte-input-stream byte-buffer (or handlers clojure-read-handlers) (boolean checksum?))))
(defn read [readable & options]
  "Convience function to read in a single obecjt from a fressian stream

   readable ([byte]|ByteBuffer) - Array of bytes or byte buffer containg a fressian stream
   options (ILookup) - Optional parameters to be passed into the fressian reader"
  (read-object (apply create-reader readable options)))

(ns longshi.core
  "Public API for the Fressian port of ClojureScript"
  (:refer-clojure :exclude (read))
  (:require [longshi.fressian.byte-stream-protocols :as bsp]
            [longshi.fressian.protocols :as p]
            [longshi.fressian.handlers :as fh]
            [longshi.fressian.byte-stream :as bs]
            [longshi.fressian.js :as bjs]))
;;Fressian Writer protocol namespace aliasing
(def write-footer p/write-footer!)
(def write-object p/write-object!)
(def write-tag p/write-tag!)
(def write-list p/write-list!)
(def write-boolean p/write-boolean!)
(def write-null p/write-null!)
(def write-int p/write-int!)
(def write-long p/write-long!)
(def write-float p/write-float!)
(def write-double p/write-double!)
(def write-bytes p/write-bytes!)
;;Fressian Reader protocol namespace aliasing
(def read-boolean p/read-boolean!)
(def read-int p/read-int!)
(def read-float p/read-float!)
(def read-double p/read-int!)
(def read-object p/read-object!)
;;Fressian Streaming protocol namespace aliasing
(def begin-open-list p/begin-open-list!)
(def begin-closed-list p/begin-closed-list!)
(def end-list p/end-list!)
;;Fressian Caching namespace aliasing
(def cache bjs/cache)
;;Fressian Tagged namespace aliasing
(def tagged-object fh/tagged-object)
(def tagged-array fh/tagged-array)

(defn write-record
  "Generic writer for ClojureScript Records

  writer (FressianWriter) - Fressian Writer for the record
  name (string) - Fressian name for the record
  record (object) - ClojureScript record to be written

  Currently the ClojureScript port of Fressian can't get the type name
  of ClojureScript records so the name of the record has to be passed in"
  [writer name record]
  (write-tag writer "record" 2)
  (write-object writer name true)
  (write-tag writer "map" 1)
  (begin-closed-list writer)
  (reduce-kv
    (fn [writer k v]
      (write-object writer k true)
      (write-object writer v))
    writer
    record)
  (end-list writer))

(defn map-write-handler [writer cljs-map]
  "Writes out a ClojureScript map to fressian

  writer (FressianWriter) - Fressian Writer for the record
  cljs-map (IMap) - ClojureScript map to be written

  Freesian maps are written internally as one list of alternating keys
  and values.  This method flattens the ClojureScript map sequence of key value
  pairs to a single list."
  (let [map-list (make-array (* 2 (count cljs-map)))]
    (do
      (write-tag writer "map" 1)
      (loop [map-seq (seq cljs-map) i 0]
        (if (empty? map-seq)
          map-list
          (let [[k v] (first map-seq)]
            (do
              (aset map-list i k)
              (aset map-list (inc i) v)
              (recur (rest map-seq) (+ i 2))))))
      (write-list writer map-list))))

(defn seq-write-handler [writer name cljs-seq]
  "Writes out a purely sequential ClojureScript type

  writer (FressianWriter) - Fressian Writer for the record
  cljs-seq (ISeq) - ClojureScript sequence to be written"
  (do
    (write-tag writer name 1)
    (write-list writer cljs-seq)))
;;ClojureScript base writers
(def clojure-write-handlers
  {Keyword
   {"key"
    (fn [writer k]
      (do
        (write-tag writer "key" 2)
        (write-object writer (namespace k) true)
        (write-object writer (name k) true)))}

   Symbol
   {"sym"
    (fn [writer k]
      (do
        (write-tag writer "sym" 2)
        (write-object writer (namespace k) true)
        (write-object writer (name k) true)))}

   PersistentHashMap
   {"map" map-write-handler}

   PersistentArrayMap
   {"map" map-write-handler}

   PersistentHashSet
   {"set"
    (fn [writer s]
      (seq-write-handler writer "set" s))}

   PersistentVector
   {"vector"
    (fn [writer v]
      (seq-write-handler writer "vector" v))}})

(defn create-writer [& {:keys [handlers]}]
  "Creates a fressian writer

   Optional parameters;
     handlers (ILookup) - Lookup table for finding the appropiate handler for a given
                          type"
  (let [write-handlers (or handlers clojure-write-handlers)
        handler-seq (mapv (fn [[k v]] (into [k] (first v))) write-handlers)]
    (bs/byte-output-stream 32 (fh/create-handler handler-seq))))
(defn write
  "Convience function to write out a single object

  obj (object) - object to be wriiten out
  options (ILookup) - Optional paramters
    footer? (boolean) - Write out a footer after the object is written"
  [obj & options]
  (let [{:keys [footer?]} (when options (apply hash-map options))
        writer (apply create-writer options)]
    (do
      (write-object writer obj)
      (when footer?
        (write-footer writer))
      writer)))
;;ClojureScript base readers
(def clojure-read-handlers
  {"key"
   (fn [reader tag component-count]
     (keyword (read-object reader) (read-object reader)))
  "sym"
   (fn [reader tag component-count]
     (symbol (read-object reader) (read-object reader)))
   "char"
   (fn [reader tag component-count]
     (read-object reader))
   "byte"
   (fn [reader tag component-count]
     (read-object reader))
   "map"
   (fn [reader tag component-count]
     (cljs.core/PersistentArrayMap.fromArray (read-object reader)))
   "set"
   (fn [reader tag component-count]
     (cljs.core/PersistentHashSet.fromArray (read-object reader)))
   "vector"
   (fn [reader tag component-count]
     (cljs.core/PersistentVector.fromArray (read-object reader)))})
(defn create-reader [input-stream & {:keys [handlers checksum?]}]
  "Creates a fressian reader

   input-stream ([byte]|ByteBuffer) - Array of bytes or byte buffer containg a fressian stream
   Optional parameters:
     handlers (ILookup) - Lookup table for the read handler of a given type
     checksum? (boolean) - Should the checksum be validated when the footer is validated"
  (let [byte-buffer (if (satisfies? bsp/ByteBuffer input-stream) (bsp/duplicate-bytes input-stream) input-stream)]
    (bs/byte-input-stream byte-buffer (or handlers clojure-read-handlers) (boolean checksum?))))
(defn read [readable & options]
  "Convience function to read in a single obecjt from a fressian stream

   readable ([byte]|ByteBuffer) - Array of bytes or byte buffer containg a fressian stream
   options (ILookup) - Optional parameters to be passed into the fressian reader"
  (read-object (apply create-reader readable options)))

Use the fromArray method for read speed up


(ns lt.util.load
  (:require [clojure.string :as string]))

(def fpath (js/require "path"))
(def fs (js/require "fs"))

(def pwd (.resolve fpath "."))

(def ^:dynamic *force-reload* false)

(defn absolute? [path]
  (boolean (re-seq #"^\s*[\\\/]|([\w]+:[\\\/])" path)))

(defn node-module [path]
  (js/require (str pwd "/core/node_modules/" path)))

(defn- prep [code file]
  (str code "\n\n//# sourceURL=" file))

(defn js
  ([file] (js file false))
  ([file sync]
   (let [file (if-not (absolute? file)
                (.join fpath pwd file)
                file)]
   (if sync
     (js/window.eval (-> (.readFileSync fs file)
                         (.toString)
                         (prep file)))
     (.readFile fs (.join fpath pwd file) (fn [content]
                                            (js/window.eval (-> (.toString content)
                                                                (prep file)))))))))

(defn css [file]
   (let [link (js/document.createElement "link")]
     (set! (.-type link) "text/css")
     (set! (.-rel link) "stylesheet")
     (set! (.-href link) (if (absolute? file)
                           (str "file://" file)
                           file))
     (js/document.head.appendChild link)
     link))

(defn obj-exists? [s]
  (loop [parts (string/split s ".")
         cur js/window]
    (if-not (first parts)
      cur
      (if-let [cur (aget cur (first parts))]
        (recur (rest parts) cur)))))

(def provided #js {})

(defn provided-ancestors [parent]
  (count (.filter (js/Object.keys provided) #(> (.indexOf % parent) -1))))

(defn only-ancestors? [cur s]
  (<= (.-length (js/Object.keys cur)) (provided-ancestors s)))

(defn provided? [s]
  (if *force-reload*
    false
    (let [res (if (aget provided s)
                true
                (when-let [cur (obj-exists? s)]
                  (not (only-ancestors? cur s))))]
      (aset provided s true)
      res)))

(ns lt.util.load
  (:require [clojure.string :as string]))

(def fpath (js/require "path"))
(def fs (js/require "fs"))

(def pwd (.resolve fpath "."))

(def ^:dynamic *force-reload* false)

(def fpath (js/require "path"))

(def separator (.-sep fpath))

(defn absolute? [path]
  (boolean (re-seq #"^\s*[\\\/]|([\w]+:[\\\/])" path)))

(defn node-module [path]
  (js/require (str pwd "/core/node_modules/" path)))

(defn- abs-source-mapping-url [code file]
  (if-let [path-to-source-map (second (re-find #"\n//# sourceMappingURL=(.*)" code))]
    (if-not (absolute? path-to-source-map)
      (let [abs-path-to-source-map (->> path-to-source-map
                          (string/replace-first file (re-pattern (str "[^" separator "]*$")))
                          js/encodeURI)]
        (string/replace-first code #"\n//# sourceMappingURL=.*" (str "\n//# sourceMappingURL=" abs-path-to-source-map)))
      code)
    code))

(defn- prep [code file]
  (-> code
      (abs-source-mapping-url file)
      (str "\n\n//# sourceURL=" file)))

(defn js
  ([file] (js file false))
  ([file sync]
   (let [file (if-not (absolute? file)
                (.join fpath pwd file)
                file)]
   (if sync
     (js/window.eval (-> (.readFileSync fs file)
                         (.toString)
                         (prep file)))
     (.readFile fs (.join fpath pwd file) (fn [content]
                                            (js/window.eval (-> (.toString content)
                                                                (prep file)))))))))

(defn css [file]
   (let [link (js/document.createElement "link")]
     (set! (.-type link) "text/css")
     (set! (.-rel link) "stylesheet")
     (set! (.-href link) (if (absolute? file)
                           (str "file://" file)
                           file))
     (js/document.head.appendChild link)
     link))

(defn obj-exists? [s]
  (loop [parts (string/split s ".")
         cur js/window]
    (if-not (first parts)
      cur
      (if-let [cur (aget cur (first parts))]
        (recur (rest parts) cur)))))

(def provided #js {})

(defn provided-ancestors [parent]
  (count (.filter (js/Object.keys provided) #(> (.indexOf % parent) -1))))

(defn only-ancestors? [cur s]
  (<= (.-length (js/Object.keys cur)) (provided-ancestors s)))

(defn provided? [s]
  (if *force-reload*
    false
    (let [res (if (aget provided s)
                true
                (when-let [cur (obj-exists? s)]
                  (not (only-ancestors? cur s))))]
      (aset provided s true)
      res)))

rewrite sourceMappingURL with full path so source maps can be found for 3rd party plugins


(ns protobuf.tasks
  (:use cake cake.ant
        [clojure.java.shell :only [sh]]
        [clojure.java.io :only [copy reader]])
  (:import [org.apache.tools.ant.taskdefs Chmod Copy ExecTask Get Javac Mkdir Untar]
           [java.net URL URLClassLoader URLConnection JarURLConnection]
           [java.util.jar JarEntry]
           [java.io File]))

(def version "2.3.0")
(def srcdir  (format "build/protobuf-%s" version))
(def tarfile (format "build/protobuf-%s.tar.gz" version))
(def url     (java.net.URL. (format "http://protobuf.googlecode.com/files/protobuf-%s.tar.gz" version)))

(defn installed? []
  (try (.contains (:out (sh "protoc" "--version")) version)
       (catch java.io.IOException e)))

(deftask fetch-protoc
  (when-not (.exists (file srcdir))
    (ant Get   {:src url :dest tarfile})
    (ant Untar {:src tarfile :dest "build" :compression "gzip"})))

(deftask install-protoc
  (when-not (installed?)
    (run-task 'fetch-protoc)
    (when-not (.exists (file srcdir "src" "protoc"))
      (ant Chmod {:file (file srcdir "configure")  :perm "+x"})
      (ant Chmod {:file (file srcdir "install-sh") :perm "+x"})
      (ant ExecTask {:dir srcdir :executable "./configure"})
      (ant ExecTask {:dir srcdir :executable "make"}))
    (ant ExecTask {:dir srcdir :executable "sudo"}
         (args ["make" "install"]))))

(defn- proto-dependencies "look for lines starting with import in proto-file"
  [proto-file]
  (for [line (line-seq (reader proto-file)) :when (.startsWith line "import")]
    (second (re-matches #".*\"(.*)\".*" line))))

(defn extract-resource [name dest-dir]
  (if-let [url (.findResource (.getClassLoader clojure.lang.RT) name)]
    (let [dest (File. dest-dir name)
          conn (.openConnection url)]
      (.mkdirs (.getParentFile dest))
      (if (instance? JarURLConnection conn)
        (let [jar (cast JarURLConnection conn)]
          (copy (.getInputStream jar) dest))
        (copy (File. (.getFile url)) dest))
      dest)
    (throw (Exception. (format "unable to find %s on classpath" name)))))

(defn extract-dependencies "extract all files proto is dependent on"
  [proto-file]
  (loop [files (vec (proto-dependencies proto-file))]
    (when-not (empty? files)
      (let [proto (peek files)
            files (pop files)]
        (if (or (.exists (file "proto" proto)) (.exists (file "build/proto" proto)))
          (recur files)
          (let [proto-file (extract-resource (str "proto/" proto) "build")]
            (recur (into files (proto-dependencies proto-file)))))))))

(defn protoc
  ([protos] (protoc protos "build/protosrc"))
  ([protos dest]
      (doseq [proto protos]
        (log "compiling" proto "to" dest)
        (extract-dependencies (file "proto" proto))
        (ant Mkdir {:dir dest})
        (ant Mkdir {:dir "build/proto"})
        (ant ExecTask {:executable "protoc" :dir "proto"}
             (args [proto (str "--java_out=../" dest) "-I." "-I../build/proto"])))
      (ant Javac {:srcdir    (path dest)
                  :destdir   (file "classes")
                  :classpath (classpath project)})))

(defn build-protobuf []
  (ant Mkdir {:dir "proto/google/protobuf"})
  (ant Copy {:file (str srcdir "/src/google/protobuf/descriptor.proto") :todir "proto/google/protobuf"})
  (protoc ["google/protobuf/descriptor.proto"] (str srcdir "/java/src/main/java"))
  (protoc ["clojure/protobuf/collections.proto"]))

(defn proto-files [dir]
  (for [file (rest (file-seq dir)) :when (.endsWith (.getName file) ".proto")]
    (.substring (.getPath file) (inc (count (.getPath dir))))))

(deftask proto
  (if (= "clojure-protobuf" (:artifact-id project))
    (do (run-task 'fetch-protoc)
        (build-protobuf))
    (protoc (or (:proto opts) (proto-files (file "proto"))))))

(ns protobuf.tasks
  (:use cake cake.ant
        [clojure.java.shell :only [sh]]
        [clojure.java.io :only [copy reader]])
  (:import [org.apache.tools.ant.taskdefs Chmod Copy ExecTask Get Javac Mkdir Untar]
           [java.net URL URLClassLoader URLConnection JarURLConnection]
           [java.util.jar JarEntry]
           [java.io File]))

(def version "2.3.0")
(def srcdir  (format "build/protobuf-%s" version))
(def tarfile (format "build/protobuf-%s.tar.gz" version))
(def url     (java.net.URL. (format "http://protobuf.googlecode.com/files/protobuf-%s.tar.gz" version)))

(defn installed? []
  (try (.contains (:out (sh "protoc" "--version")) version)
       (catch java.io.IOException e)))

(deftask fetch-protoc
  (when-not (.exists (file srcdir))
    (ant Get   {:src url :dest tarfile})
    (ant Untar {:src tarfile :dest "build" :compression "gzip"})))

(deftask install-protoc
  (when-not (installed?)
    (run-task 'fetch-protoc)
    (when-not (.exists (file srcdir "src" "protoc"))
      (ant Chmod {:file (file srcdir "configure")  :perm "+x"})
      (ant Chmod {:file (file srcdir "install-sh") :perm "+x"})
      (ant ExecTask {:dir srcdir :executable "./configure"})
      (ant ExecTask {:dir srcdir :executable "make"}))
    (ant ExecTask {:dir srcdir :executable "sudo"}
         (args ["make" "install"]))))

(defn- proto-dependencies "look for lines starting with import in proto-file"
  [proto-file]
  (for [line (line-seq (reader proto-file)) :when (.startsWith line "import")]
    (second (re-matches #".*\"(.*)\".*" line))))

(defn extract-resource [name dest-dir]
  (if-let [url (.findResource (.getClassLoader clojure.lang.RT) name)]
    (let [dest (File. dest-dir name)
          conn (.openConnection url)]
      (.mkdirs (.getParentFile dest))
      (if (instance? JarURLConnection conn)
        (let [jar (cast JarURLConnection conn)]
          (copy (.getInputStream jar) dest))
        (copy (File. (.getFile url)) dest))
      dest)
    (throw (Exception. (format "unable to find %s on classpath" name)))))

(defn extract-dependencies "extract all files proto is dependent on"
  [proto-file]
  (loop [files (vec (proto-dependencies proto-file))]
    (when-not (empty? files)
      (let [proto (peek files)
            files (pop files)]
        (if (or (.exists (file "proto" proto)) (.exists (file "build/proto" proto)))
          (recur files)
          (let [proto-file (extract-resource (str "proto/" proto) "build")]
            (recur (into files (proto-dependencies proto-file)))))))))

(defn protoc
  ([protos] (protoc protos "build/protosrc"))
  ([protos dest]
      (doseq [proto protos]
        (log "compiling" proto "to" dest)
        (extract-dependencies (file "proto" proto))
        (ant Mkdir {:dir dest})
        (ant Mkdir {:dir "build/proto"})
        (ant ExecTask {:executable "protoc" :dir "proto"}
             (args [proto (str "--java_out=../" dest) "-I." "-I../build/proto"])))
      (ant Javac {:srcdir    (path dest)
                  :destdir   (file "classes")
                  :classpath (classpath project)})))

(defn build-protobuf []
  (ant Mkdir {:dir "proto/google/protobuf"})
  (ant Copy {:file (str srcdir "/src/google/protobuf/descriptor.proto") :todir "proto/google/protobuf"})
  (protoc ["google/protobuf/descriptor.proto"] (str srcdir "/java/src/main/java"))
  (protoc ["clojure/protobuf/collections.proto"]))

(defn proto-files [dir]
  (for [file (rest (file-seq dir)) :when (.endsWith (.getName file) ".proto")]
    (.substring (.getPath file) (inc (count (.getPath dir))))))

(deftask compile #{proto})
(deftask proto
  (if (= "clojure-protobuf" (:artifact-id project))
    (do (run-task 'fetch-protoc)
        (build-protobuf))
    (protoc (or (:proto opts) (proto-files (file "proto"))))))

build protos before compiling

build protos before compiling


(ns nossal.app
  (:require [nossal.web :refer [index dot log breakout coupom miner]]
            [compojure.route :as route]
            [compojure.core :refer [defroutes routes wrap-routes GET PUT POST DELETE ANY]]
            [compojure.handler :refer [site]]
            [ring.adapter.jetty :as jetty]
            [ring.util.response :as response]
            [ring.middleware.defaults :refer :all]
            [environ.core :refer [env]]
            [clojure.java.io :as io]))

(defroutes app-routes
  (GET "/" request
    (index request))

  (GET "/p" request
    (str request))

  (GET "/dot" request
    (dot request))

  (GET "/weekly" request
    (log request))

  (GET "/breakout" request
    (breakout request))

  (GET "/miner" request
    (miner request))

  (GET "/_ah/health" request
    (str "👌"))

  (GET "/cupons/:service" [service :as request]
    (coupom service request))
  (GET "/cupons" []
    (response/redirect "/cupons/uber"))

  (route/resources "/")

  (ANY "*" []
    (route/not-found (slurp (io/resource "404.html")))))

(assoc secure-site-defaults :proxy true)

(def app
  (routes (-> app-routes (wrap-routes wrap-defaults secure-site-defaults))))

(defn -main [& [port]]
  (let [port (Integer. (or port (env :port) 3000))]
    (jetty/run-jetty (site #'app) {:port port :join? false})))

(ns nossal.app
  (:require [nossal.web :refer [index dot log breakout coupom miner]]
            [compojure.route :as route]
            [compojure.core :refer [defroutes routes wrap-routes GET PUT POST DELETE ANY]]
            [compojure.handler :refer [site]]
            [ring.adapter.jetty :as jetty]
            [ring.util.response :as response]
            [ring.middleware.defaults :refer :all]
            [environ.core :refer [env]]
            [clojure.java.io :as io]))

(defroutes app-routes
  (GET "/" request
    (index request))

  (GET "/p" request
    (str request))

  (GET "/dot" request
    (dot request))

  (GET "/weekly" request
    (log request))

  (GET "/breakout" request
    (breakout request))

  (GET "/miner" request
    (miner request))

  (GET "/_ah/health" request
    (str "👌"))

  (GET "/cupons/:service" [service :as request]
    (coupom service request))
  (GET "/cupons" []
    (response/redirect "/cupons/uber"))

  (route/resources "/")

  (ANY "*" []
    (route/not-found (slurp (io/resource "404.html")))))

(def app
  (routes (-> app-routes (wrap-routes wrap-defaults secure-site-defaults))))

(defn -main [& [port]]
  (let [port (Integer. (or port (env :port) 3000))]
    (jetty/run-jetty (site #'app) {:port port :join? false})))

Revert "redirect fix"

Revert "redirect fix"

This reverts commit 4cd5174c7961efbb0b0f9abf3d6b31e184850827.


(ns parkour.fs
  (:require [clojure.string :as str]
            [clojure.java.io :as io]
            [clojure.reflect :as reflect]
            [clojure.core.reducers :as r]
            [parkour (conf :as conf) (reducers :as pr)]
            [parkour.util :refer [ignore-errors returning map-vals mpartial]])
  (:import [java.net URI URL]
           [java.io File IOException InputStream OutputStream Reader Writer]
           [org.apache.hadoop.fs FileStatus FileSystem Path]
           [org.apache.hadoop.filecache DistributedCache]))

(defprotocol Coercions
  "Protocol for coercing objects to Hadoop `Path`s and `java.net.URI`s.  Logical
extension of `clojure.java.io/Coercions`."
  (^org.apache.hadoop.fs.Path ^:no-doc
    -path [x] "Coerce argument to a Path; private implementation.")
  (^java.net.URI ^:no-doc
    -uri [x] "Coerce argument to a URI; private implementation."))

(defmacro ^:private write-all
  [w & forms]
  (let [w (vary-meta w assoc :tag `Writer)]
    `(do ~@(map (fn [x] `(. ~w write ~(if (string? x) x `(str ~x)))) forms))))

(defn path
  "Coerce argument(s) to a Path, resolving successive arguments against base."
  {:tag `Path}
  ([x] (-path x))
  ([x y] (Path. (-path x) (str y)))
  ([x y & more] (apply path (path x y) more)))

(defn path-array
  "Array of `Path`s for each entry in seq `ps`."
  {:tag `"[Lorg.apache.hadoop.fs.Path;"}
  [ps] (into-array Path (map path ps)))

(defmethod print-method Path [x w] (write-all w "#hadoop.fs/path \"" x "\""))
(defmethod print-dup Path [x w] (write-all w "#hadoop.fs/path \"" x "\""))

(defn path?
  "True iff `x` is a Path."
  [x] (instance? Path x))

(defn uri
  "Coerce argument(s) to a URI, resolving successive arguments against base."
  {:tag `URI}
  ([x] (-uri x))
  ([x y]
     (let [x (-uri x)]
       (-> x (.resolve (str (.getPath x) "/")) (.resolve (str y)))))
  ([x y & more] (apply uri (uri x y) more)))

(defmethod print-method URI [x w] (write-all w "#java.net/uri \"" x "\""))
(defmethod print-dup URI [x w] (write-all w "#java.net/uri \"" x "\""))

(defn uri?
  "True iff `x` is a URI."
  [x] (instance? URI x))

(defn path-fs
  "Hadoop filesystem for the path `p`."
  {:tag `FileSystem}
  ([p] (path-fs (conf/ig) p))
  ([conf p] (.getFileSystem (path p) (conf/ig conf))))

(extend-protocol Coercions
  String
  (-path [x]
    (if (.startsWith x "file:")
      (-path (io/file (subs x 5)))
      (Path. x)))
  (-uri [x]
    (let [uri (URI. x)]
      (condp = (.getScheme uri)
        "file" (.toURI (io/file uri))
        nil    (-uri (-path x))
        ,,,,,, uri)))

  Path
  (-path [x] x)
  (-uri [x]
    (let [fs (ignore-errors (path-fs x))]
      (-> x (cond-> fs (.makeQualified fs)) .toUri)))

  URI
  (-path [x] (Path. x))
  (-uri [x] x)

  URL
  (-path [x] (Path. (str (.toURI x))))
  (-uri [x] (.toURI x))

  File
  (-path [x] (Path. (str "file:" (.getAbsolutePath x))))
  (-uri [x] (.toURI x)))

(extend-protocol io/Coercions
  Path
  (as-file [x] (io/as-file (uri x)))
  (as-url [x] (.toURL (uri x))))

(defn path-glob
  "Expand path glob `p` to set of matching paths."
  ([p] (path-glob (path-fs p) p))
  ([fs p]
     (->> (.globStatus ^FileSystem fs (path p))
          (map #(.getPath ^FileStatus %)))))

(defn path-list
  "List the entries in the directory at path `p`."
  ([p] (path-list (path-fs p) p))
  ([fs p]
     (->> (.listStatus ^FileSystem fs (path p))
          (map #(.getPath ^FileStatus %) ))))

(defn path-delete
  "Recursively delete files at path `p`."
  ([p] (path-delete (path-fs p) p))
  ([fs p] (.delete ^FileSystem fs (path p) true)))

(defn path-exists?
  ([p] (let [p (path p)] (path-exists? (path-fs p) p)))
  ([fs p] (.exists ^FileSystem fs (path p))))

(defn hidden?
  "True iff `p` is an HDFS-hidden ('_'-prefixed) file."
  [p] (-> p path .getName (.startsWith "_")))

(defn path-map
  "Return map of file basename to full path for all files in `dir`."
  ([dir] (path-map (path-fs dir) dir))
  ([fs dir]
     (let [dir (path dir)]
       (->> (.listStatus ^FileSystem fs dir)
            (r/remove #(.isDir ^FileStatus %))
            (r/map (comp (juxt #(.getName ^Path %) str)
                         #(.getPath ^FileStatus %)))
            (into {})))))

(defn path-open
  "Open an input stream on `p`, or default `fs` if not provided."
  ([p] (path-open (path-fs p) p))
  ([fs p] (.open ^FileSystem fs (path p))))

(defn input-stream
  "Open an input stream on `p`, via a Hadoop filesystem when in a
supported scheme and via `io/input-stream` when not."
  {:tag `InputStream}
  ([p] (input-stream (conf/ig) p))
  ([conf p]
     (let [p (path p)]
       (if-let [fs (ignore-errors (path-fs conf p))]
         (path-open fs p)
         (io/input-stream (io/as-url p))))))

(defn path-create
  "Create an output stream on `p` for `fs`, or default `fs` if not provided."
  ([p] (path-create (path-fs p) p))
  ([fs p] (.create ^FileSystem fs (path p))))

(extend Path
  io/IOFactory
  (assoc io/default-streams-impl
    :make-input-stream
    , (fn [p opts]
        (if-let [fs (or (:fs opts) (ignore-errors (path-fs p)))]
          (io/make-input-stream (path-open fs p) opts)
          (io/make-input-stream (io/as-url p) opts)))
    :make-output-stream
    , (fn [p opts]
        (if-let [fs (or (:fs opts) (ignore-errors (path-fs p)))]
          (io/make-output-stream (path-create fs p) opts)
          (io/make-output-stream (io/as-url p) opts)))))

;; Private for some reason, so copy internally
(def ^:private do-copy @#'io/do-copy)

(defmethod do-copy [Path OutputStream]
  [input output opts] (do-copy (io/input-stream input) output opts))
(defmethod do-copy [Path Writer]
  [input output opts] (do-copy (io/reader input) output opts))
(defmethod do-copy [Path File]
  [input output opts] (do-copy (io/input-stream input) output opts))

(defmethod do-copy [InputStream Path]
  [input output opts]
  (with-open [output (io/output-stream output)]
    (do-copy input output opts)))
(defmethod do-copy [Reader Path]
  [input output opts]
  (with-open [output (io/writer output)]
    (do-copy input output opts)))
(defmethod do-copy [File Path]
  [input output opts]
  (with-open [output (io/output-stream output)]
    (do-copy input output opts)))

(def ^:dynamic *temp-dir*
  "Default path to system temporary directory on the default
filesystem.  May be overridden in configuration via the property
`parkour.temp.dir`."
  "/tmp")

(defn ^:private run-id
  "A likely-unique user- and time-based string."
  []
  (let [user (System/getProperty "user.name")
        time (System/currentTimeMillis)
        rand (rand-int Integer/MAX_VALUE)]
    (str user "-" time "-" rand)))

(defn ^:private temp-root
  [conf] (path (conf/get conf "parkour.temp.dir" *temp-dir*)))

(defn ^:private new-temp-dir
  "Return path for a new temporary directory."
  [conf] (path (temp-root conf) (run-id)))

(def ^:private cancel-doe-method?
  "True iff the `Job` class has a static factory method."
  (->> FileSystem reflect/type-reflect :members
       (some #(= 'cancelDeleteOnExit (:name %)))))

(defmacro ^:private cancel-doe
  "Macro to cancel delete-on-exit when available."
  [& args]
  (if cancel-doe-method?
    `(.cancelDeleteOnExit ~@args)))

(defn with-temp-dir*
  "Function version of `with-temp-dir`."
  ([f] (with-temp-dir* nil f))
  ([conf f]
     (let [conf (or conf (conf/ig))
           temp-dir (new-temp-dir conf)
           fs (path-fs conf temp-dir)]
       (.mkdirs fs temp-dir)
       (.deleteOnExit fs temp-dir)
       (try
         (f temp-dir)
         (finally
           (.delete fs temp-dir true)
           (cancel-doe fs temp-dir))))))

(defmacro with-temp-dir
  "Run the forms in `body` with `temp-dir` bound to a Hadoop filesystem
temporary directory path, created via the optional `conf`."
  [[temp-dir conf] & body]
  `(with-temp-dir* ~conf (fn [~temp-dir] ~@body)))

(defn ^:private split-fragment
  [^URI uri]
  (let [fragment (.getFragment uri), uri-s (str uri), n (count uri-s)
        base (subs uri-s 0 (- n (count fragment) 1))]
    [fragment (URI. base)]))

(defn distcache-files
  "Retrieve map of existing distcache entries from `conf`."
  [conf]
  (->> (DistributedCache/getCacheFiles (conf/ig conf))
       (r/map split-fragment)
       (into {})))

(defn distcache!
  "Update Hadoop `conf` to merge the `uri-map` of local file paths to
URIs into the distributed cache configuration."
  [conf uri-map]
  (let [conf (doto (conf/ig conf)
               (DistributedCache/createSymlink))]
    (->> (into (distcache-files conf) uri-map)
         (map (fn [[local remote]]
                (.resolve (uri remote) (str "#" local))))
         (str/join ",")
         (conf/assoc! conf "mapred.cache.files"))))

(defn distcacher
  "Return a function for merging the `uri-map` of local paths to URIs
into the distributed cache files of a Hadoop configuration."
  [uri-map] (mpartial distcache! uri-map))

(defn with-copies*
  "Function form of `with-copies`."
  [conf uri-map f]
  (with-temp-dir [temp-dir conf]
    (let [conf (or conf (conf/ig)), uri-map (map-vals uri uri-map)
          temp-fs (path-fs conf temp-dir)
          uri-map (reduce (fn [result [local remote]]
                            (let [temp (path temp-dir local)]
                              (returning (assoc result local (uri temp))
                                (with-open [inf (input-stream conf remote),
                                            outf (.create temp-fs temp)]
                                  (io/copy inf outf)))))
                          {} uri-map)]
      (f uri-map))))

(defmacro with-copies
  "Copy the URI values of `uri-map` to a temporary directory on the
default Hadoop filesystem, optionally specified by `conf`.  Evaluate
`body` forms with `name` bound to the map of original `uri-map` keys
to new temporary paths."
  [[name uri-map conf] & body]
  `(with-copies* ~conf ~uri-map (fn [~name] ~@body)))

(ns parkour.fs
  (:require [clojure.string :as str]
            [clojure.java.io :as io]
            [clojure.reflect :as reflect]
            [clojure.core.reducers :as r]
            [parkour (conf :as conf) (reducers :as pr)]
            [parkour.util :refer [ignore-errors returning map-vals mpartial]])
  (:import [java.net URI URL]
           [java.io File IOException InputStream OutputStream Reader Writer]
           [org.apache.hadoop.fs FileStatus FileSystem Path]
           [org.apache.hadoop.filecache DistributedCache]))

(defprotocol Coercions
  "Protocol for coercing objects to Hadoop `Path`s and `java.net.URI`s.  Logical
extension of `clojure.java.io/Coercions`."
  (^org.apache.hadoop.fs.Path ^:no-doc
    -path [x] "Coerce argument to a Path; private implementation.")
  (^java.net.URI ^:no-doc
    -uri [x] "Coerce argument to a URI; private implementation."))

(defmacro ^:private write-all
  [w & forms]
  (let [w (vary-meta w assoc :tag `Writer)]
    `(do ~@(map (fn [x] `(. ~w write ~(if (string? x) x `(str ~x)))) forms))))

(defn path?
  "True iff `x` is a Path."
  [x] (instance? Path x))

(defn path
  "Coerce argument(s) to a Path, resolving successive arguments against base."
  {:tag `Path}
  ([x] (if (path? x) x (-path x)))
  ([x y] (Path. (path x) (str y)))
  ([x y & more] (apply path (path x y) more)))

(defn path-array
  "Array of `Path`s for each entry in seq `ps`."
  {:tag "[Lorg.apache.hadoop.fs.Path;"}
  [ps] (into-array Path (map path ps)))

(defmethod print-method Path [x w] (write-all w "#hadoop.fs/path \"" x "\""))
(defmethod print-dup Path [x w] (write-all w "#hadoop.fs/path \"" x "\""))

(defn uri?
  "True iff `x` is a URI."
  [x] (instance? URI x))

(defn uri
  "Coerce argument(s) to a URI, resolving successive arguments against base."
  {:tag `URI}
  ([x] (if (uri? x) x (-uri x)))
  ([x y]
     (let [x (uri x)]
       (-> x (.resolve (str (.getPath x) "/")) (.resolve (str y)))))
  ([x y & more] (apply uri (uri x y) more)))

(defmethod print-method URI [x w] (write-all w "#java.net/uri \"" x "\""))
(defmethod print-dup URI [x w] (write-all w "#java.net/uri \"" x "\""))

(defn path-fs
  "Hadoop filesystem for the path `p`."
  {:tag `FileSystem}
  ([p] (path-fs (conf/ig) p))
  ([conf p] (.getFileSystem (path p) (conf/ig conf))))

(extend-protocol Coercions
  String
  (-path [x]
    (if (.startsWith x "file:")
      (-path (io/file (subs x 5)))
      (Path. x)))
  (-uri [x]
    (let [uri (URI. x)]
      (condp = (.getScheme uri)
        "file" (.toURI (io/file uri))
        nil    (-uri (-path x))
        ,,,,,, uri)))

  Path
  (-path [x] x)
  (-uri [x]
    (let [fs (ignore-errors (path-fs x))]
      (-> x (cond-> fs (.makeQualified fs)) .toUri)))

  URI
  (-path [x] (Path. x))
  (-uri [x] x)

  URL
  (-path [x] (Path. (str (.toURI x))))
  (-uri [x] (.toURI x))

  File
  (-path [x] (Path. (str "file:" (.getAbsolutePath x))))
  (-uri [x] (.toURI x)))

(extend-protocol io/Coercions
  Path
  (as-file [x] (io/as-file (uri x)))
  (as-url [x] (.toURL (uri x))))

(defn path-glob
  "Expand path glob `p` to set of matching paths."
  ([p] (let [p (path p)] (path-glob (path-fs p) p)))
  ([fs p]
     (->> (.globStatus ^FileSystem fs (path p))
          (map #(.getPath ^FileStatus %)))))

(defn path-list
  "List the entries in the directory at path `p`."
  ([p] (let [p (path p)] (path-list (path-fs p) p)))
  ([fs p]
     (->> (.listStatus ^FileSystem fs (path p))
          (map #(.getPath ^FileStatus %) ))))

(defn path-delete
  "Recursively delete files at path `p`."
  ([p] (let [p (path p)] (path-delete (path-fs p) p)))
  ([fs p] (.delete ^FileSystem fs (path p) true)))

(defn path-exists?
  ([p] (let [p (path p)] (path-exists? (path-fs p) p)))
  ([fs p] (.exists ^FileSystem fs (path p))))

(defn hidden?
  "True iff `p` is an HDFS-hidden ('_'-prefixed) file."
  [p] (-> p path .getName (.startsWith "_")))

(defn path-map
  "Return map of file basename to full path for all files in `dir`."
  ([dir] (let [dir (path dir)] (path-map (path-fs dir) dir)))
  ([fs dir]
     (let [dir (path dir)]
       (->> (.listStatus ^FileSystem fs dir)
            (r/remove #(.isDir ^FileStatus %))
            (r/map (comp (juxt #(.getName ^Path %) str)
                         #(.getPath ^FileStatus %)))
            (into {})))))

(defn path-open
  "Open an input stream on `p`, or default `fs` if not provided."
  ([p] (path-open (path-fs p) p))
  ([fs p] (.open ^FileSystem fs (path p))))

(defn input-stream
  "Open an input stream on `p`, via a Hadoop filesystem when in a
supported scheme and via `io/input-stream` when not."
  {:tag `InputStream}
  ([p] (input-stream (conf/ig) p))
  ([conf p]
     (let [p (path p)]
       (if-let [fs (ignore-errors (path-fs conf p))]
         (path-open fs p)
         (io/input-stream (io/as-url p))))))

(defn path-create
  "Create an output stream on `p` for `fs`, or default `fs` if not provided."
  ([p] (let [p (path p)] (path-create (path-fs p) p)))
  ([fs p] (.create ^FileSystem fs (path p))))

(extend Path
  io/IOFactory
  (assoc io/default-streams-impl
    :make-input-stream
    , (fn [p opts]
        (if-let [fs (or (:fs opts) (ignore-errors (path-fs p)))]
          (io/make-input-stream (path-open fs p) opts)
          (io/make-input-stream (io/as-url p) opts)))
    :make-output-stream
    , (fn [p opts]
        (if-let [fs (or (:fs opts) (ignore-errors (path-fs p)))]
          (io/make-output-stream (path-create fs p) opts)
          (io/make-output-stream (io/as-url p) opts)))))

;; Private for some reason, so copy internally
(def ^:private do-copy @#'io/do-copy)

(defmethod do-copy [Path OutputStream]
  [input output opts] (do-copy (io/input-stream input) output opts))
(defmethod do-copy [Path Writer]
  [input output opts] (do-copy (io/reader input) output opts))
(defmethod do-copy [Path File]
  [input output opts] (do-copy (io/input-stream input) output opts))

(defmethod do-copy [InputStream Path]
  [input output opts]
  (with-open [output (io/output-stream output)]
    (do-copy input output opts)))
(defmethod do-copy [Reader Path]
  [input output opts]
  (with-open [output (io/writer output)]
    (do-copy input output opts)))
(defmethod do-copy [File Path]
  [input output opts]
  (with-open [output (io/output-stream output)]
    (do-copy input output opts)))

(def ^:dynamic *temp-dir*
  "Default path to system temporary directory on the default
filesystem.  May be overridden in configuration via the property
`parkour.temp.dir`."
  "/tmp")

(defn ^:private run-id
  "A likely-unique user- and time-based string."
  []
  (let [user (System/getProperty "user.name")
        time (System/currentTimeMillis)
        rand (rand-int Integer/MAX_VALUE)]
    (str user "-" time "-" rand)))

(defn ^:private temp-root
  [conf] (path (conf/get conf "parkour.temp.dir" *temp-dir*)))

(defn ^:private new-temp-dir
  "Return path for a new temporary directory."
  [conf] (path (temp-root conf) (run-id)))

(def ^:private cancel-doe-method?
  "True iff the `Job` class has a static factory method."
  (->> FileSystem reflect/type-reflect :members
       (some #(= 'cancelDeleteOnExit (:name %)))))

(defmacro ^:private cancel-doe
  "Macro to cancel delete-on-exit when available."
  [& args]
  (if cancel-doe-method?
    `(.cancelDeleteOnExit ~@args)))

(defn with-temp-dir*
  "Function version of `with-temp-dir`."
  ([f] (with-temp-dir* nil f))
  ([conf f]
     (let [conf (or conf (conf/ig))
           temp-dir (new-temp-dir conf)
           fs (path-fs conf temp-dir)]
       (.mkdirs fs temp-dir)
       (.deleteOnExit fs temp-dir)
       (try
         (f temp-dir)
         (finally
           (.delete fs temp-dir true)
           (cancel-doe fs temp-dir))))))

(defmacro with-temp-dir
  "Run the forms in `body` with `temp-dir` bound to a Hadoop filesystem
temporary directory path, created via the optional `conf`."
  [[temp-dir conf] & body]
  `(with-temp-dir* ~conf (fn [~temp-dir] ~@body)))

(defn ^:private split-fragment
  [^URI uri]
  (let [fragment (.getFragment uri), uri-s (str uri), n (count uri-s)
        base (subs uri-s 0 (- n (count fragment) 1))]
    [fragment (URI. base)]))

(defn distcache-files
  "Retrieve map of existing distcache entries from `conf`."
  [conf]
  (->> (DistributedCache/getCacheFiles (conf/ig conf))
       (r/map split-fragment)
       (into {})))

(defn distcache!
  "Update Hadoop `conf` to merge the `uri-map` of local file paths to
URIs into the distributed cache configuration."
  [conf uri-map]
  (let [conf (doto (conf/ig conf)
               (DistributedCache/createSymlink))]
    (->> (into (distcache-files conf) uri-map)
         (map (fn [[local remote]]
                (.resolve (uri remote) (str "#" local))))
         (str/join ",")
         (conf/assoc! conf "mapred.cache.files"))))

(defn distcacher
  "Return a function for merging the `uri-map` of local paths to URIs
into the distributed cache files of a Hadoop configuration."
  [uri-map] (mpartial distcache! uri-map))

(defn with-copies*
  "Function form of `with-copies`."
  [conf uri-map f]
  (with-temp-dir [temp-dir conf]
    (let [conf (or conf (conf/ig)), uri-map (map-vals uri uri-map)
          temp-fs (path-fs conf temp-dir)
          uri-map (reduce (fn [result [local remote]]
                            (let [temp (path temp-dir local)]
                              (returning (assoc result local (uri temp))
                                (with-open [inf (input-stream conf remote),
                                            outf (.create temp-fs temp)]
                                  (io/copy inf outf)))))
                          {} uri-map)]
      (f uri-map))))

(defmacro with-copies
  "Copy the URI values of `uri-map` to a temporary directory on the
default Hadoop filesystem, optionally specified by `conf`.  Evaluate
`body` forms with `name` bound to the map of original `uri-map` keys
to new temporary paths."
  [[name uri-map conf] & body]
  `(with-copies* ~conf ~uri-map (fn [~name] ~@body)))

Tweak Path coercion.

Tweak Path coercion.


(ns minreact.core)

(defn- extract-opts
  "Return [opts-map spec]"
  [spec]
  (let [opts
        (into {}
              (comp
               (partition-all 2)
               (take-while (comp keyword? first)))
              spec)]
    [opts (drop (* 2 (count opts)) spec)]))

(defn- wrap-fn
  [prop-binding {this-sym :this-as
                 state-binding :state
                 :or {this-sym (gensym "this")}} fn-form]
  (let [raw? (= 'raw (second fn-form))
        [fn-name fn-bindings & fn-body] (nthrest fn-form (if raw? 2 1))
        fn-params (mapv (fn [param]
                          (gensym (name param)))
                        fn-bindings)]
    [(name fn-name)
     `(fn ~fn-name
        ~fn-params
        (cljs.core/this-as ~this-sym
          (let [~prop-binding (props ~this-sym)
                ~@(if state-binding
                    [state-binding (list `state this-sym)])
                ~@(if (and (not raw?)
                           (contains? '#{componentWillReceiveProps
                                         shouldComponentUpdate
                                         componentWillUpdate
                                         componentDidUpdate}
                                      fn-name))
                    (mapcat (fn [binding param getter]
                              [binding (list getter param)])
                            fn-bindings
                            fn-params
                            [`minreact-props
                             `minreact-state])
                    (mapcat (fn [binding param]
                              [binding param])
                            fn-bindings
                            fn-params))]
            ~@fn-body)))]))

(defmacro genspec
  "Generate a spec suitable for React.createClass.

  (genspec prop-binding options* specs*)

  prop-binding - A binding form which is available in all direct
  function definitions

  the following options are available:

  :state - A binding form for the component local state, available in
  all direct function defintions

  :this-as - A symbol bound to the React component in all direct
  function definitions

  A spec consists of either of a symbol value pair:

  Defines a field in the generated spec named symbol and definition.

  See https://facebook.github.io/react/docs/component-specs.html for
  available properties.

  The following properties are augmented:

  mixins - If a vector is passed, the minreact default mixin is
  prepended and it is cast to a js-array.  The default mixin can be
  disabled by associating :no-default on the vectors metadata map.
  NOTE: If no mixins are passed, the minreact default mixin is used as
  well.

  Alternatively, a single literal function definition can be passed as
  follows

  (fn modifiers* name arg positional-params body)

  These function definitions are transformed so that state and props
  bindings are available.

  The following fn names are augmented:

  componentWillReceiveProps
  shouldComponentUpdate
  componentWillUpdate
  componentDidUpdate

  For these, the props and state arguments passed by react are rebound
  to their minreact properties.  You can disable this behavior by
  specifying the symbol \"raw\" as a modifier.

  Note that this behavior can be avoided completely by specifiyng the
  function as a symbol definition pair."
  [prop-binding & spec]
  (let [[opts spec] (extract-opts spec)
        spec (cond-> spec
               (not-any? #{'mixins} spec)
               (concat '[mixins []]))]
    `(cljs.core/js-obj
      ~@(loop [[f s :as elems] spec
               result []]
          (if f
            (cond (symbol? f)
                  (recur (nthnext elems 2)
                         (conj result
                               (name f)
                               (cond (= 'mixins f)
                                     `(let [s# ~s]
                                        (if (vector? s#)
                                          (apply cljs.core/array
                                                 (cond->> s#
                                                   (not (:no-default (meta s#)))
                                                   (cons default-mixin)))))
                                     :else
                                     s)))
                  (list? f)
                  (recur (next elems)
                         (into result (wrap-fn prop-binding opts f)))
                  :else
                  (throw (IllegalArgumentException.
                          (str "Invalid spec elem: " (pr-str f)))))
            result)))))

(defmacro defreact
  "Define a variadic factory function according to spec. varargs
  become the components minreact props.

  Within methods, the components this object is bound to name.  This
  can be overriden by using the :this-as option in spec.

  See also: genspec.

  React attributes:

  If the first arg passed is a map or JS object, the following keys
  are associated directly in the React props and will not be made
  available in the minreact props:

  :key, :ref, :dangerouslySetInnerHTML

  See also:
  https://facebook.github.io/react/docs/special-non-dom-attributes.html"
  [name prop-binding & spec]
  (assert (vector? prop-binding))
  `(def ~name
     (let [c# (js/React.createClass
               (genspec ~prop-binding :this-as ~name ~@spec))]
       (fn [prop# & props#]
         (let [[obj# prop#] (extract-reserved prop#)]
           (aset obj# props-key (cons prop# props#))
           (js/React.createElement c# obj#))))))

(ns minreact.core)

(defn- extract-opts
  "Return [opts-map spec]"
  [spec]
  (let [opts
        (into {}
              (comp
               (partition-all 2)
               (take-while (comp keyword? first)))
              spec)]
    [opts (drop (* 2 (count opts)) spec)]))

(defn- wrap-fn
  [prop-binding {this-sym :this-as
                 state-binding :state
                 :or {this-sym (gensym "this")}} fn-form]
  (let [raw? (= 'raw (second fn-form))
        [fn-name fn-bindings & fn-body] (nthrest fn-form (if raw? 2 1))
        fn-params (mapv (fn [i]
                          (gensym (str fn-name "_arg_" i)))
                        (range (count fn-bindings)))]
    [(name fn-name)
     `(fn ~fn-name
        ~fn-params
        (cljs.core/this-as ~this-sym
          (let [~prop-binding (props ~this-sym)
                ~@(if state-binding
                    [state-binding (list `state this-sym)])
                ~@(if (and (not raw?)
                           (contains? '#{componentWillReceiveProps
                                         shouldComponentUpdate
                                         componentWillUpdate
                                         componentDidUpdate}
                                      fn-name))
                    (mapcat (fn [binding param getter]
                              [binding (list getter param)])
                            fn-bindings
                            fn-params
                            [`minreact-props
                             `minreact-state])
                    (mapcat (fn [binding param]
                              [binding param])
                            fn-bindings
                            fn-params))]
            ~@fn-body)))]))

(defmacro genspec
  "Generate a spec suitable for React.createClass.

  (genspec prop-binding options* specs*)

  prop-binding - A binding form which is available in all direct
  function definitions

  the following options are available:

  :state - A binding form for the component local state, available in
  all direct function defintions

  :this-as - A symbol bound to the React component in all direct
  function definitions

  A spec consists of either of a symbol value pair:

  Defines a field in the generated spec named symbol and definition.

  See https://facebook.github.io/react/docs/component-specs.html for
  available properties.

  The following properties are augmented:

  mixins - If a vector is passed, the minreact default mixin is
  prepended and it is cast to a js-array.  The default mixin can be
  disabled by associating :no-default on the vectors metadata map.
  NOTE: If no mixins are passed, the minreact default mixin is used as
  well.

  Alternatively, a single literal function definition can be passed as
  follows

  (fn modifiers* name arg positional-params body)

  These function definitions are transformed so that state and props
  bindings are available.

  The following fn names are augmented:

  componentWillReceiveProps
  shouldComponentUpdate
  componentWillUpdate
  componentDidUpdate

  For these, the props and state arguments passed by react are rebound
  to their minreact properties.  You can disable this behavior by
  specifying the symbol \"raw\" as a modifier.

  Note that this behavior can be avoided completely by specifiyng the
  function as a symbol definition pair."
  [prop-binding & spec]
  (let [[opts spec] (extract-opts spec)
        spec (cond-> spec
               (not-any? #{'mixins} spec)
               (concat '[mixins []]))]
    `(cljs.core/js-obj
      ~@(loop [[f s :as elems] spec
               result []]
          (if f
            (cond (symbol? f)
                  (recur (nthnext elems 2)
                         (conj result
                               (name f)
                               (cond (= 'mixins f)
                                     `(let [s# ~s]
                                        (if (vector? s#)
                                          (apply cljs.core/array
                                                 (cond->> s#
                                                   (not (:no-default (meta s#)))
                                                   (cons default-mixin)))))
                                     :else
                                     s)))
                  (list? f)
                  (recur (next elems)
                         (into result (wrap-fn prop-binding opts f)))
                  :else
                  (throw (IllegalArgumentException.
                          (str "Invalid spec elem: " (pr-str f)))))
            result)))))

(defmacro defreact
  "Define a variadic factory function according to spec. varargs
  become the components minreact props.

  Within methods, the components this object is bound to name.  This
  can be overriden by using the :this-as option in spec.

  See also: genspec.

  React attributes:

  If the first arg passed is a map or JS object, the following keys
  are associated directly in the React props and will not be made
  available in the minreact props:

  :key, :ref, :dangerouslySetInnerHTML

  See also:
  https://facebook.github.io/react/docs/special-non-dom-attributes.html"
  [name prop-binding & spec]
  (assert (vector? prop-binding))
  `(def ~name
     (let [c# (js/React.createClass
               (genspec ~prop-binding :this-as ~name ~@spec))]
       (fn [prop# & props#]
         (let [[obj# prop#] (extract-reserved prop#)]
           (aset obj# props-key (cons prop# props#))
           (js/React.createElement c# obj#))))))

support destructoring in augmented fn-params


(ns
  ^{:doc

  "Dispatching Input Events of a SimRunner Application."

    :author "Frank Mosebach"}
  fm.simrunner.input
  (:require
    [fm.simrunner.config :as cfg]))

(defmulti on-input {:private true} (fn [id & _] id))

(defmethod on-input :default [id app & args]
  (println (format "on-input{id: %s args: %s}" id args)))

(defn- handle-input? [{app-state :state}]
  (let [{ui :ui} @app-state]
    (and (not (:locked? ui))
         (not (:rendering? ui)))))

(defn dispatch [id app args]
  (when (handle-input? app)
    (apply on-input id app args)))

(ns
  ^{:doc

  "Dispatching Input Events of a SimRunner Application."

    :author "Frank Mosebach"}
  fm.simrunner.input
  (:require
    [fm.simrunner.config :as cfg]))

(defn- value->param [id value]
  (if (= :calc-err id)
    (if value "1" "0")
    (str value)))

(defn- update-values [app-state id value]
  (assoc-in app-state [:ui :model :values id] value))

(defn- update-config [app-state id value]
  (let [config (-> (get-in app-state [:model :config])
                   (cfg/with-value id (value->param id value)))]
    (-> app-state
        (assoc-in [:model :config] config)
        (assoc-in [:model :changed?] true)
        (assoc-in [:model :valid?] (cfg/complete? config)))))

(defn- on-input [id {app-state :state} & [widget value :as args]]
  (println (format "on-input{id: %s value: %s}" id value))
  (swap! app-state
         (fn [app-state]
           (-> app-state
               (update-values id value)
               (update-config id value)))))

(defn- handle-input? [{app-state :state}]
  (let [{ui :ui} @app-state]
    (and (not (:locked? ui))
         (not (:rendering? ui)))))

(defn dispatch [id app args]
  (when (handle-input? app)
    (apply on-input id app args)))

Update the app's model according to incoming events.


(ns pinpointer.core
  (:require #?(:clj [clansi])
            [clojure.spec.alpha :as s]
            [clojure.string :as str]
            [clojure.walk :as walk]
            [fipp.clojure :as fipp]
            [pinpointer.formatter :as formatter]
            [pinpointer.trace :as trace]))

(def ^:dynamic *colorize-fn*)

(defn- colorize [color s]
  (*colorize-fn* color s))

(defn- ansi-colorize [color s]
  #?(:clj (clansi/style s color)
     :cljs s))

(defn- none-colorize [_ s] s)

(def ^:private builtin-colorize-fns
  {:ansi ansi-colorize
   :none none-colorize})

(defn- choose-colorize-fn [colorize]
  (let [colorize (or colorize :none)]
    (if (keyword? colorize)
      (get builtin-colorize-fns colorize none-colorize)
      colorize)))

(defn- times [n c]
  (str/join (repeat n c)))

(defn- space [n]
  (times n \space))

(defn- wavy-line [n]
  (colorize :red (times n \^)))

(defn- format-line [line hiliting?]
  (let [[_ indent line'] (re-matches #"(\s*)(.*)" line)
        parts (str/split line' #"\000")]
    (if (= (count parts) 1)
      (if hiliting?
        [line (str (space (count indent)) (wavy-line (count line))) true]
        [line nil false])
      (loop [parts parts, hiliting? hiliting?, ret [indent], wavy [indent]]
        (if (empty? parts)
          [(str/join ret) (str/join wavy) (not hiliting?)]
          (let [[part & parts] parts]
            (if hiliting?
              (recur parts (not hiliting?)
                     (conj ret (colorize :red part))
                     (conj wavy (wavy-line (count part))))
              (recur parts (not hiliting?)
                     (conj ret part)
                     (conj wavy (space (count part)))))))))))

(defn- format-data [value trace]
  (let [lines (str/split (formatter/format value trace) #"\n")]
    (loop [[line & more] lines, hiliting? false, ret []]
      (if-not line
        ret
        (let [[line wavy hiliting?] (format-line line hiliting?)]
          (recur more
                 hiliting?
                 (cond-> (conj ret line)
                   wavy (conj wavy))))))))

(defn- print-headline [nproblems]
  (if (= nproblems 1)
    (println " Detected 1 spec error:")
    (println " Detected" nproblems "spec errors:")))

(defn- hline []
  (->> " --------------------------------------------------"
       (colorize :cyan)
       println))

(defn- correct-paths [ed]
  (if (::s/args ed)
    ;; Probably :path in each problem has extra :args key
    (update ed ::s/problems
            (fn [problems] (map #(update % :path subvec 1) problems)))
    ed))

(defn- simplify-spec [spec]
  (walk/postwalk (fn [x]
                   (if (symbol? x)
                     (condp #(= (namespace %2) %1) x
                       "clojure.core" (symbol (name x))
                       "clojure.spec.alpha" (symbol "s" (name x))
                       x)
                     x))
                 spec))

(defn pinpoint-out
  ([ed] (pinpoint-out ed {}))
  ([ed {:keys [colorize]}]
   (if ed
     (let [{:keys [::s/problems ::s/value] :as ed} (correct-paths ed)
           nproblems (count problems)]
       (if-let [traces (try (trace/traces ed) (catch Throwable _ nil))]
         (binding [*colorize-fn* (choose-colorize-fn colorize)]
           (newline)
           (print-headline nproblems)
           (hline)
           (doseq [[i problem trace] (map vector (range) problems traces)
                   :let [[line & lines] (format-data value trace)]]
             (printf " (%d/%d)\n\n" (inc i) nproblems)
             (println "     Input:" line)
             (doseq [line lines]
               (println "          :" line))
             (let [[line & lines] (as-> (:pred problem) it
                                    (simplify-spec it)
                                    (with-out-str (fipp/pprint it))
                                    (str/split it #"\n"))]
               (println "  Expected:" line)
               (doseq [line lines]
                 (println "          :" line)))
             (when-let [reason (:reason problem)]
               (println "    Reason:" reason))
             (newline)
             (hline)))
         (do (println "\n(Failed to analyze the spec errors, and will fall back to s/explain-printer)\n")
             (s/explain-printer ed))))
     (println "Success!!"))))

(defn pinpoint
  ([spec x] (pinpoint spec x {}))
  ([spec x opts]
   (pinpoint-out (s/explain-data spec x) opts)))

(defn ppt []
  (letfn [(find-spec-error [^Throwable t]
            (when t
              (let [data (ex-data t)]
                (if (and data (::s/problems data))
                  t
                  (recur (.getCause t))))))]
    (when-let [e (find-spec-error *e)]
      (pinpoint-out (ex-data e)))))

(ns pinpointer.core
  (:require #?(:clj [clansi])
            [clojure.spec.alpha :as s]
            [clojure.string :as str]
            [clojure.walk :as walk]
            [fipp.clojure :as fipp]
            [pinpointer.formatter :as formatter]
            [pinpointer.trace :as trace]))

(def ^:dynamic *colorize-fn*)

(defn- colorize [color s]
  (*colorize-fn* color s))

(defn- ansi-colorize [color s]
  #?(:clj (clansi/style s color)
     :cljs s))

(defn- none-colorize [_ s] s)

(def ^:private builtin-colorize-fns
  {:ansi ansi-colorize
   :none none-colorize})

(defn- choose-colorize-fn [colorize]
  (let [colorize (or colorize :none)]
    (if (keyword? colorize)
      (get builtin-colorize-fns colorize none-colorize)
      colorize)))

(defn- times [n c]
  (str/join (repeat n c)))

(defn- space [n]
  (times n \space))

(defn- wavy-line [n]
  (colorize :red (times n \^)))

(defn- format-line [line hiliting?]
  (let [[_ indent line'] (re-matches #"(\s*)(.*)" line)
        parts (str/split line' #"\000")]
    (if (= (count parts) 1)
      (if hiliting?
        [line (str (space (count indent)) (wavy-line (count line))) true]
        [line nil false])
      (loop [parts parts, hiliting? hiliting?, ret [indent], wavy [indent]]
        (if (empty? parts)
          [(str/join ret) (str/join wavy) (not hiliting?)]
          (let [[part & parts] parts]
            (if hiliting?
              (recur parts (not hiliting?)
                     (conj ret (colorize :red part))
                     (conj wavy (wavy-line (count part))))
              (recur parts (not hiliting?)
                     (conj ret part)
                     (conj wavy (space (count part)))))))))))

(defn- format-data [value trace]
  (let [lines (str/split (formatter/format value trace) #"\n")]
    (loop [[line & more] lines, hiliting? false, ret []]
      (if-not line
        ret
        (let [[line wavy hiliting?] (format-line line hiliting?)]
          (recur more
                 hiliting?
                 (cond-> (conj ret line)
                   wavy (conj wavy))))))))

(defn- print-headline [nproblems]
  (if (= nproblems 1)
    (println " Detected 1 spec error:")
    (println " Detected" nproblems "spec errors:")))

(defn- hline []
  (->> " --------------------------------------------------"
       (colorize :cyan)
       println))

(defn- correct-paths [ed]
  (if (::s/args ed)
    ;; Probably :path in each problem has extra :args key
    (update ed ::s/problems
            (fn [problems] (map #(update % :path subvec 1) problems)))
    ed))

(defn- simplify-spec [spec]
  (walk/postwalk (fn [x]
                   (if (symbol? x)
                     (condp #(= (namespace %2) %1) x
                       "clojure.core" (symbol (name x))
                       "clojure.spec.alpha" (symbol "s" (name x))
                       x)
                     x))
                 spec))

(defn pinpoint-out
  ([ed] (pinpoint-out ed {}))
  ([ed {:keys [colorize]}]
   (if ed
     (let [{:keys [::s/problems ::s/value] :as ed} (correct-paths ed)
           nproblems (count problems)]
       (if-let [traces (try (trace/traces ed)
                            (catch #?(:clj Throwable :cljs js/Error) _))]
         (binding [*colorize-fn* (choose-colorize-fn colorize)]
           (newline)
           (print-headline nproblems)
           (hline)
           (doseq [[i problem trace] (map vector (range) problems traces)
                   :let [[line & lines] (format-data value trace)]]
             (println (str " (" (inc i) "/" nproblems ")\n"))
             (println "     Input:" line)
             (doseq [line lines]
               (println "          :" line))
             (let [[line & lines] (as-> (:pred problem) it
                                    (simplify-spec it)
                                    (with-out-str (fipp/pprint it))
                                    (str/split it #"\n"))]
               (println "  Expected:" line)
               (doseq [line lines]
                 (println "          :" line)))
             (when-let [reason (:reason problem)]
               (println "    Reason:" reason))
             (newline)
             (hline)))
         (do (println "\n(Failed to analyze the spec errors, and will fall back to s/explain-printer)\n")
             (s/explain-printer ed))))
     (println "Success!!"))))

(defn pinpoint
  ([spec x] (pinpoint spec x {}))
  ([spec x opts]
   (pinpoint-out (s/explain-data spec x) opts)))

#?(:clj
   (defn- find-spec-error [^Throwable t]
     (when t
       (let [data (ex-data t)]
         (if (and data (::s/problems data))
           t
           (recur (.getCause t))))))

   :cljs
   (defn- find-spec-error [e]
     (when (some-> e ex-data ::s/problems)
       e)))

(defn ppt []
  (when-let [e (find-spec-error *e)]
    (pinpoint-out (ex-data e))))

Fix problematic code for CLJS

Fix problematic code for CLJS


(ns playmary.one
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :as async :refer [<! put! chan timeout sliding-buffer close!]]
            [playmary.util :as util]
            [playmary.scales :as scales]))

(def timbre js/T)

(def colors [{:note "#676767" :light "#6DA0CB" :dark "#000000"}
             {:note "#929292" :light "#A76AB9" :dark "#1E1E1E"}
             {:note "#B9B9B9" :light "#BB67A2" :dark "#3D3D3D"}
             {:note "#DCDCDC" :light "#C55D83" :dark "#5C5C5C"}
             {:note "#FFFFFF" :light "#D35E4C" :dark "#7A7A7A"}
             {:note "#000000" :light "#E18C43" :dark "#999999"}
             {:note "#393939" :light "#E1B040" :dark "#B9B9B9"}])

(defn piano-key-width
  [{piano-keys :piano-keys w :w}]
  (.round js/Math (/ w (count piano-keys))))

(defn latest-note
  [instrument freq]
  (some (fn [note] (and (= freq (-> note :freq)) note))
        (-> instrument :notes)))

(defn t->px
  [{start :start px-per-ms :px-per-ms} t]
  (* px-per-ms (- t start)))

(defn note-rect
  [{on :on off :off freq :freq :as note}
   {px-per-ms :px-per-ms playhead :playhead :as instrument}]
  (let [piano-key-w (piano-key-width instrument)]
    {:x (* piano-key-w (get-in instrument [:piano-keys freq :n]))
     :y (+ (t->px instrument on)
           (/ (-> instrument :h) 2))
     :w piano-key-w
     :h (- (t->px instrument (or off playhead))
           (t->px instrument on))}))

(defn screen-rect
  [{w :w h :h playhead :playhead :as instrument}]
  {:x 0 :y (t->px instrument playhead) :w w :h h})

(defn draw-note
  [draw-ctx instrument note]
  (let [{x :x y :y w :w h :h} (note-rect note instrument)]
    (set! (.-fillStyle draw-ctx) "white")
    (.fillRect draw-ctx x y w h)))

(defn colliding?
  [r1 r2]
  (not (or (< (+ (:x r1) (:w r1)) (:x r2))
           (< (+ (:y r1) (:h r1)) (:y r2))
           (> (:x r1) (+ (:x r2) (:w r2)))
           (> (:y r1) (+ (:y r2) (:h r2))))))

(defn on-screen?
  [instrument note]
  (colliding? (note-rect note instrument)
              (screen-rect instrument)))

(defn draw-notes
  [draw-ctx instrument]
  (doseq [note (filter (partial on-screen? instrument)
                       (-> instrument :notes))]
    (draw-note draw-ctx instrument note)))

(defn draw-piano-keys
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (let [piano-keys (-> instrument :piano-keys)
        piano-key-w (piano-key-width instrument)]
    (doseq [[n [freq piano-key]] (map-indexed vector piano-keys)]
      (set! (.-fillStyle draw-ctx)
            ((if (piano-key :on?) :light :dark) (nth colors (mod n (count colors)))))
      (.fillRect draw-ctx
                 (* n piano-key-w)
                 (t->px instrument playhead)
                 piano-key-w h))))

(defn draw-instrument
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (.save draw-ctx)
  (.translate draw-ctx 0 (-> (t->px instrument playhead) -))
  (.clearRect draw-ctx 0 0 w h)
  (draw-piano-keys draw-ctx instrument)
  (draw-notes draw-ctx instrument)
  (.restore draw-ctx))

(defn touch->note
  [x instrument]
  (let [note-index (.floor js/Math (/ x (piano-key-width instrument)))]
    (nth (-> instrument :piano-keys keys) note-index)))

(defn create-note-synth
  [freq]
  (timbre "adsr"
          (js-obj "a" 5 "d" 10000 "s" 0 "r" 500)
          (timbre "fami" (js-obj "freq" freq "mul" 0.1))))

(defn create-instrument
  [scale]
  (let [start (.getTime (js/Date.))]
    {:piano-keys (into (sorted-map) (map-indexed (fn [i freq] [freq {:n i :on? false}])
                                                 scale))
     :notes ()
     :w 0 :h 0 :sound-ready false
     :px-per-ms 0.04
     :start start
     :playhead start}))

(defn add-synths-to-instrument
  [instrument]
  (assoc (reduce (fn [a x] (assoc-in a [:piano-keys x :synth] (create-note-synth x)))
                 instrument
                 (-> instrument :piano-keys keys))
    :sound-ready true))

(defn touch-data->touches [touch-data]
  (let [event (.-event_ touch-data)
        touches (js->clj (.-changedTouches event) :keywordize-keys true)]
    (map (fn [x] {:type (.-type event)
                  :touch-id (:identifier x)
                  :clientX (:clientX x)
                  :time (.-timeStamp event)})
         (for [x (range (:length touches))] ((keyword (str x)) touches)))))

(defn touch->freq
  [instrument touch]
  (touch->note (get touch :clientX)
               instrument))

(def instrument-fns
  {"touchstart" (fn
                  [instrument {touch-id :touch-id time :time :as event}]
                  (let [freq (touch->freq instrument event)
                        piano-key (get-in instrument [:piano-keys freq])]
                    (if-not (:on? piano-key)
                      (do
                        ;; (println "play")
                        (.play (.bang (:synth piano-key)))
                        (-> instrument
                            (assoc :notes (conj (get instrument :notes)
                                                {:freq freq :on time :off nil :touch-id touch-id}))
                            (assoc-in [:piano-keys freq :on?] true)))
                      instrument)))
   "touchend" (fn
                [{piano-keys :piano-keys :as instrument}
                 {touch-id :touch-id time :time :as event}]
                (let [freqs-on (atom [])
                      instrument (assoc instrument :notes
                                        (doall
                                         (map (fn [{freq :freq :as note}]
                                                (if (= touch-id (note :touch-id))
                                                  (do
                                                    (swap! freqs-on conj freq)
                                                    ;; (println "release")
                                                    (.release ((get piano-keys freq) :synth))
                                                    (assoc note :off time))
                                                  note))
                                              (-> instrument :notes))))]
                  (reduce (fn [inst freq]
                            (assoc-in inst [:piano-keys freq :on?] false))
                          instrument
                          @freqs-on)))})

(defn fire-event-on-instrument
  [instrument event]
  (let [f-instrument (get instrument-fns (:type event))]
    (or (and f-instrument (f-instrument instrument event))
        instrument)))

(defn maybe-init-synths
  [instrument]
  (if (:sound-ready instrument)
    instrument
    (add-synths-to-instrument instrument)))

(defn fire-touch-data-on-instrument
  [instrument data]
  (reduce fire-event-on-instrument
          (maybe-init-synths instrument)
          (touch-data->touches data)))

(defn update-size [instrument canvas-id]
  (let [{w :w h :h :as window-size} (util/get-window-size)]
    (do (util/set-canvas-size! canvas-id window-size)
        (.scrollTo js/window 0 0) ;; Safari leaves window part scrolled down after turn
        (assoc (assoc instrument :h h) :w w))))

(defn create-touch-input-channel
  [canvas-id]
  (async/merge [(util/listen (dom/getElement canvas-id) :touchstart)
                (util/listen (dom/getElement canvas-id) :touchend)]))

(let [canvas-id "canvas"
      c-instrument (chan)
      c-orientation-change (util/listen js/window :orientation-change)
      c-touch (create-touch-input-channel canvas-id)]

  (go
   (let [draw-ctx (util/get-ctx canvas-id)]
     (util/set-canvas-size! canvas-id (util/get-window-size))
     (loop [instrument (<! c-instrument)]
       (let [[data c] (alts! [c-instrument (timeout 16)])]
         (condp = c
           c-instrument (recur data)
           (do (draw-instrument draw-ctx instrument)
               (recur instrument)))))))

  (go
   (loop [instrument (update-size (create-instrument (scales/c-minor)) canvas-id)]
     (>! c-instrument instrument)
     (let [[data c] (alts! [c-touch c-orientation-change (timeout 16)])]
       (condp = c
         c-orientation-change (recur (update-size instrument canvas-id))
         c-touch (recur (fire-touch-data-on-instrument instrument data))
         (recur (assoc instrument :playhead (.getTime (js/Date.))))))))
  )

(ns playmary.one
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :as async :refer [<! put! chan timeout sliding-buffer close!]]
            [playmary.util :as util]
            [playmary.scales :as scales]))

(def timbre js/T)

(def colors [{:note "#676767" :light "#6DA0CB" :dark "#000000"}
             {:note "#929292" :light "#A76AB9" :dark "#1E1E1E"}
             {:note "#B9B9B9" :light "#BB67A2" :dark "#3D3D3D"}
             {:note "#DCDCDC" :light "#C55D83" :dark "#5C5C5C"}
             {:note "#FFFFFF" :light "#D35E4C" :dark "#7A7A7A"}
             {:note "#000000" :light "#E18C43" :dark "#999999"}
             {:note "#393939" :light "#E1B040" :dark "#B9B9B9"}])

(defn piano-key-width
  [{piano-keys :piano-keys w :w}]
  (.round js/Math (/ w (count piano-keys))))

(defn latest-note
  [instrument freq]
  (some (fn [note] (and (= freq (-> note :freq)) note))
        (-> instrument :notes)))

(defn t->px
  [{start :start px-per-ms :px-per-ms} t]
  (* px-per-ms (- t start)))

(defn note-rect
  [{on :on off :off freq :freq :as note}
   {px-per-ms :px-per-ms playhead :playhead :as instrument}]
  (let [piano-key-w (piano-key-width instrument)]
    {:x (* piano-key-w (get-in instrument [:piano-keys freq :n]))
     :y (+ (t->px instrument on)
           (/ (-> instrument :h) 2))
     :w piano-key-w
     :h (- (t->px instrument (or off playhead))
           (t->px instrument on))}))

(defn screen-rect
  [{w :w h :h playhead :playhead :as instrument}]
  {:x 0 :y (t->px instrument playhead) :w w :h h})

(defn draw-note
  [draw-ctx instrument note]
  (let [{x :x y :y w :w h :h} (note-rect note instrument)]
    (set! (.-fillStyle draw-ctx) "white")
    (.fillRect draw-ctx x y w h)))

(defn colliding?
  [r1 r2]
  (not (or (< (+ (:x r1) (:w r1)) (:x r2))
           (< (+ (:y r1) (:h r1)) (:y r2))
           (> (:x r1) (+ (:x r2) (:w r2)))
           (> (:y r1) (+ (:y r2) (:h r2))))))

(defn on-screen?
  [instrument note]
  (colliding? (note-rect note instrument)
              (screen-rect instrument)))

(defn draw-notes
  [draw-ctx instrument]
  (doseq [note (filter (partial on-screen? instrument)
                       (-> instrument :notes))]
    (draw-note draw-ctx instrument note)))

(defn draw-piano-keys
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (let [piano-keys (-> instrument :piano-keys)
        piano-key-w (piano-key-width instrument)]
    (doseq [[n [freq piano-key]] (map-indexed vector piano-keys)]
      (set! (.-fillStyle draw-ctx)
            ((if (piano-key :on?) :light :dark) (nth colors (mod n (count colors)))))
      (.fillRect draw-ctx
                 (* n piano-key-w)
                 (t->px instrument playhead)
                 piano-key-w h))))

(defn draw-instrument
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (.save draw-ctx)
  (.translate draw-ctx 0 (-> (t->px instrument playhead) -))
  (.clearRect draw-ctx 0 0 w h)
  (draw-piano-keys draw-ctx instrument)
  (draw-notes draw-ctx instrument)
  (.restore draw-ctx))

(defn touch->note
  [x instrument]
  (let [note-index (.floor js/Math (/ x (piano-key-width instrument)))]
    (nth (-> instrument :piano-keys keys) note-index)))

(defn create-note-synth
  [freq]
  (timbre "adsr"
          (js-obj "a" 5 "d" 10000 "s" 0 "r" 500)
          (timbre "fami" (js-obj "freq" freq "mul" 0.1))))

(defn create-instrument
  [scale]
  (let [start (.getTime (js/Date.))]
    {:piano-keys (into (sorted-map) (map-indexed (fn [i freq] [freq {:n i :on? false}])
                                                 scale))
     :notes ()
     :w 0 :h 0 :sound-ready false
     :px-per-ms 0.04
     :start start
     :playhead start}))

(defn add-synths-to-instrument
  [instrument]
  (assoc (reduce (fn [a x] (assoc-in a [:piano-keys x :synth] (create-note-synth x)))
                 instrument
                 (-> instrument :piano-keys keys))
    :sound-ready true))

(defn touch-data->touches [touch-data]
  (let [event (.-event_ touch-data)
        touches (js->clj (.-changedTouches event) :keywordize-keys true)]
    (map (fn [x] {:type (.-type event)
                  :touch-id (:identifier x)
                  :clientX (:clientX x)
                  :time (.-timeStamp event)})
         (for [x (range (:length touches))] ((keyword (str x)) touches)))))

(defn touch->freq
  [instrument touch]
  (touch->note (get touch :clientX)
               instrument))

(def instrument-fns
  {"touchstart" (fn
                  [instrument {touch-id :touch-id time :time :as event}]
                  (let [freq (touch->freq instrument event)
                        piano-key (get-in instrument [:piano-keys freq])]
                    (if-not (:on? piano-key)
                      (do
                        ;; (println "play")
                        (.play (.bang (:synth piano-key)))
                        (-> instrument
                            (assoc :notes (conj (get instrument :notes)
                                                {:freq freq :on time :off nil :touch-id touch-id}))
                            (assoc-in [:piano-keys freq :on?] true)))
                      instrument)))
   "touchend" (fn
                [{piano-keys :piano-keys :as instrument}
                 {touch-id :touch-id time :time :as event}]
                (let [freqs-on (atom [])
                      instrument (assoc instrument :notes
                                        (doall
                                         (map (fn [{freq :freq :as note}]
                                                (if (= touch-id (note :touch-id))
                                                  (do
                                                    (swap! freqs-on conj freq)
                                                    ;; (println "release")
                                                    (.release ((get piano-keys freq) :synth))
                                                    (assoc note :off time))
                                                  note))
                                              (-> instrument :notes))))]
                  (reduce (fn [inst freq]
                            (assoc-in inst [:piano-keys freq :on?] false))
                          instrument
                          @freqs-on)))})

(defn fire-event-on-instrument
  [instrument event]
  (let [f-instrument (get instrument-fns (:type event))]
    (or (and f-instrument (f-instrument instrument event))
        instrument)))

(defn maybe-init-synths
  [instrument]
  (if (:sound-ready instrument)
    instrument
    (add-synths-to-instrument instrument)))

(defn fire-touch-data-on-instrument
  [instrument data]
  (reduce fire-event-on-instrument
          (maybe-init-synths instrument)
          (touch-data->touches data)))

(defn update-size [instrument canvas-id]
  (let [{w :w h :h :as window-size} (util/get-window-size)]
    (do (util/set-canvas-size! canvas-id window-size)
        (.scrollTo js/window 0 0) ;; Safari leaves window part scrolled down after turn
        (assoc (assoc instrument :h h) :w w))))

(defn create-touch-input-channel
  [canvas-id]
  (async/merge [(util/listen (dom/getElement canvas-id) :touchstart)
                (util/listen (dom/getElement canvas-id) :touchend)]))

(let [canvas-id "canvas"
      c-instrument (chan)
      c-orientation-change (util/listen js/window :orientation-change)
      c-touch (create-touch-input-channel canvas-id)
      frame-delay 30]

  (go
   (let [draw-ctx (util/get-ctx canvas-id)]
     (util/set-canvas-size! canvas-id (util/get-window-size))
     (loop [instrument (<! c-instrument)]
       (let [[data c] (alts! [c-instrument (timeout frame-delay)])]
         (condp = c
           c-instrument (recur data)
           (do (draw-instrument draw-ctx instrument)
               (recur instrument)))))))

  (go
   (loop [instrument (update-size (create-instrument (scales/c-minor)) canvas-id)]
     (>! c-instrument instrument)
     (let [[data c] (alts! [c-touch c-orientation-change (timeout frame-delay)])]
       (condp = c
         c-orientation-change (recur (update-size instrument canvas-id))
         c-touch (recur (fire-touch-data-on-instrument instrument data))
         (recur (assoc instrument :playhead (.getTime (js/Date.))))))))
  )

Make var for frame delay

Make var for frame delay