;;; Interpreters using the memory subsystem

;;; This file contains experimental interpreters that use the memory
;;; subsystem.  I write these interpreters to try the memory subsystem
;;; in a more realistic context than the unit tests.

;;; Currently I'm thinking of implementing a simple
;;; continuation-passing interpreter (that, obviously, also has to be
;;; a storage-passing interpreter).  I'm not sure whether to implement
;;; mutable variables in this interpreter, since this would mean that
;;; all parameters have to be boxed and passed on the heap.  And since
;;; we never release storage on the heap this would probably
;;; prohibitively wasteful.  In a compiler we can avoid this by
;;; performing a closure analysis pass.  Of course, the "interpreters"
;;; could also use a preprocessing pass that performs these kinds of
;;; analysis, but then the interpreters would mutate into compilers
;;; with a different IR.  That's not really the current plan, but
;;; we'll see how things work out.  --tc

(ns revue.interpreter
  (:require [revue.util :as util]
            [revue.mem :as mem]))

;;; Utilities
;;; =========

(defn warn
  "Warn about a problem encountered by an interpreter."
  [msg]
  (util/warn "Interpreter warning:" msg))

;;; Environments for the interpreter
;;; ================================

;;; The interpreters use a simple Clojure map as environment.

;;; We define function to create and update the global environment
;;; which are used to initialize the interpreter.  The interpreter
;;; only uses one non-standard function for manipulating environment:
;;; `extend-env' is called when a new lexical scope is entered and
;;; returns the previous environment extended with the new bindings.
;;; To update the environment we simply use `assoc', to look up values
;;; we use `get'.

(defn empty-env
  "Returns an empty environment."
  []
  {})

(def ^:dynamic *initial-bindings* (atom {}))

(defn clear-initial-bindings
  "Set the value of `*initial-bindings*' to the empty map."
  []
  (reset! *initial-bindings* {}))

(defn define-global
  "Defines a global variable, or redefines it if it already exists"
  [name value]
  (swap! *initial-bindings* assoc name value))

(defn global-env
  "Returns the global environment for the interpreter."
  []
  @*initial-bindings*)

(defn extend-env [env keys values]
  (merge env (zipmap keys values)))

;;; Procedures for the interpreter
;;; ===============================

;;; We define a protocol that specifies how the interpreter handles
;;; procedures, and record types for representing interpreted
;;; procedures as well as primitive procedures.

;;; TODO Protocol

;;; An interpreted procedure.  Its `code' is the source code to be
;;; interpreted; `params' is a list of parameter names; `name' is the
;;; name of the procedure (as clojure symbol), or `nil' if the
;;; procedure is anonymous.
;;;
(defrecord Proc [code env params name])

;;; A primitive procedure.  Its `code' is a Clojure function that
;;; should be invoked.  The `name' and `params' fields are as for
;;; `Proc'
;;;
(defrecord Prim [code name params])

;;; A simple state-passing interpreter
;;; ==================================

;;; The core of the simple interpreter is a function `step' that
;;; performs one step of the evaluation process.  It operates on an
;;; iterpreter state that contains all information required by the
;;; interpreter; i.e., its sole argument is an interpreter state and
;;; its result is again an interpreter state.

;;; The state contains the following elements:
;;; * the form to be executed
;;; * the environment for the form
;;; * the store
;;; * a continuation
;;; * The value returned by the previous evaluation step

;;; Not sure whether that is a good idea, since we want to share as
;;; much data as possible, and introducing a record will probably
;;; store each state in a fresh object.
;;; TODO: check this
;;;
#_(defrecord State [form env store cont value])

(defn initial-store []
  [])

(defn initial-state
  "Create an initial state for the interpreter"
  ([form]
     (initial-state form (global-env)))
  ([form env]
     #_(->State form env (initial-store) nil nil)
     {:form form :env env :store (initial-store)
      :cont nil :value nil}))

;;; TODO: Refactor this into multi-methods

;;; TODO: Should we clear the :value field for forms which have no
;;; return value on their own?

(defn step
  "Perform a single step of the interpreter and return a new state"
  [{:keys [form env store cont value] :as state}]
  (cond
   ;;
   (nil? form)
   (if cont
     (assoc state :form (first cont) :cont (next cont))
     (assoc state :value nil))
   ;;
   (symbol? form)
   (assoc state :form nil :value (get env form))
   ;;
   (util/atomic? form)
   (assoc state :form nil :value form)
   ;; TODO: integrate macros here...
   ;;
   :else
   (case (first form)
     ;; Quote
     quote
     (assoc state :form nil :value (rest form))
     ;; Sequence
     begin
     (cond
      ;; An empty begin evaluates to false.
      (empty? (rest form))
      (assoc state :form nil :value false)
      ;; A begin containing a single form is equivalent to that form.
      (util/singleton? (rest form))
      (assoc state :form (nth form 1))
      :else
      ;; We have a begin with at least two subforms.  Extract the
      ;; first subform, push the remaining forms onto the
      ;; continuation.
      (assoc state
        :form (nth form 1)
        :cont (cons (cons 'begin (nthrest form 2)) cont)))
     ;; If: Compute the condition and add a continuation that uses
     ;; this value to choose the correct branch.
     if
     (assoc state
       :form (nth form 1)
       :cont (cons (cons ::if (nthrest form 2)) cont))
     ;; The continuation function for the `if' operator
     ::if
     (assoc state
       :form (if value
               (nth form 1)
               (nth form 2)))
     ;; Function definition
     lambda
     (assoc state
       :form nil
       :value (->Proc (util/maybe-add 'begin (nthrest form 2))
                      env
                      (vec (nth form 1))
                      nil))
     ;; If we arrive here, we have a function application.  First we
     ;; need to pick off the continuation functons for function
     ;; applications, though.
     ::eval-args
     (if (empty? (nthrest form 2)) ;; TODO: Check that new form evaluates function?
       (assoc state
         :form (first cont)
         :cont (next cont)
         :value (nth form 1))
       (assoc state
         :form (nth form 2)
         :cont `((::collect-arg ~(nth form 1) ~@(nthrest form 3)) ~@cont)))
     ::collect-arg
     (assoc state
       :form `(::eval-args ~(conj (nth form 1) value) ~@(nthrest form 2)))
     ::eval-proc
     (assoc state
       :form (nth form 1)
       :cont `((::apply ~value) ~@cont))
     ::apply
     ;; TODO: Need to handle primitive procedures; define protocol for
     ;; application
     (let [proc value
           [_ args] form]
       (assoc state
         :form (:code proc)
         :env (extend-env (:env proc) (:params proc) (nth form 1))
         :cont `((::reset-env ~env) ~@cont)))
     ::reset-env
     (assoc state
       :form nil
       :env (nth form 1))
     (let [[proc & args] form]
       (assoc state
         :form `(::eval-args [] ~@args)
         :cont `((::eval-proc ~proc) ~@cont)
         :value [])))))

(defn run-n-steps
  ([form]
     (run-n-steps form 100))
  ([form n]
     (clojure.pprint/pprint
      (take n (take-while
               (fn [{:keys [form cont value]}] (or form cont value))
               (iterate step (initial-state form)))))))

;;; Evaluate this (e.g., with C-x C-e in Cider) to run the tests for
;;; this namespace:
;;; (clojure.test/run-tests 'revue.interpreter-test)
;;; Evaluate this to run the test for all namespaces:
;;; (clojure.test/run-all-tests #"^revue\..*-test")

;;; Interpreters using the memory subsystem

;;; This file contains experimental interpreters that use the memory
;;; subsystem.  I write these interpreters to try the memory subsystem
;;; in a more realistic context than the unit tests.

;;; Currently I'm thinking of implementing a simple
;;; continuation-passing interpreter (that, obviously, also has to be
;;; a storage-passing interpreter).  I'm not sure whether to implement
;;; mutable variables in this interpreter, since this would mean that
;;; all parameters have to be boxed and passed on the heap.  And since
;;; we never release storage on the heap this would probably
;;; prohibitively wasteful.  In a compiler we can avoid this by
;;; performing a closure analysis pass.  Of course, the "interpreters"
;;; could also use a preprocessing pass that performs these kinds of
;;; analysis, but then the interpreters would mutate into compilers
;;; with a different IR.  That's not really the current plan, but
;;; we'll see how things work out.  --tc

(ns revue.interpreter
  (:require [revue.util :as util]
            [revue.mem :as mem]))

;;; Utilities
;;; =========

(defn warn
  "Warn about a problem encountered by an interpreter."
  [msg]
  (util/warn "Interpreter warning:" msg))

;;; Environments for the interpreter
;;; ================================

;;; The interpreters use a simple Clojure map as environment.

;;; We define function to create and update the global environment
;;; which are used to initialize the interpreter.  The interpreter
;;; only uses one non-standard function for manipulating environment:
;;; `extend-env' is called when a new lexical scope is entered and
;;; returns the previous environment extended with the new bindings.
;;; To update the environment we simply use `assoc', to look up values
;;; we use `get'.

(defn empty-env
  "Returns an empty environment."
  []
  {})

(def ^:dynamic *initial-bindings* (atom {}))

(defn clear-initial-bindings
  "Set the value of `*initial-bindings*' to the empty map."
  []
  (reset! *initial-bindings* {}))

(defn define-global
  "Defines a global variable, or redefines it if it already exists"
  [name value]
  (swap! *initial-bindings* assoc name value))

(defn global-env
  "Returns the global environment for the interpreter."
  []
  @*initial-bindings*)

(defn extend-env [env keys values]
  (merge env (zipmap keys values)))

;;; Procedures for the interpreter
;;; ===============================

;;; We define a protocol IProc that specifies how the interpreter
;;; handles procedures, and record types for representing interpreted
;;; procedures as well as primitive procedures.

(defprotocol IProc
  "Procedures that can be invoked by the interpreter"
  (apply-proc [this args state]
    "Apply the procedure to `args' and `state', and return a new
    state"))

;;; An interpreted procedure.  Its `code' is the source code to be
;;; interpreted; `params' is a list of parameter names; `name' is the
;;; name of the procedure (as clojure symbol), or `nil' if the
;;; procedure is anonymous.
;;;
(defrecord Proc [code env params name]
  IProc
  (apply-proc [this args state]
    (assoc state
      :form (:code this)
      :env (extend-env (:env this) (:params this) args)
      :cont `((::reset-env ~(:env state)) ~@(:cont state)))))

;;; A primitive procedure.  Its `code' is a Clojure function that
;;; should be invoked.  The `params' and `name' fields are as for
;;; `Proc'
;;;
(defrecord Prim [code params name]
  IProc
  (apply-proc [this args state]
    ((:code this) args state)))

(defn define-nary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[& args]
            name)))

(defn define-binary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[x y]
            name)))

(define-nary-global '+ +)
(define-nary-global '- -)
(define-nary-global '* *)
(define-nary-global '/ /)

(define-binary-global '< <)
(define-binary-global '> >)
(define-binary-global '<= <=)
(define-binary-global '>= >=)

;;; A simple state-passing interpreter
;;; ==================================

;;; The core of the simple interpreter is a function `step' that
;;; performs one step of the evaluation process.  It operates on an
;;; iterpreter state that contains all information required by the
;;; interpreter; i.e., its sole argument is an interpreter state and
;;; its result is again an interpreter state.

;;; The state contains the following elements:
;;; * the form to be executed
;;; * the environment for the form
;;; * the store
;;; * a continuation
;;; * The value returned by the previous evaluation step

;;; Not sure whether that is a good idea, since we want to share as
;;; much data as possible, and introducing a record will probably
;;; store each state in a fresh object.
;;; TODO: check this
;;;
#_(defrecord State [form env store cont value])

(defn initial-store []
  [])

(defn initial-state
  "Create an initial state for the interpreter"
  ([form]
     (initial-state form (global-env)))
  ([form env]
     #_(->State form env (initial-store) nil nil)
     {:form form :env env :store (initial-store)
      :cont nil :value nil}))

;;; TODO: Refactor this into multi-methods

;;; TODO: Should we clear the :value field for forms which have no
;;; return value on their own?

(defn step
  "Perform a single step of the interpreter and return a new state"
  [{:keys [form env store cont value] :as state}]
  (cond
   ;;
   (nil? form)
   (if cont
     (assoc state :form (first cont) :cont (next cont))
     (assoc state :value nil))
   ;;
   (symbol? form)
   (assoc state :form nil :value (get env form))
   ;;
   (util/atomic? form)
   (assoc state :form nil :value form)
   ;; TODO: integrate macros here...
   ;;
   :else
   (case (first form)
     ;; Quote
     quote
     (assoc state :form nil :value (rest form))
     ;; Sequence
     begin
     (cond
      ;; An empty begin evaluates to false.
      (empty? (rest form))
      (assoc state :form nil :value false)
      ;; A begin containing a single form is equivalent to that form.
      (util/singleton? (rest form))
      (assoc state :form (nth form 1))
      :else
      ;; We have a begin with at least two subforms.  Extract the
      ;; first subform, push the remaining forms onto the
      ;; continuation.
      (assoc state
        :form (nth form 1)
        :cont (cons (cons 'begin (nthrest form 2)) cont)))
     ;; If: Compute the condition and add a continuation that uses
     ;; this value to choose the correct branch.
     if
     (assoc state
       :form (nth form 1)
       :cont (cons (cons ::if (nthrest form 2)) cont))
     ;; The continuation function for the `if' operator
     ::if
     (assoc state
       :form (if value
               (nth form 1)
               (nth form 2)))
     ;; Function definition
     lambda
     (assoc state
       :form nil
       :value (->Proc (util/maybe-add 'begin (nthrest form 2))
                      env
                      (vec (nth form 1))
                      nil))
     ;; If we arrive here, we have a function application.  First we
     ;; need to pick off the continuation functons for function
     ;; applications, though.
     ::eval-args
     (if (empty? (nthrest form 2)) ;; TODO: Check that new form evaluates function?
       (assoc state
         :form (first cont)
         :cont (next cont)
         :value (nth form 1))
       (assoc state
         :form (nth form 2)
         :cont `((::collect-arg ~(nth form 1) ~@(nthrest form 3)) ~@cont)))
     ::collect-arg
     (assoc state
       :form `(::eval-args ~(conj (nth form 1) value) ~@(nthrest form 2)))
     ::eval-proc
     (assoc state
       :form (nth form 1)
       :cont `((::apply ~value) ~@cont))
     ::apply
     ;; TODO: Need to handle primitive procedures; define protocol for
     ;; application
     (let [proc value
           [_ args] form]
       (apply-proc proc args state))
     ::reset-env
     (assoc state
       :form nil
       :env (nth form 1))
     (let [[proc & args] form]
       (assoc state
         :form `(::eval-args [] ~@args)
         :cont `((::eval-proc ~proc) ~@cont)
         :value [])))))

(defn run-n-steps
  ([form]
     (run-n-steps form 100))
  ([form n]
     (let [result (take n (take-while
                           (fn [{:keys [form cont value]}] (or form cont value))
                           (iterate step (initial-state form))))]
       (clojure.pprint/pprint result)
       (last result))))

(defn interp
  ([form]
     (interp form 100000))
  ([form n]
     (let [result (take n (take-while
                           (fn [{:keys [form cont value]}] (or form cont value))
                           (iterate step (initial-state form))))]
       (dissoc (last result) :env))))

;;; Try for example the factorial function:
(comment
  (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
            (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 1000N))
  )

;;; Evaluate this (e.g., with C-x C-e in Cider) to run the tests for
;;; this namespace:
;;; (clojure.test/run-tests 'revue.interpreter-test)
;;; Evaluate this to run the test for all namespaces:
;;; (clojure.test/run-all-tests #"^revue\..*-test")

Add support for primitive functions

Add support for primitive functions


(ns cuttle.projects
  (:require-macros
    [cljs.core.async.macros :refer [go]])
  (:require
    [cljs.core.async :refer [<! put! close! chan]]
    [cljs.reader :refer [read-string]]
    [clojure.string :refer [replace]]
    [cuttle.cljsbuild.config :refer [extract-options]]
    [cuttle.exec :refer [get-cljsbuild-with-profiles]]
    [cuttle.util :refer [file-exists? js-log log path-join path-dirname]]))

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

(declare write-workspace!)

;;------------------------------------------------------------------------------
;; Project Parsing
;;------------------------------------------------------------------------------

(defn- add-default-id-to-build
  [i build]
  (if-not (:id build)
    (assoc build :id (str "build " i))
    build))

(defn normalize-cljsbuild-opts
  [opts]
  (let [opts (extract-options {:cljsbuild opts})
        builds (->> (:builds opts)
                    (map-indexed add-default-id-to-build))]
    (assoc opts :builds builds)))

(defn- parse-project-file
  "Parse the project file without considering profiles."
  [contents filename]
  (let [contents (replace contents "#(" "(") ;; prevent "Could not find tag parser for" error
        prj1 (read-string contents)
        project (apply hash-map (drop 3 prj1))
        cljsbuild (when-let [opts (:cljsbuild project)]
                    (normalize-cljsbuild-opts opts))]
    (assoc project
           :cljsbuild cljsbuild
           :filename filename
           :name (name (nth prj1 1))
           :version (nth prj1 2))))

(defn- fix-project-with-profiles
  "Correct the given project file with cljsbuild options from profiles."
  [project]
  (go
    (let [filename (:filename project)
          path (path-dirname filename)
          cljsbuild (<! (get-cljsbuild-with-profiles path))
          cljsbuild2 (normalize-cljsbuild-opts cljsbuild)]
      (assoc project :cljsbuild cljsbuild2))))

;; TODO:
;; - need to do some quick validation of project.clj
;;   (ie: does it have :cljsbuild?)
(defn load-project-file [filename]
  (let [c (chan)]
    (go
      (let [file-contents (.readFileSync fs filename (js-obj "encoding" "utf8"))
            project (parse-project-file file-contents filename)]
        (put! c project)
        (when-not (:cljsbuild project)
          (put! c (<! (fix-project-with-profiles project))))
        (close! c)))
    c))

;;------------------------------------------------------------------------------
;; Project Workspace Initialization
;;------------------------------------------------------------------------------

(def workspace-filename)

(defn- set-workspace-filename!
  [app-data-path]
  (set! workspace-filename (path-join app-data-path "projects.json")))

(defn- create-default-projects-file!
  [app-data-path projects-file]
  (when-not (file-exists? app-data-path)
    (.mkdirSync fs app-data-path))
  (.writeFileSync fs projects-file
    (.stringify js/JSON (array) nil 2)
    (js-obj "encoding" "utf8")))

(defn load-workspace!
  [app-data-path]
  (set-workspace-filename! app-data-path)
  ;; TODO: need to do some quick validation on projects.json format here
  (when-not (file-exists? workspace-filename)
    (create-default-projects-file! app-data-path workspace-filename))
  (let [filenames1 (js->clj (js/require workspace-filename))
        filenames2 (vec (filter file-exists? filenames1))]

    ;; re-write projects.json if it contains a project.clj file that no longer exists
    ;; TODO: add some UX around this to inform the user that this has happened, GitHub Issue #45
    (when (not= filenames1 filenames2)
      (write-workspace! filenames2))

    filenames2))

;;------------------------------------------------------------------------------
;; Project Workspace Modification
;;------------------------------------------------------------------------------

(defn- read-workspace
  []
  (let [content (.readFileSync fs workspace-filename "utf8")
        js-projects (.parse js/JSON content)]
    (js->clj js-projects)))

(defn- write-workspace!
  [projects]
  (let [js-projects (clj->js projects)
        content (.stringify js/JSON js-projects nil 2)
        options #js {:encoding "utf8"}]
    (.writeFileSync fs workspace-filename content options)))

(defn add-to-workspace!
  [filename]
  (let [projects (read-workspace)
        in-projects? (get (into #{} projects) filename)
        should-add? (not in-projects?)]
    (when should-add?
      (write-workspace! (conj projects filename)))
    should-add?))

(defn remove-from-workspace!
  [filename]
  (let [projects (read-workspace)
        in-projects? (get (into #{} projects) filename)]
    (when in-projects?
      (write-workspace! (remove #{filename} projects)))))

(ns cuttle.projects
  (:require-macros
    [cljs.core.async.macros :refer [go]])
  (:require
    [cljs.core.async :refer [<! put! close! chan]]
    [cljs.reader :refer [read-string]]
    [clojure.string :refer [replace]]
    [cuttle.cljsbuild.config :refer [extract-options]]
    [cuttle.exec :refer [get-cljsbuild-with-profiles]]
    [cuttle.log :refer [log-info]]
    [cuttle.util :refer [file-exists? js-log log path-join path-dirname]]))

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

(declare write-workspace!)

;;------------------------------------------------------------------------------
;; Project Parsing
;;------------------------------------------------------------------------------

(defn- add-default-id-to-build
  [i build]
  (if-not (:id build)
    (assoc build :id (str "build " i))
    build))

(defn normalize-cljsbuild-opts
  [opts]
  (let [opts (extract-options {:cljsbuild opts})
        builds (->> (:builds opts)
                    (map-indexed add-default-id-to-build))]
    (assoc opts :builds builds)))

(defn- parse-project-file
  "Parse the project file without considering profiles."
  [contents filename]
  (log-info "parsing project:" filename)
  (let [contents (replace contents "#(" "(") ;; prevent "Could not find tag parser for" error
        prj1 (read-string contents)
        project (apply hash-map (drop 3 prj1))
        cljsbuild (when-let [opts (:cljsbuild project)]
                    (normalize-cljsbuild-opts opts))]
    (assoc project
           :cljsbuild cljsbuild
           :filename filename
           :name (name (nth prj1 1))
           :version (nth prj1 2))))

(defn- fix-project-with-profiles
  "Correct the given project file with cljsbuild options from profiles."
  [project]
  (log-info "parsing project with :dev profile:" (:filename project))
  (go
    (let [filename (:filename project)
          path (path-dirname filename)
          cljsbuild (<! (get-cljsbuild-with-profiles path))
          cljsbuild2 (normalize-cljsbuild-opts cljsbuild)]
      (assoc project :cljsbuild cljsbuild2))))

;; TODO:
;; - need to do some quick validation of project.clj
;;   (ie: does it have :cljsbuild?)
(defn load-project-file [filename]
  (let [c (chan)]
    (go
      (let [file-contents (.readFileSync fs filename (js-obj "encoding" "utf8"))
            project (parse-project-file file-contents filename)]
        (put! c project)
        (when-not (:cljsbuild project)
          (put! c (<! (fix-project-with-profiles project))))
        (close! c)))
    c))

;;------------------------------------------------------------------------------
;; Project Workspace Initialization
;;------------------------------------------------------------------------------

(def workspace-filename)

(defn- set-workspace-filename!
  [app-data-path]
  (set! workspace-filename (path-join app-data-path "projects.json")))

(defn- create-default-projects-file!
  [app-data-path projects-file]
  (when-not (file-exists? app-data-path)
    (.mkdirSync fs app-data-path))
  (.writeFileSync fs projects-file
    (.stringify js/JSON (array) nil 2)
    (js-obj "encoding" "utf8")))

(defn load-workspace!
  [app-data-path]
  (set-workspace-filename! app-data-path)
  ;; TODO: need to do some quick validation on projects.json format here
  (when-not (file-exists? workspace-filename)
    (create-default-projects-file! app-data-path workspace-filename))
  (let [filenames1 (js->clj (js/require workspace-filename))
        filenames2 (vec (filter file-exists? filenames1))]

    ;; re-write projects.json if it contains a project.clj file that no longer exists
    ;; TODO: add some UX around this to inform the user that this has happened, GitHub Issue #45
    (when (not= filenames1 filenames2)
      (write-workspace! filenames2))

    filenames2))

;;------------------------------------------------------------------------------
;; Project Workspace Modification
;;------------------------------------------------------------------------------

(defn- read-workspace
  []
  (let [content (.readFileSync fs workspace-filename "utf8")
        js-projects (.parse js/JSON content)]
    (js->clj js-projects)))

(defn- write-workspace!
  [projects]
  (let [js-projects (clj->js projects)
        content (.stringify js/JSON js-projects nil 2)
        options #js {:encoding "utf8"}]
    (.writeFileSync fs workspace-filename content options)))

(defn add-to-workspace!
  [filename]
  (let [projects (read-workspace)
        in-projects? (get (into #{} projects) filename)
        should-add? (not in-projects?)]
    (when should-add?
      (write-workspace! (conj projects filename)))
    should-add?))

(defn remove-from-workspace!
  [filename]
  (let [projects (read-workspace)
        in-projects? (get (into #{} projects) filename)]
    (when in-projects?
      (write-workspace! (remove #{filename} projects)))))

add logging to project parsing

add logging to project parsing


(ns braid.client.quests.list)

(def quests
  [; conversations

   {:id :quest/conversation-new
    :name "Start a conversation"
    :icon \uf0e6
    :goal 3
    :listener (fn [state [event args]]
                (= event :quests/show-quest-instructions))}

   {:id :quest/conversation-tag
    :name "Tag a conversation"
    :icon \uf02c
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-reply
    :name "Reply to a conversation"
    :icon \uf112
    :goal 3
    :listener (fn [state [event args]]
                (= event :new-message))}

   {:id :quest/conversation-private
    :name "Start a private conversation"
    :icon \uf21b
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-mute
    :name "Close a conversation"
    :icon \uf00d
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-mute
    :name "Mute a conversation"
    :icon \uf070
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-close-ctrlx
    :name "Close a conversation with CTRL X"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-close-esc
    :name "Close a conversation with ESC"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; recent

   {:id :quest/recent-view
    :name "View your recent closed messages"
    :icon \uf1da
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; messages

   {:id :quest/message-emoji
    :name "Send a message with an emoji"
    :icon \uf118
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-link
    :name "Send a message with a link"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-mention-user
    :name "Mention a user in a message"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-mention-tag
    :name "Mention a tag in a message"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-upload-file-button
    :name "Upload a file (via button)"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-upload-file-drag
    :name "Upload a file (via drag n drop)"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; search

   {:id :quest/search-word
    :name "Search for an old conversation by word"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/search-tag
    :name "Search for an old conversation by tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; profile

   {:id :quest/set-avatar
    :name "Set your avatar"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/set-profile
    :name "Set your profile"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/update-nickname
    :name "Update your nickname"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/verify-email
    :name "Verify your email"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; invite

   {:id :quest/invite
    :name "Invite a user to your group"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; tags

   {:id :quest/tags-review
    :name "Review your subscriptions"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-subscribe
    :name "Subscribe to a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)
    }
   {:id :quest/tag-unsubscribe
    :name "Unsubscribe from a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-create
    :name "Create a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-create-autocomplete
    :name "Create a tag using the autocomplete"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/archives
    :name "Look into a tag's archives"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; settings

   {:id :review-digest-options
    :name "Review your email preferences"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; bots

   {:id :quest/bot-add
    :name "Add a bot to your group"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; clients

   {:id :quest/desktop-client
    :name "Try the Braid desktop app"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/mobile-client
    :name "Try the Braid mobile app"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/web-client
    :name "Try the Braid web app"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; groups

   {:id :quest/groups-create
    :name "Create another group"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/groups-explore
    :name "Explore the available public groups"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/groups-join-public
    :name "Join a public group"
    :goal 3
    :listener (fn [state [event args]]
                false)}])

(ns braid.client.quests.list)

(def quests
  [; conversations

   {:id :quest/conversation-new
    :name "Start a conversation"
    :icon \uf0e6
    :goal 3
    :listener (fn [state [event args]]
                (= event :quests/show-quest-instructions))}])

(def disabled-quests
  [; conversations

   {:id :quest/conversation-tag
    :name "Tag a conversation"
    :icon \uf02c
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-reply
    :name "Reply to a conversation"
    :icon \uf112
    :goal 3
    :listener (fn [state [event args]]
                (= event :new-message))}

   {:id :quest/conversation-private
    :name "Start a private conversation"
    :icon \uf21b
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-mute
    :name "Close a conversation"
    :icon \uf00d
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-mute
    :name "Mute a conversation"
    :icon \uf070
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-close-ctrlx
    :name "Close a conversation with CTRL X"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/conversation-close-esc
    :name "Close a conversation with ESC"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; recent

   {:id :quest/recent-view
    :name "View your recent closed messages"
    :icon \uf1da
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; messages

   {:id :quest/message-emoji
    :name "Send a message with an emoji"
    :icon \uf118
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-link
    :name "Send a message with a link"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-mention-user
    :name "Mention a user in a message"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-mention-tag
    :name "Mention a tag in a message"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-upload-file-button
    :name "Upload a file (via button)"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/message-upload-file-drag
    :name "Upload a file (via drag n drop)"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; search

   {:id :quest/search-word
    :name "Search for an old conversation by word"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/search-tag
    :name "Search for an old conversation by tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; profile

   {:id :quest/set-avatar
    :name "Set your avatar"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/set-profile
    :name "Set your profile"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/update-nickname
    :name "Update your nickname"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/verify-email
    :name "Verify your email"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; invite

   {:id :quest/invite
    :name "Invite a user to your group"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; tags

   {:id :quest/tags-review
    :name "Review your subscriptions"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-subscribe
    :name "Subscribe to a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)
    }
   {:id :quest/tag-unsubscribe
    :name "Unsubscribe from a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-create
    :name "Create a tag"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/tag-create-autocomplete
    :name "Create a tag using the autocomplete"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   {:id :quest/archives
    :name "Look into a tag's archives"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; settings

   {:id :review-digest-options
    :name "Review your email preferences"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; bots

   {:id :quest/bot-add
    :name "Add a bot to your group"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; clients

   {:id :quest/desktop-client
    :name "Try the Braid desktop app"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/mobile-client
    :name "Try the Braid mobile app"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/web-client
    :name "Try the Braid web app"
    :goal 3
    :listener (fn [state [event args]]
                false)}

   ; groups

   {:id :quest/groups-create
    :name "Create another group"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/groups-explore
    :name "Explore the available public groups"
    :goal 3
    :listener (fn [state [event args]]
                false)}
   {:id :quest/groups-join-public
    :name "Join a public group"
    :goal 3
    :listener (fn [state [event args]]
                false)}])

Disable unimplemented quests

Disable unimplemented quests


(ns brainbot.nozzle.esconnect
  (:require [clojure.pprint :refer [pprint]])
  (:require [clojure.string :as string])
  (:require [clojure.tools.logging :as logging])
  (:require [langohr.core :as rmq]
            [langohr.consumers :as lcons]
            [langohr.basic :as lb])
  (:require [clj-time.core :as tcore]
            [clj-time.coerce :as tcoerce])
  (:require [brainbot.nozzle.misc :as misc]
            [brainbot.nozzle.path :as path]
            [brainbot.nozzle.sys :as sys]
            [brainbot.nozzle.worker :as worker]
            [brainbot.nozzle.inihelper :as inihelper]
            [brainbot.nozzle.dynaload :as dynaload]
            [brainbot.nozzle.mqhelper :as mqhelper])
  (:require [robert.bruce :refer [try-try-again]])
  (:require [clojurewerkz.elastisch.rest.document :as esd]
            [clojurewerkz.elastisch.rest :as esr]
            [clojurewerkz.elastisch.rest.index :as esi]))

(def ^:private token-document-null-value "NOBODY")

;; (esr/connect! "http://127.0.0.1:9200")
(let [parent {:index "not_analyzed", :type "string", :store "yes"}
      token {:index "not_analyzed",
             :type "string",
             :store true,
             :null_value token-document-null-value}]
  (def mapping-types
    {"doc" {:_all {:enabled false},
            :_source {:enabled true},
            :properties
            {:parent parent
             :tags {:index "not_analyzed",
                    :type "string",
                    :index_options "docs",
                    :store true,
                    :omit_norms true},
             :lastmodified {:type "date", :store "yes"},
             :content {:type "string", :store "yes"},
             :content_type {:type "string", :store "yes" :index "not_analyzed"},
             :extension {:type "string", :store "yes" :index "not_analyzed"},
             :title   {:type "string", :store "yes"},
             :deny_token_document token,
             :allow_token_document token}},
     "dir" {:_all {:enabled false},
            :_source {:enabled true}
            :properties
            {:lastmodified {:type "date", :store "yes"},
             :parent parent}}}))

;;; when sending around messages via rabbitmq we pass the lastmodified
;;; date as unix time (as integer). the field is called mtime while in
;;; rabbitmq. elasticsearch has a dedicated date type, and we store
;;; the lastmodified date under the lastmodified field.
;;; mtime->lastmodied and lastmodified->mtime convert between these
;;; two representations.

(defn mtime->lastmodified
  "convert unix timestamp to elasticsearch compatible string representation"
  [mtime]
  (-> mtime long (* 1000) tcoerce/from-long str))

(defn lastmodified->mtime
  "convert elasticsearch date string to unix timestamp"
  [lastmodified]
  (-> lastmodified tcoerce/from-string tcoerce/to-long (quot 1000)))

(defn strip-mime-type-parameters
  "strip mime type parameters from mime type string"
  [s]
  (-> s (string/split #";" 2) first string/trim))

(defn ensure-index-and-mappings
  [index-name]
  (if (esi/exists? index-name)
    (doseq [[doctype mapping] mapping-types]
      ;; (println "update-mapping" doctype mapping)
      (esi/update-mapping index-name doctype :mapping {:mapping mapping}))
    (esi/create index-name :mappings mapping-types)))

(defn es-listdir
  [index-name parent]
  (esd/search index-name
              ["dir" "doc"]
              :size 1000000
              :query {:match_all {}}
              :fields ["parent" "lastmodified" "allow_token_document" "deny_token_document"]
              :filter {:term {:parent parent}}))

(let [estype->type {"dir" "directory"
                    "doc" "file"}]
  (defn- convert-es-entry
    [{:keys [_type _id fields]}]
    {:id _id
     :type (estype->type _type)
     :allow (:allow_token_document fields)
     :deny (:deny_token_document fields)
     :mtime (-> fields :lastmodified lastmodified->mtime)}))

(defn enrich-es-entries
  [entries]
  (loop [entries entries]
    (if (map? entries)
      (recur (:hits entries))
      (map convert-es-entry entries))))

(defn es-recursive-delete
  [index-name parent]
  (let [with-slash (misc/ensure-endswith-slash parent)]
    (esd/delete-by-query-across-all-types
     index-name
     {:prefix {:_id with-slash}})
    (esd/delete index-name "dir" parent)))

(defn make-id
  [& args]
  (string/replace (string/join "/" args) #"/+" "/"))

(defn enrich-mq-entries
  [directory entries]
  (map
   (fn [entry]
     (assoc entry
       :id (make-id "" directory (:relpath entry))
       :type (if (:error entry)
               "error"
               (get-in entry [:stat :type]))
       :mtime (get-in entry [:stat :mtime])))
   entries))

(defn make-id-map
  [entries]
  (apply hash-map (mapcat (juxt :id identity) entries)))

(defn find-missing-entries
  [existing-map entries]
  (remove #(contains? existing-map (:id %)) entries))

(declare simplify-permissions-for-es)

(defn permset
  "create a set. elasticsearch may give us a single string, handle that case"
  [p]
  (if (string? p)
    #{p}
    (set p)))

(defn entry-needs-update?
  "compare es-entry with mq-entry and determine if we need to update it"
  [es-entry mq-entry]
  (or (not= (:mtime es-entry) (:mtime mq-entry))
      (let [mqperm (-> mq-entry :permissions simplify-permissions-for-es)
            mqperm* (misc/remap permset mqperm)
            esperm (select-keys es-entry [:allow :deny])
            esperm* (misc/remap permset esperm)]
        (not= mqperm* esperm*))))

(defn find-updates
  "compare entries with those in es-file-map and return a seq of
   entries that need to be updated"
  [es-file-map entries]
  (remove
   nil?
   (map (fn [mq-entry]
          (if-let [es-entry (-> mq-entry :id es-file-map)]
            (when (entry-needs-update? es-entry mq-entry)
              mq-entry)))
        entries)))

(defn compare-directories
  [mq-entries es-entries]
  (let [mq-entries-by-type (group-by :type mq-entries)
        mq-directory-map (make-id-map (mq-entries-by-type "directory"))
        mq-file-map (make-id-map (mq-entries-by-type "file"))

        es-entries-by-type (group-by :type
                                     (find-missing-entries
                                      (make-id-map (mq-entries-by-type "error"))
                                      es-entries))
        es-directory-map (make-id-map (es-entries-by-type "directory"))
        es-file-map (make-id-map (es-entries-by-type "file"))]
    {:delete-directories (find-missing-entries mq-directory-map (es-entries-by-type "directory"))
     :delete-files (find-missing-entries mq-file-map (es-entries-by-type "file"))
     :create-directories (find-missing-entries es-directory-map (mq-entries-by-type "directory"))
     :create-files (find-missing-entries es-file-map (mq-entries-by-type "file"))
     :update-files (find-updates es-file-map (mq-entries-by-type "file"))}))

(defn apply-diff-to-elasticsearch
  [{:keys [delete-directories delete-files create-directories]} es-index parent-id]
  (doseq [e delete-directories]
    (es-recursive-delete es-index (:id e)))
  (doseq [e delete-files]
    (esd/delete es-index "doc" (:id e)))
  (doseq [e create-directories]
    (esd/put es-index "dir"
             (:id e)
             {:lastmodified (mtime->lastmodified (:mtime e))
              :parent parent-id})))

(let [default-value (list token-document-null-value)]
  (defn simplify-permissions-for-es
    [permissions]
    (let [allow->sids (misc/remap #(sort (set (map :sid %)))
                                  (group-by :allow permissions))]
      {:allow (allow->sids true default-value)
       :deny  (allow->sids false default-value)})))

(defn get-tags-from-path
  [s]
  (sort (disj (set (string/split s #"/")) "")))

(defn simple-import_file
  [fs es-index {:keys [directory entry] :as body} {publish :publish}]
  (let [parent-id (make-id "" directory)
        relpath (:relpath entry)
        id (make-id "" directory relpath)
        title (or (get-in body [:extract :tika-content :dc:title])
                  relpath)
        simple-perms (simplify-permissions-for-es (:permissions entry))]

    (esd/put es-index "doc"
             id
             {:parent parent-id
              :content (get-in body [:extract :tika-content :text])
              :extension (path/get-extension-from-basename relpath)
              :content_type (strip-mime-type-parameters
                             (or
                              (first (get-in body [:extract :tika-content :content-type]))
                              ""))

              :title title
              :tags (get-tags-from-path directory)
              :allow_token_document (simple-perms :allow)
              :deny_token_document (simple-perms :deny)
              :lastmodified (mtime->lastmodified (get-in entry [:stat :mtime]))})))

(defn simple-update_directory
  [fs es-index {:keys [directory entries] :as body} {publish :publish}]
  ;; (logging/info "simple-update" directory)
  (let [parent-id (make-id "" directory)
        es-entries (enrich-es-entries (es-listdir es-index parent-id))
        mq-entries (enrich-mq-entries directory entries)
        diff (compare-directories mq-entries es-entries)]
    (apply-diff-to-elasticsearch diff es-index parent-id)

    (doseq [e (concat (:create-files diff) (:update-files diff))]
      (publish "extract_content"
               {:directory directory
                :entry (select-keys e [:relpath :permissions :stat])}))))

(def command->msg-handler
  {"update_directory" simple-update_directory
   "import_file"      simple-import_file})

(defn build-handle-connection
  [fsmap num-workers rmq-prefix]
  (fn [conn]
    (logging/info "initializing rabbitmq connection with" num-workers "workers")
    (doseq [_ (range num-workers)]
      (mqhelper/channel-loop
       conn
       (fn [ch]
         (doseq [fs (keys fsmap)
                 [command handle-msg] (seq command->msg-handler)]
           (let [qname (mqhelper/initialize-rabbitmq-structures ch command rmq-prefix fs)]
             ;; (lb/qos ch 1)
             (lcons/subscribe ch qname
                              (mqhelper/make-handler (partial handle-msg fs (get-in fsmap [fs :index])))))))))))

(defn make-standard-fsmap
  [filesystems]
  (into
   {}
   (for [fs filesystems]
     [fs {:index fs :prefix "" :filesystem fs}])))

(defn indexes-from-fsmap
  [fsmap]
  (distinct (map :index (vals fsmap))))

(defn ensure-all-indexes-and-mappings
  [fsmap]
  (doseq [idx (indexes-from-fsmap fsmap)]
    (ensure-index-and-mappings idx)))

(defn initialize-elasticsearch
  [es-url fsmap]
  (esr/connect! es-url)
  (ensure-all-indexes-and-mappings fsmap))

(defrecord ESConnectService [rmq-settings rmq-prefix num-workers fsmap es-url thread-pool]
  worker/Service
  (start [this]
    (try-try-again {:tries :unlimited
                    :error-hook (fn [err]
                                  (logging/error "error while initializing elasticsearch connection and indexes" es-url err))}
                   #(initialize-elasticsearch es-url fsmap))

    (mqhelper/connect-loop-with-thread-pool
     rmq-settings
     (build-handle-connection fsmap num-workers rmq-prefix)
     thread-pool)))

(def runner
  (reify
    dynaload/Loadable
    inihelper/IniConstructor
    (make-object-from-section [this system section]
      (let [iniconfig (:iniconfig system)
            rmq-settings (-> system :config :rmq-settings)
            rmq-prefix (-> system :config :rmq-prefix)
            num-workers (Integer. (get-in iniconfig [section "num-workers"] "10"))
            filesystems (sys/get-filesystems-for-section system section)
            fsmap (make-standard-fsmap filesystems)
            es-url (-> system :config :es-url)]
        (->ESConnectService rmq-settings
                            rmq-prefix
                            num-workers
                            fsmap
                            es-url
                            (:thread-pool system))))))

(ns brainbot.nozzle.esconnect
  "this namespace provides functionality to connect with the
elasticsearch backend. the import_file and update_directory
subcommands of the esconnect worker types are implemented here"
  (:require [clojure.pprint :refer [pprint]])
  (:require [clojure.string :as string])
  (:require [clojure.tools.logging :as logging])
  (:require [langohr.core :as rmq]
            [langohr.consumers :as lcons]
            [langohr.basic :as lb])
  (:require [clj-time.core :as tcore]
            [clj-time.coerce :as tcoerce])
  (:require [brainbot.nozzle.misc :as misc]
            [brainbot.nozzle.path :as path]
            [brainbot.nozzle.sys :as sys]
            [brainbot.nozzle.worker :as worker]
            [brainbot.nozzle.inihelper :as inihelper]
            [brainbot.nozzle.dynaload :as dynaload]
            [brainbot.nozzle.mqhelper :as mqhelper])
  (:require [robert.bruce :refer [try-try-again]])
  (:require [clojurewerkz.elastisch.rest.document :as esd]
            [clojurewerkz.elastisch.rest :as esr]
            [clojurewerkz.elastisch.rest.index :as esi]))

(def ^:private token-document-null-value "NOBODY")

;; (esr/connect! "http://127.0.0.1:9200")
(let [parent {:index "not_analyzed", :type "string", :store "yes"}
      token {:index "not_analyzed",
             :type "string",
             :store true,
             :null_value token-document-null-value}]
  (def mapping-types
    {"doc" {:_all {:enabled false},
            :_source {:enabled true},
            :properties
            {:parent parent
             :tags {:index "not_analyzed",
                    :type "string",
                    :index_options "docs",
                    :store true,
                    :omit_norms true},
             :lastmodified {:type "date", :store "yes"},
             :content {:type "string", :store "yes"},
             :content_type {:type "string", :store "yes" :index "not_analyzed"},
             :extension {:type "string", :store "yes" :index "not_analyzed"},
             :title   {:type "string", :store "yes"},
             :deny_token_document token,
             :allow_token_document token}},
     "dir" {:_all {:enabled false},
            :_source {:enabled true}
            :properties
            {:lastmodified {:type "date", :store "yes"},
             :parent parent}}}))

;;; when sending around messages via rabbitmq we pass the lastmodified
;;; date as unix time (as integer). the field is called mtime while in
;;; rabbitmq. elasticsearch has a dedicated date type, and we store
;;; the lastmodified date under the lastmodified field.
;;; mtime->lastmodied and lastmodified->mtime convert between these
;;; two representations.

(defn mtime->lastmodified
  "convert unix timestamp to elasticsearch compatible string representation"
  [mtime]
  (-> mtime long (* 1000) tcoerce/from-long str))

(defn lastmodified->mtime
  "convert elasticsearch date string to unix timestamp"
  [lastmodified]
  (-> lastmodified tcoerce/from-string tcoerce/to-long (quot 1000)))

(defn strip-mime-type-parameters
  "strip mime type parameters from mime type string"
  [s]
  (-> s (string/split #";" 2) first string/trim))

(defn ensure-index-and-mappings
  "create index with name index-name and make sure the mappings in
mapping-types are used. if the index already exists, just update the
mappings"
  [index-name]
  (if (esi/exists? index-name)
    (doseq [[doctype mapping] mapping-types]
      ;; (println "update-mapping" doctype mapping)
      (esi/update-mapping index-name doctype :mapping {:mapping mapping}))
    (esi/create index-name :mappings mapping-types)))

(defn es-listdir
  "list contents of directory 'parent' in index 'index-name'"
  [index-name parent]
  (esd/search index-name
              ["dir" "doc"]
              :size 1000000
              :query {:match_all {}}
              :fields ["parent" "lastmodified" "allow_token_document" "deny_token_document"]
              :filter {:term {:parent parent}}))

(let [estype->type {"dir" "directory"
                    "doc" "file"}]
  (defn- convert-es-entry
    [{:keys [_type _id fields]}]
    {:id _id
     :type (estype->type _type)
     :allow (:allow_token_document fields)
     :deny (:deny_token_document fields)
     :mtime (-> fields :lastmodified lastmodified->mtime)}))

(defn enrich-es-entries
  "convert entries from es-listdir to our common format"
  [entries]
  (loop [entries entries]
    (if (map? entries)
      (recur (:hits entries))
      (map convert-es-entry entries))))

(defn es-recursive-delete
  "recursively delete directory 'parent' from index 'index-name'"
  [index-name parent]
  (let [with-slash (misc/ensure-endswith-slash parent)]
    (esd/delete-by-query-across-all-types
     index-name
     {:prefix {:_id with-slash}})
    (esd/delete index-name "dir" parent)))

(defn make-id
  "build an id suitable for use in elasticsearch. we just join the
  components with / as separator and make sure that multiple slashes
  are replaced with one slash"
  [& args]
  (string/replace (string/join "/" args) #"/+" "/"))

(defn enrich-mq-entries
  "convert entries received via rabbitmq to our common format"
  [directory entries]
  (map
   (fn [entry]
     (assoc entry
       :id (make-id "" directory (:relpath entry))
       :type (if (:error entry)
               "error"
               (get-in entry [:stat :type]))
       :mtime (get-in entry [:stat :mtime])))
   entries))

(defn make-id-map
  "build a hashmap, mapping the :id of each entry to the entry itself"
  [entries]
  (apply hash-map (mapcat (juxt :id identity) entries)))

(defn find-missing-entries
  "return a seq of entries missing in existing-map, uses :id of each
entry for lookup in existing-map"
 [existing-map entries]
  (remove #(contains? existing-map (:id %)) entries))

(declare simplify-permissions-for-es)

(defn permset
  "create a set. elasticsearch may give us a single string, handle that case"
  [p]
  (if (string? p)
    #{p}
    (set p)))

(defn entry-needs-update?
  "compare es-entry with mq-entry and determine if we need to update it"
  [es-entry mq-entry]
  (or (not= (:mtime es-entry) (:mtime mq-entry))
      (let [mqperm (-> mq-entry :permissions simplify-permissions-for-es)
            mqperm* (misc/remap permset mqperm)
            esperm (select-keys es-entry [:allow :deny])
            esperm* (misc/remap permset esperm)]
        (not= mqperm* esperm*))))

(defn find-updates
  "compare entries with those in es-file-map and return a seq of
   entries that need to be updated"
  [es-file-map entries]
  (remove
   nil?
   (map (fn [mq-entry]
          (if-let [es-entry (-> mq-entry :id es-file-map)]
            (when (entry-needs-update? es-entry mq-entry)
              mq-entry)))
        entries)))

(defn compare-directories
  "compares listing of two directories and creates 'instructions' on
how to update the second directory to match the first one"
  [mq-entries es-entries]
  (let [mq-entries-by-type (group-by :type mq-entries)
        mq-directory-map (make-id-map (mq-entries-by-type "directory"))
        mq-file-map (make-id-map (mq-entries-by-type "file"))

        es-entries-by-type (group-by :type
                                     (find-missing-entries
                                      (make-id-map (mq-entries-by-type "error"))
                                      es-entries))
        es-directory-map (make-id-map (es-entries-by-type "directory"))
        es-file-map (make-id-map (es-entries-by-type "file"))]
    {:delete-directories (find-missing-entries mq-directory-map (es-entries-by-type "directory"))
     :delete-files (find-missing-entries mq-file-map (es-entries-by-type "file"))
     :create-directories (find-missing-entries es-directory-map (mq-entries-by-type "directory"))
     :create-files (find-missing-entries es-file-map (mq-entries-by-type "file"))
     :update-files (find-updates es-file-map (mq-entries-by-type "file"))}))

(defn apply-diff-to-elasticsearch
  [{:keys [delete-directories delete-files create-directories]} es-index parent-id]
  (doseq [e delete-directories]
    (es-recursive-delete es-index (:id e)))
  (doseq [e delete-files]
    (esd/delete es-index "doc" (:id e)))
  (doseq [e create-directories]
    (esd/put es-index "dir"
             (:id e)
             {:lastmodified (mtime->lastmodified (:mtime e))
              :parent parent-id})))

(let [default-value (list token-document-null-value)]
  (defn simplify-permissions-for-es
    [permissions]
    (let [allow->sids (misc/remap #(sort (set (map :sid %)))
                                  (group-by :allow permissions))]
      {:allow (allow->sids true default-value)
       :deny  (allow->sids false default-value)})))

(defn get-tags-from-path
  [s]
  (sort (disj (set (string/split s #"/")) "")))

(defn simple-import_file
  [fs es-index {:keys [directory entry] :as body} {publish :publish}]
  (let [parent-id (make-id "" directory)
        relpath (:relpath entry)
        id (make-id "" directory relpath)
        title (or (get-in body [:extract :tika-content :dc:title])
                  relpath)
        simple-perms (simplify-permissions-for-es (:permissions entry))]

    (esd/put es-index "doc"
             id
             {:parent parent-id
              :content (get-in body [:extract :tika-content :text])
              :extension (path/get-extension-from-basename relpath)
              :content_type (strip-mime-type-parameters
                             (or
                              (first (get-in body [:extract :tika-content :content-type]))
                              ""))

              :title title
              :tags (get-tags-from-path directory)
              :allow_token_document (simple-perms :allow)
              :deny_token_document (simple-perms :deny)
              :lastmodified (mtime->lastmodified (get-in entry [:stat :mtime]))})))

(defn simple-update_directory
  [fs es-index {:keys [directory entries] :as body} {publish :publish}]
  ;; (logging/info "simple-update" directory)
  (let [parent-id (make-id "" directory)
        es-entries (enrich-es-entries (es-listdir es-index parent-id))
        mq-entries (enrich-mq-entries directory entries)
        diff (compare-directories mq-entries es-entries)]
    (apply-diff-to-elasticsearch diff es-index parent-id)

    (doseq [e (concat (:create-files diff) (:update-files diff))]
      (publish "extract_content"
               {:directory directory
                :entry (select-keys e [:relpath :permissions :stat])}))))

(def command->msg-handler
  {"update_directory" simple-update_directory
   "import_file"      simple-import_file})

(defn build-handle-connection
  [fsmap num-workers rmq-prefix]
  (fn [conn]
    (logging/info "initializing rabbitmq connection with" num-workers "workers")
    (doseq [_ (range num-workers)]
      (mqhelper/channel-loop
       conn
       (fn [ch]
         (doseq [fs (keys fsmap)
                 [command handle-msg] (seq command->msg-handler)]
           (let [qname (mqhelper/initialize-rabbitmq-structures ch command rmq-prefix fs)]
             ;; (lb/qos ch 1)
             (lcons/subscribe ch qname
                              (mqhelper/make-handler (partial handle-msg fs (get-in fsmap [fs :index])))))))))))

(defn make-standard-fsmap
  [filesystems]
  (into
   {}
   (for [fs filesystems]
     [fs {:index fs :prefix "" :filesystem fs}])))

(defn indexes-from-fsmap
  [fsmap]
  (distinct (map :index (vals fsmap))))

(defn ensure-all-indexes-and-mappings
  [fsmap]
  (doseq [idx (indexes-from-fsmap fsmap)]
    (ensure-index-and-mappings idx)))

(defn initialize-elasticsearch
  [es-url fsmap]
  (esr/connect! es-url)
  (ensure-all-indexes-and-mappings fsmap))

(defrecord ESConnectService [rmq-settings rmq-prefix num-workers fsmap es-url thread-pool]
  worker/Service
  (start [this]
    (try-try-again {:tries :unlimited
                    :error-hook (fn [err]
                                  (logging/error "error while initializing elasticsearch connection and indexes" es-url err))}
                   #(initialize-elasticsearch es-url fsmap))

    (mqhelper/connect-loop-with-thread-pool
     rmq-settings
     (build-handle-connection fsmap num-workers rmq-prefix)
     thread-pool)))

(def runner
  (reify
    dynaload/Loadable
    inihelper/IniConstructor
    (make-object-from-section [this system section]
      (let [iniconfig (:iniconfig system)
            rmq-settings (-> system :config :rmq-settings)
            rmq-prefix (-> system :config :rmq-prefix)
            num-workers (Integer. (get-in iniconfig [section "num-workers"] "10"))
            filesystems (sys/get-filesystems-for-section system section)
            fsmap (make-standard-fsmap filesystems)
            es-url (-> system :config :es-url)]
        (->ESConnectService rmq-settings
                            rmq-prefix
                            num-workers
                            fsmap
                            es-url
                            (:thread-pool system))))))

add some docstrings to esconnect

add some docstrings to esconnect


(ns hsm.integration.twttr
    (:use
   [twitter.oauth]
   [twitter.callbacks]
   [twitter.callbacks.handlers]
   [twitter.api.streaming])
    (:require
   [cheshire.core :as json]
   [environ.core :refer [env]]
   [http.async.client :as ac])
  (:import
   (twitter.callbacks.protocols AsyncStreamingCallback))

    )

(def my-creds (make-oauth-creds (env :app-consumer-key)
                                (env :app-consumer-secret)
                                (env :user-access-token)
                                (env :user-access-token-secret)))

(def ^:dynamic
     *custom-streaming-callback*
     (AsyncStreamingCallback. (comp println #(:text %) json/parse-string #(str %2))
                      (comp println response-return-everything)
                  exception-print))

(statuses-filter :params {:track "clojure"}
         :oauth-creds my-creds
         :callbacks *custom-streaming-callback*)

(ns hsm.integration.twttr
    (:use
   [twitter.oauth]
   [twitter.callbacks]
   [twitter.callbacks.handlers]
   [twitter.api.streaming])
    (:require
   [cheshire.core :as json]
   [environ.core :refer [env]]
   [http.async.client :as ac])
  (:import
   (twitter.callbacks.protocols AsyncStreamingCallback)))

(def my-creds (make-oauth-creds (env :app-consumer-key)
                                (env :app-consumer-secret)
                                (env :user-access-token)
                                (env :user-access-token-secret)))

(def ^:dynamic
     *custom-streaming-callback*
     (AsyncStreamingCallback. (comp println #(:text %) json/parse-string #(str %2))
                      (comp println response-return-everything)
                  exception-print))

(defn testing []
  (statuses-filter :params {:track "clojure"}
             :oauth-creds my-creds
             :callbacks *custom-streaming-callback*))

connect twttr via a fn

connect twttr via a fn


; Copyright © 2011 Sattvik Software & Technology Resources, Ltd. Co.
; All rights reserved.
;
; This program and the accompanying materials are made available under the
; terms of the Eclipse Public License v1.0 which accompanies this distribution,
; and is available at <http://www.eclipse.org/legal/epl-v10.html>.
;
; By using this software in any fashion, you are agreeing to be bound by the
; terms of this license.  You must not remove this notice, or any other, from
; this software.

(ns neko.dialog.alert
  "Helps build and manage alert dialogs.  The core functionality of this
  namespace is built around the AlertDialogBuilder protocol.  This allows using
  the protocol with the FunctionalAlertDialogBuilder generated by new-builder
  as well as the AlertDialog.Builder class provided by the Android platform.

  In general, it is preferable to use the functional version of the builder as
  it is immutable.  Using the protocol with an AlertDialog.Builder object works
  by mutating the object."
  {:author "Daniel Solano Gómez"}
  (:import android.app.AlertDialog$Builder)
  (:use neko.context)
  )

(defprotocol AlertDialogBuilder
  "Defines the functionality needed to build new alert dialogues."
  (create [builder]
    "Actually creates the AlertDialog.")
  )

(defrecord FunctionalAlertDialogBuilder
  [^android.content.Context context]
  AlertDialogBuilder
  (create [_]
    #_{:post [(instance? android.app.AlertDialog %)]}
    (let [builder (AlertDialog$Builder. context)]
      (.create builder)))
  )

(extend-type AlertDialog$Builder
  AlertDialogBuilder
  (create [this]
    {:post [(instance? android.app.AlertDialog %)]}
    (.create this))
  )

(defn new-builder
  ([]
   {:pre  [(has-*context*?)]
    :post [(instance? FunctionalAlertDialogBuilder %)]}
   (new-builder *context*))
  ([context]
   {:pre  [(context? context)]
    :post [(instance? FunctionalAlertDialogBuilder %)]}
   (FunctionalAlertDialogBuilder. context)))

; Copyright © 2011 Sattvik Software & Technology Resources, Ltd. Co.
; All rights reserved.
;
; This program and the accompanying materials are made available under the
; terms of the Eclipse Public License v1.0 which accompanies this distribution,
; and is available at <http://www.eclipse.org/legal/epl-v10.html>.
;
; By using this software in any fashion, you are agreeing to be bound by the
; terms of this license.  You must not remove this notice, or any other, from
; this software.

(ns neko.dialog.alert
  "Helps build and manage alert dialogs.  The core functionality of this
  namespace is built around the AlertDialogBuilder protocol.  This allows using
  the protocol with the FunctionalAlertDialogBuilder generated by new-builder
  as well as the AlertDialog.Builder class provided by the Android platform.

  In general, it is preferable to use the functional version of the builder as
  it is immutable.  Using the protocol with an AlertDialog.Builder object works
  by mutating the object."
  {:author "Daniel Solano Gómez"}
  (:import android.app.AlertDialog$Builder)
  (:use neko.context)
  )

(defprotocol AlertDialogBuilder
  "Defines the functionality needed to build new alert dialogues."
  (create [builder]
    "Actually creates the AlertDialog.")
  )

(defrecord FunctionalAlertDialogBuilder
  [^android.content.Context context]
  AlertDialogBuilder
  (create [_]
    #_{:post [(instance? android.app.AlertDialog %)]}
    (let [builder (AlertDialog$Builder. context)]
      (.create builder)))
  )

(extend-type AlertDialog$Builder
  AlertDialogBuilder
  (create [this]
    {:post [(instance? android.app.AlertDialog %)]}
    (.create this))
  )

(defn new-builder
  "Creates a new functional alert dialog builder.  If within a with-context
  form, the context argument may be omitted."
  ([]
   {:pre  [(has-*context*?)]
    :post [(instance? FunctionalAlertDialogBuilder %)]}
   (new-builder *context*))
  ([context]
   {:pre  [(context? context)]
    :post [(instance? FunctionalAlertDialogBuilder %)]}
   (FunctionalAlertDialogBuilder. context)))

Add doc

Add doc


(ns nightweb-desktop.window
  (:require [splendid.jfx :as jfx])
  (:import (javafx.scene.layout VBox Priority)
           (javafx.scene.control TabPane Tab)
           javafx.scene.web.WebView
           javafx.beans.value.ChangeListener)
  (:use [nightweb.router :only [stop-router]]
        [nightweb-desktop.server :only [port]]))

(defn create-tab
  "Creates a new tab."
  []
  (let [new-tab (Tab.)
        web-view (WebView.)
        web-engine (.getEngine web-view)
        history (.getHistory web-engine)
        dots "..."]
    (VBox/setVgrow web-view Priority/ALWAYS)
    (.addListener (.stateProperty (.getLoadWorker web-engine))
                  (proxy [ChangeListener] []
                    (changed [ov old-state new-state]
                      (if (= new-state javafx.concurrent.Worker$State/RUNNING)
                        (.setText new-tab dots)
                        (.setText new-tab (or (.getTitle web-engine) dots))))))
    (.load web-engine (str "http://localhost:" port))
    (.setContent new-tab web-view)
    new-tab))

(defn add-tab
  "Creates a tab and adds it to the tab bar."
  [tab-bar]
  (let [index (- (.size (.getTabs tab-bar)) 1)
        new-tab (create-tab)]
    (.add (.getTabs tab-bar) index new-tab)
    (.select (.getSelectionModel tab-bar) index)))

(defn start-window
  "Launches a JavaFX window."
  []
  (jfx/jfx
    (let [window (VBox.)
          tab-bar (TabPane.)
          plus-tab (Tab. " + ")]
      (.setTabClosingPolicy
        tab-bar javafx.scene.control.TabPane$TabClosingPolicy/ALL_TABS)
      (.setClosable plus-tab false)
      (.add (.getTabs tab-bar) plus-tab)
      (jfx/defhandler :onSelectionChanged plus-tab (add-tab tab-bar))
      (.addListener (.getTabs tab-bar)
                    (reify javafx.collections.ListChangeListener
                      (onChanged [this change]
                        (let [tabs (butlast (.getTabs tab-bar))]
                          (doseq [tab tabs]
                            (.setClosable tab (> (count tabs) 1)))))))
      (add-tab tab-bar)
      (VBox/setVgrow tab-bar Priority/ALWAYS)
      (.setWidth jfx/primary-stage 1024)
      (.setMinWidth jfx/primary-stage 800)
      (.setHeight jfx/primary-stage 768)
      (.setMinHeight jfx/primary-stage 600)
      (jfx/add window [tab-bar])
      (jfx/show window)
      (.setOnCloseRequest jfx/primary-stage
                          (reify javafx.event.EventHandler
                            (handle [this event]
                              (stop-router)
                              (java.lang.System/exit 0)))))))

(ns nightweb-desktop.window
  (:require [splendid.jfx :as jfx])
  (:import (javafx.scene.layout VBox Priority)
           (javafx.scene.control TabPane Tab)
           javafx.scene.web.WebView
           javafx.beans.value.ChangeListener)
  (:use [nightweb.router :only [stop-router]]
        [nightweb-desktop.server :only [port]]))

(defn create-webview
  "Creates a new WebView."
  []
  (let [web-view (WebView.)
        web-engine (.getEngine web-view)]
    (VBox/setVgrow web-view Priority/ALWAYS)
    (.load web-engine (str "http://localhost:" port))
    web-view))

(defn start-window
  "Launches a JavaFX window."
  []
  (jfx/jfx
    (let [window (VBox.)
          web-view (create-webview)]
      (.setWidth jfx/primary-stage 1024)
      (.setMinWidth jfx/primary-stage 800)
      (.setHeight jfx/primary-stage 768)
      (.setMinHeight jfx/primary-stage 600)
      (jfx/add window [web-view])
      (jfx/show window)
      (.setOnCloseRequest jfx/primary-stage
                          (reify javafx.event.EventHandler
                            (handle [this event]
                              (stop-router)
                              (java.lang.System/exit 0)))))))

Remove tabs for simplicity

Remove tabs for simplicity


(ns comic-reader.scrape
  (:require [clojure.string :refer [trim]]
            [net.cgrand.enlive-html :as html])
  (:import java.net.URL))

(def sites
  {"Manga Fox" {:url "http://mangafox.me/manga/"
                :selector [:div.manga_list :ul :li :a]
                :normalize (fn [{name :content
                                 {url :href} :attrs}]
                             {:name name
                              :url url})}
   "Manga Reader" {:url "http://www.mangareader.net/alphabetical"
                   :selector [:div.series_alpha :ul :li :a]
                   :normalize (fn [{name :content
                                    {url :href} :attrs}]
                                {:name (trim name)
                                 :url url})}})

(defn fetch-url [url]
  (html/html-resource (java.net.URL. url)))

(defn fetch-site-list [{:keys [url selector normalize]}]
  (map normalize (html/select (fetch-url url) selector)))

(ns comic-reader.scrape
  (:require [clojure.string :refer [trim]]
            [net.cgrand.enlive-html :as html])
  (:import java.net.URL))

(def sites
  [{:name "Manga Fox"
    :url "http://mangafox.me/manga/"
    :selector [:div.manga_list :ul :li :a]
    :normalize (fn [{[name] :content
                     {url :href} :attrs}]
                 {:name name
                  :url url})}
   {:name "Manga Reader"
    :url "http://www.mangareader.net/alphabetical"
    :selector [:div.series_alpha :ul :li :a]
    :normalize (fn [{[name] :content
                     {url :href} :attrs}]
                 {:name (trim name)
                  :url url})}])

(defn fetch-url [url]
  (html/html-resource (java.net.URL. url)))

(defn fetch-site-list [{:keys [url selector normalize]}]
  (map normalize (html/select (fetch-url url) selector)))

Restructure site meta-data

Restructure site meta-data


(ns klangmeister.instruments)

(defonce context (js/window.AudioContext.))

(defn volume [peak]
  (fn [at context]
    (let [node (.createGain context)]
      (doto (.-gain node)
        (.setValueAtTime peak at))
      node)))

(defn percuss [attack decay]
  (fn [at context]
    (let [node (.createGain context)]
      (doto (.-gain node)
        (.setValueAtTime 0 at)
        (.linearRampToValueAtTime 1.0 (+ at attack))
        (.linearRampToValueAtTime 0 (+ at attack decay)))
      node)))

(defn wire [ugen1 ugen2]
  (fn [at context]
    (let [upstream (ugen1 at context)
          sink (ugen2 at context)]
      (.connect upstream sink)
      sink)))

(defn >>> [& nodes]
  (reduce wire nodes))

(defn oscillator [type freq duration]
  (fn [at context]
    (doto (.createOscillator context)
      (-> .-frequency .-value (set! freq))
      (-> .-type (set! type))
      (.start at)
      (.stop (+ at duration)))))

(def sin-osc (partial oscillator "sine"))
(def saw (partial oscillator "sawtooth"))

(defn destination [at context]
  (.-destination context))

(defn blend [nodes]
  (fn [at context]
    (doseq [node nodes]
      (node at context))))

(defn bell! [{:keys [time duration pitch]}]
  (let [harmonic (fn [n proportion]
                   (>>> (sin-osc (* n pitch) 1.5)
                        (percuss 0.01 proportion)
                        (volume 0.01)
                        destination))]
    (->>
      (map
        harmonic
        [1.0 2.0 3.0 4.1 5.2]
        [1.0 0.6 0.4 0.3 0.2])
      blend)))

(defn fuzz! [{:keys [duration pitch]}]
  (>>> (saw pitch 1.5)
       (percuss 0.1 0.5)
       (volume 0.1)
       destination))

(defn buzz! [{:keys [duration pitch]}]
  (let [freqs [pitch (* pitch 1.01) (* pitch 0.99)]
        envelopes [[0.3 0.2] [0.05 0.1] [0.1 0.1]]]
    (->> (map (fn [freq [attack decay]]
                (>>> (saw freq 1.5)
                     (percuss attack decay)
                     (volume 0.05)
                     destination))
              freqs
              envelopes)
         blend)))

(ns klangmeister.instruments)

(defonce context (js/window.AudioContext.))

(defn volume [peak]
  (fn [at context]
    (let [node (.createGain context)]
      (doto (.-gain node)
        (.setValueAtTime peak at))
      node)))

(defn percuss [attack decay]
  (fn [at context]
    (let [node (.createGain context)]
      (doto (.-gain node)
        (.setValueAtTime 0 at)
        (.linearRampToValueAtTime 1.0 (+ at attack))
        (.linearRampToValueAtTime 0 (+ at attack decay)))
      node)))

(defn connect [ugen1 ugen2]
  (fn [at context]
    (let [upstream (ugen1 at context)
          sink (ugen2 at context)]
      (.connect upstream sink)
      sink)))

(defn >>> [& nodes]
  (reduce connect nodes))

(defn oscillator [type freq duration]
  (fn [at context]
    (doto (.createOscillator context)
      (-> .-frequency .-value (set! freq))
      (-> .-type (set! type))
      (.start at)
      (.stop (+ at duration)))))

(def sin-osc (partial oscillator "sine"))
(def saw (partial oscillator "sawtooth"))

(defn destination [at context]
  (.-destination context))

(defn blend [nodes]
  (fn [at context]
    (doseq [node nodes]
      (node at context))))

(defn bell! [{:keys [time duration pitch]}]
  (let [harmonic (fn [n proportion]
                   (>>> (sin-osc (* n pitch) 1.5)
                        (percuss 0.01 proportion)
                        (volume 0.01)
                        destination))]
    (->>
      (map
        harmonic
        [1.0 2.0 3.0 4.1 5.2]
        [1.0 0.6 0.4 0.3 0.2])
      blend)))

(defn fuzz! [{:keys [duration pitch]}]
  (>>> (saw pitch 1.5)
       (percuss 0.1 0.5)
       (volume 0.1)
       destination))

(defn buzz! [{:keys [duration pitch]}]
  (let [freqs [pitch (* pitch 1.01) (* pitch 0.99)]
        envelopes [[0.3 0.2] [0.05 0.1] [0.1 0.1]]]
    (->> (map (fn [freq [attack decay]]
                (>>> (saw freq 1.5)
                     (percuss attack decay)
                     (volume 0.05)
                     destination))
              freqs
              envelopes)
         blend)))

Rename fn.

Rename fn.


;;;
;;;   Copyright 2015 Ruediger Gad
;;;
;;;   This software is released under the terms of the Eclipse Public License
;;;   (EPL) 1.0. You can find a copy of the EPL at:
;;;   http://opensource.org/licenses/eclipse-1.0.php
;;;

(ns
  ^{:author "Ruediger Gad",
    :doc "Helper that are primarily used during experiments"}
  dsbdp.experiment-helper
  (:require
    [clojure.walk :refer :all]
    [clojure.pprint :refer :all]
    [dsbdp.byte-array-conversion :refer :all])
  (:import
    (java.util HashMap Map)
    (org.apache.commons.math3.util CombinatoricsUtils)))

(defmacro create-proc-fns
  [fn-1 fn-n n]
  (loop [fns (prewalk-replace {:idx 0} [fn-1])]
    (if (< (count fns) n)
      (recur (conj fns (prewalk-replace {:idx (count fns)} fn-n)))
      (do
        (println "proc-fns-full:" fns)
        (println "proc-fns-short:" (.replaceAll (str fns) "(?<=\\()([a-zA-Z\\.\\-]++/)" ""))
        (println "proc-fns-pretty:\n" (.replaceAll (with-out-str (pprint fns)) "(?<=\\()([a-zA-Z\\.\\-]++/)" ""))
        fns))))

(defmacro create-no-op-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'_ ~'_])
     (fn [~'_ ~'_])
     ~n))

(defmacro create-inc-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'i ~'_] (inc ~'i))
     (fn [~'_ ~'o] (inc ~'o))
     ~n))

(defmacro create-hashmap-inc-put-proc-fns
  [n]
  (let [o-sym 'o]
    (let [o-meta (vary-meta o-sym assoc :tag 'Map)]
     `(create-proc-fns
        (fn [~'i ~'_] (doto (HashMap.) (.put (str :idx) (inc ~'i))))
        (fn [~'_ ~o-meta] (.put ~o-meta (str :idx) (inc (.get ~o-meta (str (dec :idx))))))
        ~n))))

(defn factorial
  [n]
  (loop [result 1N i 1N]
    (if (<= i n)
      (recur (* result i) (inc i))
      result)))

(defmacro create-factorial-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'i ~'_] (factorial ~'i))
     (fn [~'i ~'_] (factorial ~'i))
     ~n))

;;;
;;;   Copyright 2015 Ruediger Gad
;;;
;;;   This software is released under the terms of the Eclipse Public License
;;;   (EPL) 1.0. You can find a copy of the EPL at:
;;;   http://opensource.org/licenses/eclipse-1.0.php
;;;

(ns
  ^{:author "Ruediger Gad",
    :doc "Helper that are primarily used during experiments"}
  dsbdp.experiment-helper
  (:require
    [clojure.walk :refer :all]
    [clojure.pprint :refer :all]
    [dsbdp.byte-array-conversion :refer :all])
  (:import
    (java.util HashMap Map)
    (org.apache.commons.math3.util CombinatoricsUtils)))

(defmacro create-proc-fns
  [fn-1 fn-n n]
  (loop [fns (prewalk-replace {:idx 0} [fn-1])]
    (if (< (count fns) n)
      (recur (conj fns (prewalk-replace {:idx (count fns)} fn-n)))
      (do
        (println "proc-fns-full:" fns)
        (println "proc-fns-short:" (.replaceAll (str fns) "(?<=\\()([a-zA-Z\\.\\-]++/)" ""))
        (println "proc-fns-pretty:\n" (.replaceAll (str (with-out-str (pprint fns))) "(?<=\\()([a-zA-Z\\.\\-]++/)" ""))
        fns))))

(defmacro create-no-op-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'_ ~'_])
     (fn [~'_ ~'_])
     ~n))

(defmacro create-inc-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'i ~'_] (inc ~'i))
     (fn [~'_ ~'o] (inc ~'o))
     ~n))

(defmacro create-hashmap-inc-put-proc-fns
  [n]
  (let [o-sym 'o]
    (let [o-meta (vary-meta o-sym assoc :tag 'Map)]
     `(create-proc-fns
        (fn [~'i ~'_] (doto (HashMap.) (.put (str :idx) (inc ~'i))))
        (fn [~'_ ~o-meta] (.put ~o-meta (str :idx) (inc (.get ~o-meta (str (dec :idx))))))
        ~n))))

(defn factorial
  [n]
  (loop [result 1N i 1N]
    (if (<= i n)
      (recur (* result i) (inc i))
      result)))

(defmacro create-factorial-proc-fns
  [n]
  `(create-proc-fns
     (fn [~'i ~'_] (factorial ~'i))
     (fn [~'i ~'_] (factorial ~'i))
     ~n))

Fix reflection warning.

Fix reflection warning.


(ns salava.core.i18n
  #?(:cljs (:require-macros [taoensso.tower :as tower-macros]))
     (:require
       #?@(:cljs [[reagent.session :as session]
                  [salava.translator.ui.main :as tr]
                  [taoensso.tower :as tower :refer-macros (with-tscope)]])
       #?(:clj  [taoensso.tower :as tower :refer (with-tscope)])))

(def tconfig
  #?(:clj {:fallback-locale :en
           :dev-mode? true
           :dictionary "i18n/dict.clj"}
     :cljs {:fallback-locale :en
            :compiled-dictionary (tower-macros/dict-compile* "i18n/dict.clj")}))

(def translation (tower/make-t tconfig)) ; create translation fn

(defn get-t [lang key]
  (let [out-str (translation lang key)]
    (if-not (= out-str "")
      out-str
      (str "[" key "]"))))

#?(:clj  (defn t [key] (get-t "en" key))

   :cljs (defn t [& keylist]
           (let [lang (or (session/get-in [:user :lang]) :en)]
             (if (session/get :i18n-editable)
               (tr/get-editable translation lang keylist)
               (apply str (map (fn [k] (if (keyword? k) (get-t lang k) k)) keylist))))))

(ns salava.core.i18n
  #?(:cljs (:require-macros [taoensso.tower :as tower-macros]))
     (:require
       #?@(:cljs [[reagent.session :as session]
                  [salava.translator.ui.main :as tr]
                  [taoensso.tower :as tower :refer-macros (with-tscope)]])
       #?(:clj  [taoensso.tower :as tower :refer (with-tscope)])))

(def tconfig
  #?(:clj {:fallback-locale :en
           :dev-mode? true
           :dictionary "i18n/dict.clj"}
     :cljs {:fallback-locale :en
            :compiled-dictionary (tower-macros/dict-compile* "i18n/dict.clj")}))

(def translation (tower/make-t tconfig)) ; create translation fn

(defn get-t [lang key]
  (let [out-str (translation lang key)]
    (if-not (= out-str "")
      out-str
      (str "[" key "]"))))

#?(:clj  (defn t [key] (get-t "en" key))

   :cljs (defn t [& keylist]
           (let [lang (or (session/get-in [:user :language]) :en)]
             (if (session/get :i18n-editable)
               (tr/get-editable translation lang keylist)
               (apply str (map (fn [k] (if (keyword? k) (get-t lang k) k)) keylist))))))

Fix user language check

Fix user language check


(ns hatti.ona.post-process
  (:require [chimera.js-interop :refer [format]]
            [chimera.om.state :refer [transact!]]
            [chimera.seq :refer [filter-first]]
            [chimera.urls :refer [url last-url-param]]
            [clojure.string :refer [join split]]
            [hatti.constants :refer [_attachments _id _rank]]
            [hatti.ona.forms :as forms]
            [hatti.ona.urls :as ona-urls]
            [cljsjs.jquery]
            [osmtogeojson]))

;; OSM POST-PROCESSING

(defn ona-osm-link
  "Given some data in Ona format, builds a data structure that we will use
   to link osm data to Ona data."
  [data form]
  (let [osmfields (filter forms/osm? form)]
    (->> (for [datum data]
           (for [field osmfields]
             (let [osmkey (:full-name field)
                   osmdatum (get datum osmkey)
                   osmid (and osmdatum (re-find #"[0-9]+" osmdatum))]
               (when osmid
                 {osmid (merge {:field field}
                               (select-keys datum #{_id _rank}))}))))
         flatten
         (into {}))))

(defn osm-xml->geojson
  "Takes OSM XML in string form, and returns cljs geojson."
  [osm-xml-string]
  (js->clj (js/osmtogeojson (.parseXML js/jQuery osm-xml-string))
           :keywordize-keys true))

(defn osm-id->osm-data
  "Given some data in OSM format, an Ona Form, and osm xml string,
   return a map from OSM ID to each osm feature. The map contains:
   :osm-id, :name, :tags from osm xml,
   :type, :geom from osm feature's geojson equivalent."
  [data form osm-xml]
  (let [ona-osm-link (ona-osm-link data form)
        osmgeo (osm-xml->geojson osm-xml)
        featureset (osmgeo :features)]
    (into {}
          (for [{:keys [type properties geometry] :as feature} featureset]
            (let [{:keys [type id tags]} properties]
              {id {:osm-id id
                   :type type
                   :geom geometry
                   :name (:name tags)
                   :tags tags}})))))

(defn integrate-osm-data!
  "Given some data post-processed from the ona server
   (ie, containing _id, _rank), and a string of osm-xml, produce a version with
   relevant osm data injected in."
  [app-state form osm-xml app-state-keys]
  (let [osm-fields (filter forms/osm? form)]
    (when (seq osm-fields)
      (let [data (get-in app-state app-state-keys)
            osm-data (osm-id->osm-data data form osm-xml)
            osm-val->osm-id #(re-find #"[-]?[0-9]+" %)
            osm-val->osm-data (fn [osm-val osm-id]
                                ;; The OSM-val can be either a string or a
                                ;; precomputed osm-data value. This condition
                                ;; ensures only strings are parsed for OSM ids
                                (if (string? osm-val)
                                  (if-let [osm-submission-data
                                           (osm-data osm-id)]
                                    osm-submission-data
                                    osm-val)
                                  osm-val))
            updater (fn [osm-key]
                      (fn [data]
                        (for [datum data]
                          (let [osm-id (or
                                        (get-in datum [(str osm-key
                                                            ":way:id")])
                                        (get-in datum [(str osm-key
                                                            ":node:id")]))]
                            (update-in datum [osm-key]
                                       #(osm-val->osm-data % osm-id))))))]

        (doseq [osm-field osm-fields]
          (transact! app-state app-state-keys
                     (updater (:full-name osm-field))))))))

;; IMAGE AND VIDEO POST-PROCESSING

(defn url-obj
  "Calculate full image and thumbnail urls given attachment information."
  [media-obj]
  (let [media-id (get media-obj "id")
        fname (get media-obj "filename")
        file-url (ona-urls/media-url media-id fname)]
    {:filename fname
     :download_url file-url
     :small_download_url (str file-url "&suffix=small")}))

(defn get-matching-name
  "Gets and returns matching name for an attachment that was renamed by
  appending a hash on the S3 server to avoid duplicating names.
  e.g. if 1478203839187.jpg was renamed to 1478203839187_wijUzUf.jpg,
  it returns 1478203839187_wijUzUf.jpg."
  [fname fnames]
  (if (string? fname)
    (try
      (or
       (filter-first
        #(re-find
          (re-pattern (first (split fname (re-pattern "\\.")))) %)
        fnames)
       fname)
      (catch js/SyntaxError e
        fname))
    fname))

(defn get-attach-map
  "Helper function for integrate attachments; returns a function from
   a filename to a `url-obj` (see specs in `url-obj` function)."
  [record attachments]
  (let [attachments (or attachments (get record _attachments))
        fnames (map #(last-url-param (get % "filename")) attachments)
        fname->urlobj (zipmap fnames (map url-obj attachments))]
    ;; If urlobj isn't found, we'll just return filename
    (fn [fname] (get fname->urlobj (get-matching-name fname fnames) fname))))

(defn filter-media
  "Coll -> Coll"
  [flat-form]
  (filter #(or (forms/video? %) (forms/image? %)) flat-form))

(defn integrate-attachments
  "Inlines media data from within _attachments into each record.
   Coll Coll -> Coll"
  [flat-form data & {:keys [attachments]}]
  (let [image-fields (filter-media flat-form)]
    (for [record data]
      (let [attach-map (get-attach-map record attachments)]
        (reduce (fn [record img-field]
                  (update-in record [(:full-name img-field)] attach-map))
                record
                image-fields)))))

(defn integrate-attachments-in-repeats
  "Inlines data from within _attachments into each datapoint within repeats."
  [flat-form data]
  (let [repeat-fields (filter forms/repeat? flat-form)
        integrate (fn [record rpt-field]
                    (let [key (:full-name rpt-field)]
                      (assoc record key
                             (integrate-attachments
                              (:children rpt-field)
                              (get record key)
                              :attachments
                              (get record _attachments)))))]
    (for [record data]
      (reduce integrate record repeat-fields))))

(defn integrate-attachments!
  "Inlines data from within _attachments into each record within app-state."
  [app-state flat-form & {:keys [app-data-keys]
                          :or {app-data-keys [:data]}}]
  (transact! app-state
             app-data-keys
             #(->> %
                   (integrate-attachments flat-form)
                   (integrate-attachments-in-repeats flat-form))))

(ns hatti.ona.post-process
  (:require [chimera.js-interop :refer [format]]
            [chimera.om.state :refer [transact!]]
            [chimera.seq :refer [filter-first]]
            [chimera.urls :refer [url last-url-param]]
            [clojure.string :refer [join split]]
            [hatti.constants :refer [_attachments _id _rank]]
            [hatti.ona.forms :as forms]
            [hatti.ona.urls :as ona-urls]
            [cljsjs.jquery]
            [osmtogeojson]))

;; OSM POST-PROCESSING

(defn ona-osm-link
  "Given some data in Ona format, builds a data structure that we will use
   to link osm data to Ona data."
  [data form]
  (let [osmfields (filter forms/osm? form)]
    (->> (for [datum data]
           (for [field osmfields]
             (let [osmkey (:full-name field)
                   osmdatum (get datum osmkey)
                   osmid (and osmdatum (re-find #"[0-9]+" osmdatum))]
               (when osmid
                 {osmid (merge {:field field}
                               (select-keys datum #{_id _rank}))}))))
         flatten
         (into {}))))

(defn osm-xml->geojson
  "Takes OSM XML in string form, and returns cljs geojson."
  [osm-xml-string]
  (js->clj (js/osmtogeojson (.parseXML js/jQuery osm-xml-string))
           :keywordize-keys true))

(defn osm-id->osm-data
  "Given some data in OSM format, an Ona Form, and osm xml string,
   return a map from OSM ID to each osm feature. The map contains:
   :osm-id, :name, :tags from osm xml,
   :type, :geom from osm feature's geojson equivalent."
  [data form osm-xml]
  (let [ona-osm-link (ona-osm-link data form)
        osmgeo (osm-xml->geojson osm-xml)
        featureset (osmgeo :features)]
    (into {}
          (for [{:keys [type properties geometry] :as feature} featureset]
            (let [{:keys [type id tags]} properties]
              {id {:osm-id id
                   :type type
                   :geom geometry
                   :name (:name tags)
                   :tags tags}})))))

(defn integrate-osm-data!
  "Given some data post-processed from the ona server
   (ie, containing _id, _rank), and a string of osm-xml, produce a version with
   relevant osm data injected in."
  [app-state form osm-xml app-state-keys]
  (let [osm-fields (filter forms/osm? form)]
    (when (seq osm-fields)
      (let [data (get-in app-state app-state-keys)
            osm-data (osm-id->osm-data data form osm-xml)
            osm-val->osm-id #(re-find #"[-]?[0-9]+" %)
            osm-val->osm-data (fn [osm-val osm-id]
                                ;; The OSM-val can be either a string or a
                                ;; precomputed osm-data value. This condition
                                ;; ensures only strings are parsed for OSM ids
                                (if (string? osm-val)
                                  (if-let [osm-submission-data
                                           (osm-data osm-id)]
                                    osm-submission-data
                                    osm-val)
                                  osm-val))
            updater (fn [osm-key]
                      (fn [data]
                        (for [datum data]
                          (let [osm-id (or
                                        (get-in datum [(str osm-key
                                                            ":way:id")])
                                        (get-in datum [(str osm-key
                                                            ":node:id")]))]
                            (update-in datum [osm-key]
                                       #(osm-val->osm-data % osm-id))))))]

        (doseq [osm-field osm-fields]
          (transact! app-state app-state-keys
                     (updater (:full-name osm-field))))))))

;; IMAGE AND VIDEO POST-PROCESSING

(defn url-obj
  "Calculate full image and thumbnail urls given attachment information."
  [media-obj]
  (let [media-id (get media-obj "id")
        fname (get media-obj "filename")
        file-url (ona-urls/media-url media-id fname)]
    {:filename fname
     :download_url file-url
     :small_download_url (str file-url "&suffix=small")}))

(defn get-matching-name
  "Gets and returns matching name for an attachment that was renamed by
  appending a hash on the S3 server to avoid duplicating names.
  e.g. if 1478203839187.jpg was renamed to 1478203839187_wijUzUf.jpg,
  it returns 1478203839187_wijUzUf.jpg."
  [fname fnames]
  (if (string? fname)
    (try
      (or
       (filter-first
        #(re-find
          (re-pattern (first (split fname (re-pattern "\\.")))) %)
        fnames)
       fname)
      (catch js/SyntaxError e
        fname))
    fname))

(defn get-attach-map
  "Helper function for integrate attachments; returns a function from
   a filename to a `url-obj` (see specs in `url-obj` function)."
  [record attachments]
  (let [attachments (or attachments (get record _attachments))
        fnames (map #(last-url-param (get % "filename")) attachments)
        fname->urlobj (zipmap fnames (map url-obj attachments))]
    ;; If urlobj isn't found, we'll just return filename
    (fn [fname] (get fname->urlobj (get-matching-name fname fnames) fname))))

(defn filter-media
  "Coll -> Coll"
  [flat-form]
  (filter #(or (forms/video? %) (forms/audio? %) (forms/image? %)) flat-form))

(defn integrate-attachments
  "Inlines media data from within _attachments into each record.
   Coll Coll -> Coll"
  [flat-form data & {:keys [attachments]}]
  (let [image-fields (filter-media flat-form)]
    (for [record data]
      (let [attach-map (get-attach-map record attachments)]
        (reduce (fn [record img-field]
                  (update-in record [(:full-name img-field)] attach-map))
                record
                image-fields)))))

(defn integrate-attachments-in-repeats
  "Inlines data from within _attachments into each datapoint within repeats."
  [flat-form data]
  (let [repeat-fields (filter forms/repeat? flat-form)
        integrate (fn [record rpt-field]
                    (let [key (:full-name rpt-field)]
                      (assoc record key
                             (integrate-attachments
                              (:children rpt-field)
                              (get record key)
                              :attachments
                              (get record _attachments)))))]
    (for [record data]
      (reduce integrate record repeat-fields))))

(defn integrate-attachments!
  "Inlines data from within _attachments into each record within app-state."
  [app-state flat-form & {:keys [app-data-keys]
                          :or {app-data-keys [:data]}}]
  (transact! app-state
             app-data-keys
             #(->> %
                   (integrate-attachments flat-form)
                   (integrate-attachments-in-repeats flat-form))))

Add forms audio function to filter-media function