(ns status-im.chat.handlers
  (:require [re-frame.core :refer [register-handler enrich after debug dispatch]]
            [status-im.models.commands :as commands]
            [clojure.string :as str]
            [status-im.chat.suggestions :as suggestions]
            [status-im.protocol.api :as api]
            [status-im.models.messages :as messages]
            [status-im.constants :refer [text-content-type
                                         content-type-command]]
            [status-im.utils.random :as random]
            [status-im.chat.sign-up :as sign-up-service]
            [status-im.models.chats :as chats]
            [status-im.navigation.handlers :as nav]
            [status-im.utils.handlers :as u]
            [status-im.persistence.realm :as r]))

(register-handler :set-show-actions
  (fn [db [_ show-actions]]
    (assoc db :show-actions show-actions)))

(register-handler :load-more-messages
  (fn [db _]
    db
    ;; TODO implement
    #_(let [chat-id      (get-in db [:chat :current-chat-id])
            messages     [:chats chat-id :messages]
            new-messages (gen-messages 10)]
        (update-in db messages concat new-messages))))

(defn safe-trim [s]
  (when (string? s)
    (str/trim s)))

(register-handler :cancel-command
  (fn [{:keys [current-chat-id] :as db} _]
    (-> db
        (assoc-in [:chats current-chat-id :command-input] {})
        (update-in [:chats current-chat-id :input-text] safe-trim))))

(register-handler :set-chat-command-content
  (fn [db [_ content]]
    (commands/set-chat-command-content db content)))

(defn update-input-text
  [{:keys [current-chat-id] :as db} text]
  (assoc-in db [:chats current-chat-id :input-text] text))

(register-handler :stage-command
  (fn [{:keys [current-chat-id] :as db} _]
    (let [db           (update-input-text db nil)
          {:keys [command content]}
          (get-in db [:chats current-chat-id :command-input])
          command-info {:command command
                        :content content
                        :handler (:handler command)}]
      (commands/stage-command db command-info))))

(register-handler :set-response-chat-command
  (fn [db [_ to-msg-id command-key]]
    (commands/set-response-chat-command db to-msg-id command-key)))

(defn update-text
  [db [_ text]]
  (update-input-text db text))

(defn update-command [db [_ text]]
  (let [{:keys [command]} (suggestions/check-suggestion db text)]
    (commands/set-chat-command db command)))

(register-handler :set-chat-input-text
  ((enrich update-command) update-text))

(defn console? [s]
  (= "console" s))

(def not-console?
  (complement console?))

(defn check-author-direction
  [db chat-id {:keys [from outgoing] :as message}]
  (let [previous-message (first (get-in db [:chats chat-id :messages]))]
    (merge message
           {:same-author    (if previous-message
                              (= (:from previous-message) from)
                              true)
            :same-direction (if previous-message
                              (= (:outgoing previous-message) outgoing)
                              true)})))

(defn add-message-to-db
  [db chat-id message]
  (let [messages [:chats chat-id :messages]]
    (update-in db messages conj message)))

(defn prepare-message
  [{:keys [identity current-chat-id] :as db} _]
  (let [text    (get-in db [:chats current-chat-id :input-text])
        {:keys [command]} (suggestions/check-suggestion db (str text " "))
        message (check-author-direction
                  db current-chat-id
                  {:msg-id       (random/id)
                   :chat-id      current-chat-id
                   :content      text
                   :to           current-chat-id
                   :from         identity
                   :content-type text-content-type
                   :outgoing     true})]
    (if command
      (commands/set-chat-command db command)
      (assoc db :new-message (when-not (str/blank? text) message)))))

(defn prepare-command [identity chat-id staged-command]
  (let [command-key (get-in staged-command [:command :command])
        content     {:command (name command-key)
                     :content (:content staged-command)}]
    {:msg-id       (random/id)
     :from         identity
     :to           chat-id
     :content      content
     :content-type content-type-command
     :outgoing     true
     :handler      (:handler staged-command)}))

(defn prepare-staged-commans
  [{:keys [current-chat-id identity] :as db} _]
  (let [staged-commands (get-in db [:chats current-chat-id :staged-commands])]
    (->> staged-commands
         (map #(prepare-command identity current-chat-id %))
         ;todo this is wrong :(
         (map #(check-author-direction db current-chat-id %))
         (assoc db :new-commands))))

(defn add-message
  [{:keys [new-message current-chat-id] :as db}]
  (if new-message
    (add-message-to-db db current-chat-id new-message)
    db))

(defn add-commands
  [{:keys [new-commands current-chat-id] :as db}]
  (reduce
    #(add-message-to-db %1 current-chat-id %2)
    db
    new-commands))

(defn clear-input
  [{:keys [current-chat-id new-message] :as db} _]
  (if new-message
    (assoc-in db [:chats current-chat-id :input-text] nil)
    db))

(defn clear-staged-commands
  [{:keys [current-chat-id] :as db} _]
  (assoc-in db [:chats current-chat-id :staged-commands] []))

(defn send-message!
  [{:keys [new-message current-chat-id] :as db} _]
  (when (and new-message (not-console? current-chat-id))
    (let [{:keys [group-chat]} (get-in db [:chats current-chat-id])
          content (:content new-message)]
      (if group-chat
        (api/send-group-user-msg {:group-id current-chat-id
                                  :content  content})
        (api/send-user-msg {:to      current-chat-id
                            :content content})))))

(defn save-message-to-realm!
  [{:keys [new-message current-chat-id]} _]
  (when new-message
    (messages/save-message current-chat-id new-message)))

(defn save-commands-to-realm!
  [{:keys [new-commands current-chat-id]} _]
  (doseq [new-command new-commands]
    (messages/save-message current-chat-id (dissoc new-command :handler))))

(defn handle-commands
  [{:keys [new-commands]}]
  (doseq [{{content :content} :content
           handler            :handler} new-commands]
    (when handler
      (handler content))))

(register-handler :send-chat-msg
  (-> prepare-message
      ((enrich prepare-staged-commans))
      ((enrich add-message))
      ((enrich add-commands))
      ((enrich clear-input))
      ((enrich clear-staged-commands))
      ;; todo uncomment once
      ;((after send-message!))
      ((after save-message-to-realm!))
      ((after save-commands-to-realm!))
      ((after handle-commands))))

(register-handler :unstage-command
  (fn [db [_ staged-command]]
    (commands/unstage-command db staged-command)))

(register-handler :set-chat-command
  (fn [db [_ command-key]]
    ;; todo what is going on there?!
    (commands/set-chat-command db command-key)))

(register-handler :init-console-chat
  (fn [db [_]]
    (sign-up-service/init db)))

(register-handler :save-password
  (fn [db [_ password]]
    (sign-up-service/save-password password)
    (assoc db :password-saved true)))

(register-handler :sign-up
  (-> (fn [db [_ phone-number]]
        ;; todo save phone number to db
        (assoc db :user-phone-number phone-number))
      ((after (fn [& _] (sign-up-service/on-sign-up-response))))))

(register-handler :sign-up-confirm
  (fn [db [_ confirmation-code]]
    (sign-up-service/on-send-code-response confirmation-code)
    (sign-up-service/set-signed-up db true)))

(register-handler :set-signed-up
  (fn [db [_ signed-up]]
    (sign-up-service/set-signed-up db signed-up)))

(defn load-messages!
  ([db] (load-messages! db nil))
  ([db _]
   (->> (:current-chat-id db)
        messages/get-messages
        (assoc db :messages))))

(defn init-chat
  ([db] (init-chat db nil))
  ([{:keys [messages current-chat-id] :as db} _]
   (assoc-in db [:chats current-chat-id :messages] messages)))

(register-handler :init-chat
  (-> load-messages!
      ((enrich init-chat))
      debug))

(defn initialize-chats
  [{:keys [loaded-chats] :as db} _]
  (let [chats (->> loaded-chats
                   (map (fn [{:keys [chat-id] :as chat}]
                          [chat-id chat]))
                   (into {}))
        ids   (set (keys chats))]
    (-> db
        (assoc :chats chats)
        (assoc :chats-ids ids)
        (dissoc :loaded-chats))))

(defn load-chats!
  [db _]
  (assoc db :loaded-chats (chats/chats-list)))

(register-handler :initialize-chats
  ((enrich initialize-chats) load-chats!))

(defn store-message!
  [{:keys [new-message]} [_ {chat-id :from}]]
  (messages/save-message chat-id new-message))

(defn receive-message
  [db [_ {chat-id :from :as message}]]
  (let [message' (check-author-direction db chat-id message)]
    (-> db
        (add-message-to-db chat-id message')
        (assoc :new-message message'))))

(register-handler :received-msg
  (-> receive-message
      ((after store-message!))))

(register-handler :group-received-msg
  (u/side-effect!
    (fn [_ [_ {chat-id :group-id :as msg}]]
      (messages/save-message chat-id msg))))

(defmethod nav/preload-data! :chat
  [{:keys [current-chat-id] :as db} [_ _ id]]
  (let [chat-id (or id current-chat-id)
        messages (get-in db [:chats chat-id :messages])
        db' (assoc db :current-chat-id chat-id)]
    (println "wuuut..." chat-id messages)
    (if (seq messages)
      db'
      (-> db'
          load-messages!
          init-chat))))

(defn prepare-chat
  [{:keys [contacts] :as db} [_ contcat-id]]
  (let [name (get-in contacts [contcat-id :name])
        chat {:chat-id    contcat-id
              :name       name
              :group-chat false
              :is-active  true
              :timestamp  (.getTime (js/Date.))
              :contacts   [{:identity contcat-id}]}]
    (assoc db :new-chat chat)))

(defn add-chat [{:keys [new-chat] :as db} [_ chat-id]]
  (-> db
      (update :chats assoc chat-id new-chat)
      (update :chats-ids conj chat-id)))

(defn save-chat!
  [{:keys [new-chat]} _]
  (chats/create-chat new-chat))

(defn open-chat!
  [_ [_ chat-id]]
  (dispatch [:navigate-to :chat chat-id]))

(register-handler :start-chat
  (-> prepare-chat
      ((enrich add-chat))
      ((after save-chat!))
      ((after open-chat!))))

(register-handler :switch-command-suggestions
  (fn [db [_]]
    (suggestions/switch-command-suggestions db)))

(defn remove-chat
  [{:keys [current-chat-id] :as db} _]
  (update db :chats dissoc current-chat-id))

(defn notify-about-leaving!
  [{:keys [current-chat-id]} _]
  (api/leave-group-chat current-chat-id))

; todo do we really need this message?
(defn leaving-message!
  [{:keys [current-chat-id]} _]
  (messages/save-message
    current-chat-id
    {:from         "system"
     :msg-id       (random/id)
     :content      "You left this chat"
     :content-type text-content-type}))

(defn delete-messages!
  [{:keys [current-chat-id]} _]
  (r/write
    (fn []
      (r/delete (r/get-by-field :msgs :chat-id current-chat-id)))))

(defn delete-chat!
  [{:keys [current-chat-id]} _]
  (r/write
    (fn []
      (-> (r/get-by-field :chats :chat-id current-chat-id)
          (r/single)
          (r/delete)))))

(register-handler :leave-group-chat
  ;; todo oreder of operations tbd
  (after (fn [_ _] (dispatch [:navigation-replace :chat-list])))
  (-> remove-chat
      ;; todo uncomment
      ;((after notify-about-leaving!))
      ;((after leaving-message!))
      ((after delete-messages!))
      ((after delete-chat!))))

(ns status-im.chat.handlers
  (:require [re-frame.core :refer [register-handler enrich after debug dispatch]]
            [status-im.models.commands :as commands]
            [clojure.string :as str]
            [status-im.chat.suggestions :as suggestions]
            [status-im.protocol.api :as api]
            [status-im.models.messages :as messages]
            [status-im.constants :refer [text-content-type
                                         content-type-command]]
            [status-im.utils.random :as random]
            [status-im.chat.sign-up :as sign-up-service]
            [status-im.models.chats :as chats]
            [status-im.navigation.handlers :as nav]
            [status-im.utils.handlers :as u]
            [status-im.persistence.realm :as r]))

(register-handler :set-show-actions
  (fn [db [_ show-actions]]
    (assoc db :show-actions show-actions)))

(register-handler :load-more-messages
  (fn [db _]
    db
    ;; TODO implement
    #_(let [chat-id      (get-in db [:chat :current-chat-id])
            messages     [:chats chat-id :messages]
            new-messages (gen-messages 10)]
        (update-in db messages concat new-messages))))

(defn safe-trim [s]
  (when (string? s)
    (str/trim s)))

(register-handler :cancel-command
  (fn [{:keys [current-chat-id] :as db} _]
    (-> db
        (assoc-in [:chats current-chat-id :command-input] {})
        (update-in [:chats current-chat-id :input-text] safe-trim))))

(register-handler :set-chat-command-content
  (fn [db [_ content]]
    (commands/set-chat-command-content db content)))

(defn update-input-text
  [{:keys [current-chat-id] :as db} text]
  (assoc-in db [:chats current-chat-id :input-text] text))

(register-handler :stage-command
  (fn [{:keys [current-chat-id] :as db} _]
    (let [db           (update-input-text db nil)
          {:keys [command content]}
          (get-in db [:chats current-chat-id :command-input])
          command-info {:command command
                        :content content
                        :handler (:handler command)}]
      (commands/stage-command db command-info))))

(register-handler :set-response-chat-command
  (fn [db [_ to-msg-id command-key]]
    (commands/set-response-chat-command db to-msg-id command-key)))

(defn update-text
  [db [_ text]]
  (update-input-text db text))

(defn update-command [db [_ text]]
  (let [{:keys [command]} (suggestions/check-suggestion db text)]
    (commands/set-chat-command db command)))

(register-handler :set-chat-input-text
  ((enrich update-command) update-text))

(defn console? [s]
  (= "console" s))

(def not-console?
  (complement console?))

(defn check-author-direction
  [db chat-id {:keys [from outgoing] :as message}]
  (let [previous-message (first (get-in db [:chats chat-id :messages]))]
    (merge message
           {:same-author    (if previous-message
                              (= (:from previous-message) from)
                              true)
            :same-direction (if previous-message
                              (= (:outgoing previous-message) outgoing)
                              true)})))

(defn add-message-to-db
  [db chat-id message]
  (let [messages [:chats chat-id :messages]]
    (update-in db messages conj message)))

(defn prepare-message
  [{:keys [identity current-chat-id] :as db} _]
  (let [text    (get-in db [:chats current-chat-id :input-text])
        {:keys [command]} (suggestions/check-suggestion db (str text " "))
        message (check-author-direction
                  db current-chat-id
                  {:msg-id       (random/id)
                   :chat-id      current-chat-id
                   :content      text
                   :to           current-chat-id
                   :from         identity
                   :content-type text-content-type
                   :outgoing     true})]
    (if command
      (commands/set-chat-command db command)
      (assoc db :new-message (when-not (str/blank? text) message)))))

(defn prepare-command [identity chat-id staged-command]
  (let [command-key (get-in staged-command [:command :command])
        content     {:command (name command-key)
                     :content (:content staged-command)}]
    {:msg-id       (random/id)
     :from         identity
     :to           chat-id
     :content      content
     :content-type content-type-command
     :outgoing     true
     :handler      (:handler staged-command)}))

(defn prepare-staged-commans
  [{:keys [current-chat-id identity] :as db} _]
  (let [staged-commands (get-in db [:chats current-chat-id :staged-commands])]
    (->> staged-commands
         (map #(prepare-command identity current-chat-id %))
         ;todo this is wrong :(
         (map #(check-author-direction db current-chat-id %))
         (assoc db :new-commands))))

(defn add-message
  [{:keys [new-message current-chat-id] :as db}]
  (if new-message
    (add-message-to-db db current-chat-id new-message)
    db))

(defn add-commands
  [{:keys [new-commands current-chat-id] :as db}]
  (reduce
    #(add-message-to-db %1 current-chat-id %2)
    db
    new-commands))

(defn clear-input
  [{:keys [current-chat-id new-message] :as db} _]
  (if new-message
    (assoc-in db [:chats current-chat-id :input-text] nil)
    db))

(defn clear-staged-commands
  [{:keys [current-chat-id] :as db} _]
  (assoc-in db [:chats current-chat-id :staged-commands] []))

(defn send-message!
  [{:keys [new-message current-chat-id] :as db} _]
  (when (and new-message (not-console? current-chat-id))
    (let [{:keys [group-chat]} (get-in db [:chats current-chat-id])
          content (:content new-message)]
      (if group-chat
        (api/send-group-user-msg {:group-id current-chat-id
                                  :content  content})
        (api/send-user-msg {:to      current-chat-id
                            :content content})))))

(defn save-message-to-realm!
  [{:keys [new-message current-chat-id]} _]
  (when new-message
    (messages/save-message current-chat-id new-message)))

(defn save-commands-to-realm!
  [{:keys [new-commands current-chat-id]} _]
  (doseq [new-command new-commands]
    (messages/save-message current-chat-id (dissoc new-command :handler))))

(defn handle-commands
  [{:keys [new-commands]}]
  (doseq [{{content :content} :content
           handler            :handler} new-commands]
    (when handler
      (handler content))))

(register-handler :send-chat-msg
  (-> prepare-message
      ((enrich prepare-staged-commans))
      ((enrich add-message))
      ((enrich add-commands))
      ((enrich clear-input))
      ((enrich clear-staged-commands))
      ;; todo uncomment once
      ;((after send-message!))
      ((after save-message-to-realm!))
      ((after save-commands-to-realm!))
      ((after handle-commands))))

(register-handler :unstage-command
  (fn [db [_ staged-command]]
    (commands/unstage-command db staged-command)))

(register-handler :set-chat-command
  (fn [db [_ command-key]]
    ;; todo what is going on there?!
    (commands/set-chat-command db command-key)))

(register-handler :init-console-chat
  (fn [db [_]]
    (sign-up-service/init db)))

(register-handler :save-password
  (fn [db [_ password]]
    (sign-up-service/save-password password)
    (assoc db :password-saved true)))

(register-handler :sign-up
  (-> (fn [db [_ phone-number]]
        ;; todo save phone number to db
        (assoc db :user-phone-number phone-number))
      ((after (fn [& _] (sign-up-service/on-sign-up-response))))))

(register-handler :sign-up-confirm
  (fn [db [_ confirmation-code]]
    (sign-up-service/on-send-code-response confirmation-code)
    (sign-up-service/set-signed-up db true)))

(register-handler :set-signed-up
  (fn [db [_ signed-up]]
    (sign-up-service/set-signed-up db signed-up)))

(defn load-messages!
  ([db] (load-messages! db nil))
  ([db _]
   (->> (:current-chat-id db)
        messages/get-messages
        (assoc db :messages))))

(defn init-chat
  ([db] (init-chat db nil))
  ([{:keys [messages current-chat-id] :as db} _]
   (assoc-in db [:chats current-chat-id :messages] messages)))

(register-handler :init-chat
  (-> load-messages!
      ((enrich init-chat))
      debug))

(defn initialize-chats
  [{:keys [loaded-chats] :as db} _]
  (let [chats (->> loaded-chats
                   (map (fn [{:keys [chat-id] :as chat}]
                          [chat-id chat]))
                   (into {}))
        ids   (set (keys chats))]
    (-> db
        (assoc :chats chats)
        (assoc :chats-ids ids)
        (dissoc :loaded-chats))))

(defn load-chats!
  [db _]
  (assoc db :loaded-chats (chats/chats-list)))

(register-handler :initialize-chats
  ((enrich initialize-chats) load-chats!))

(defn store-message!
  [{:keys [new-message]} [_ {chat-id :from}]]
  (messages/save-message chat-id new-message))

(defn receive-message
  [db [_ {chat-id :from :as message}]]
  (let [message' (check-author-direction db chat-id message)]
    (-> db
        (add-message-to-db chat-id message')
        (assoc :new-message message'))))

(register-handler :received-msg
  (-> receive-message
      ((after store-message!))))

(register-handler :group-received-msg
  (u/side-effect!
    (fn [_ [_ {chat-id :group-id :as msg}]]
      (messages/save-message chat-id msg))))

(defmethod nav/preload-data! :chat
  [{:keys [current-chat-id] :as db} [_ _ id]]
  (let [chat-id (or id current-chat-id)
        messages (get-in db [:chats chat-id :messages])
        db' (assoc db :current-chat-id chat-id)]
    (if (seq messages)
      db'
      (-> db'
          load-messages!
          init-chat))))

(defn prepare-chat
  [{:keys [contacts] :as db} [_ contcat-id]]
  (let [name (get-in contacts [contcat-id :name])
        chat {:chat-id    contcat-id
              :name       name
              :group-chat false
              :is-active  true
              :timestamp  (.getTime (js/Date.))
              :contacts   [{:identity contcat-id}]}]
    (assoc db :new-chat chat)))

(defn add-chat [{:keys [new-chat] :as db} [_ chat-id]]
  (-> db
      (update :chats assoc chat-id new-chat)
      (update :chats-ids conj chat-id)))

(defn save-chat!
  [{:keys [new-chat]} _]
  (chats/create-chat new-chat))

(defn open-chat!
  [_ [_ chat-id]]
  (dispatch [:navigate-to :chat chat-id]))

(register-handler :start-chat
  (-> prepare-chat
      ((enrich add-chat))
      ((after save-chat!))
      ((after open-chat!))))

(register-handler :switch-command-suggestions
  (fn [db [_]]
    (suggestions/switch-command-suggestions db)))

(defn remove-chat
  [{:keys [current-chat-id] :as db} _]
  (update db :chats dissoc current-chat-id))

(defn notify-about-leaving!
  [{:keys [current-chat-id]} _]
  (api/leave-group-chat current-chat-id))

; todo do we really need this message?
(defn leaving-message!
  [{:keys [current-chat-id]} _]
  (messages/save-message
    current-chat-id
    {:from         "system"
     :msg-id       (random/id)
     :content      "You left this chat"
     :content-type text-content-type}))

(defn delete-messages!
  [{:keys [current-chat-id]} _]
  (r/write
    (fn []
      (r/delete (r/get-by-field :msgs :chat-id current-chat-id)))))

(defn delete-chat!
  [{:keys [current-chat-id]} _]
  (r/write
    (fn []
      (-> (r/get-by-field :chats :chat-id current-chat-id)
          (r/single)
          (r/delete)))))

(register-handler :leave-group-chat
  ;; todo oreder of operations tbd
  (after (fn [_ _] (dispatch [:navigation-replace :chat-list])))
  (-> remove-chat
      ;; todo uncomment
      ;((after notify-about-leaving!))
      ;((after leaving-message!))
      ((after delete-messages!))
      ((after delete-chat!))))

remove println

remove println

Former-commit-id: 86f80dc52560402abe0956abae83ee4092f35dc7


(ns todo-repl-webapp.handler
  (:gen-class :main true)
  (:use compojure.core
        hiccup.core)
  (:require [compojure.handler :as handler]
            [compojure.route :as route]
            [hiccup.form :as form]
            [hiccup.page :as page]
            [ring.adapter.jetty :as jetty]
            [todo-repl.core :as todo]))

(defn home-page [& _]
  (html [:head
          [:title "todo-repl"]
          (page/include-css "css/bootstrap.min.css")
          (page/include-js "http://code.jquery.com/jquery-1.10.1.min.js"
                           "js/bootstrap.min.js")]
        [:body
          [:div.col-md-7.col-md-offset-2
            [:h1 "todo-repl"]
            (form/form-to {:id "todoForm"}
                          [:post "/eval"]
                          (form/text-area {:class "form-control"}
                                          "evalInput"
                                          "blah")
                          [:br]
                          (form/submit-button {:id "todoSubmitButton"}
                                              "Eval"))]
          [:div#display.col-md-7.col-md-offset-2]
          (page/include-js "js/eval.js")]))
(defn eval-page [x & xs]
  (html [:h1 "Eval"]
        [:h2 x]))

(def *tasks-ref* (ref []))
(defn tasks [] (deref *tasks-ref*))
(defn add-new-task [x]
  (dosync (alter *tasks-ref* #(cons
                                (todo/new-task-better x)
                                %1))))
(defn add-to-tasks [x]
  (dosync (alter *tasks-ref* #(cons x %1))))

(defroutes app-routes
  (GET "/" [] (do (println "get /")
                  (home-page)))
  (POST "/eval" [evalInput]
    (do (println "/eval " evalInput)
        (binding [*ns* (find-ns 'todo-repl-webapp.handler)]
          (let [result (load-string evalInput)]
            (println "evals to: " result)
            (eval-page (str result))))))
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  (handler/site app-routes))

(defn -main [port]
  (jetty/run-jetty app-routes {:port (Integer. port) :join? false}))

(ns todo-repl-webapp.handler
  (:gen-class :main true)
  (:use compojure.core
        hiccup.core)
  (:require [compojure.handler :as handler]
            [compojure.route :as route]
            [hiccup.form :as form]
            [hiccup.page :as page]
            [ring.adapter.jetty :as jetty]
            [todo-repl.core :as todo]))

(defn home-page [& _]
  (html [:head
          [:title "todo-repl"]
          (page/include-css "css/bootstrap.min.css")
          (page/include-js "http://code.jquery.com/jquery-1.10.1.min.js"
                           "js/bootstrap.min.js")]
        [:body
          [:div.col-md-7.col-md-offset-2
            [:h1 "todo-repl"]
            (form/form-to {:id "todoForm"}
                          [:post "/eval"]
                          (form/text-area {:class "form-control"}
                                          "evalInput"
                                          "blah")
                          [:br]
                          (form/submit-button {:id "todoSubmitButton"}
                                              "Eval"))]
          [:div#display.col-md-7.col-md-offset-2]
          (page/include-js "js/eval.js")]))
(defn eval-page [x & xs]
  (html [:h1 "Eval"]
        [:h2 x]))

(def *tasks-ref* (ref []))
(defn tasks [] (deref *tasks-ref*))
(defn add-new-task [x]
  (dosync (alter *tasks-ref* #(cons
                                (todo/new-task-better x)
                                %1))))
(defn add-to-tasks [x]
  (dosync (alter *tasks-ref* #(cons x %1))))

(defroutes app-routes
  (GET "/" [] (do (println "get /")
                  (home-page)))
  (POST "/eval" [evalInput]
    (if (nil? evalInput)
      (eval-page "nil")
      (do (println "/eval " evalInput)
          (binding [*ns* (find-ns 'todo-repl-webapp.handler)]
            (let [result (load-string evalInput)]
              (println "evals to: " result)
              (eval-page (str result)))))))
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  (handler/site app-routes))

(defn -main [port]
  (jetty/run-jetty app-routes {:port (Integer. port) :join? false}))

Add better handling for nil in post function.


(ns cmr.search.services.query-execution.facets.hierarchical-links-helper
  "Functions to create links for hierarchical fields within v2 facets. Facets (v2) includes links
  within each value to conduct the same search with either a value added to the query or with the
  value removed. This namespace contains functions to create the links that include or exclude a
  particular parameter.

  Commonly used parameters in the functions include:

  base-url - root URL for the link being created.
  query-params - the query parameters from the current search as a map with a key for each
                 parameter name and the value as either a single value or a collection of values.
  field-name - the query-field that needs to be added to (or removed from) the current search.
  value - the value to apply (or remove) for the given field-name."
  (:require [camel-snake-kebab.core :as csk]
            [clojure.string :as str]
            [cmr.common.util :as util]
            [cmr.search.services.query-execution.facets.links-helper :as lh]))

(defn- get-max-index-for-field-name
  "Returns the max index for the provided field-name within the query parameters.

  For example if the query parameters included fields foo[0][alpha]=bar and foo[6][beta]=zeta the
  max index of field foo would be 6. If the field is not found then -1 is returned."
  [query-params base-field]
  (let [field-regex (re-pattern (format "%s\\[(\\d+)\\]\\[.*\\]" base-field))
        indexes (keep #(some-> (re-matches field-regex %) second Integer/parseInt)
                      (keys query-params))]
    (apply max -1 indexes)))

(defn- split-into-base-field-and-subfield
  "Takes a query parameter name and returns the base field and subfield for that query parameter.
  For example \"science_keywords_h[0][topic]\" returns [\"science_keywords_h\" \"topic\"]"
  [param-name]
  (let [[_ base-field subfield] (re-find #"(.*)\[\d+\]\[(.*)\]" param-name)]
    [base-field subfield]))

(defn create-apply-link-for-hierarchical-field
  "Create a link that will modify the current search to also filter by the given hierarchical
  field-name and value.
  Field-name must be of the form <string>[<int>][<string>] such as science_keywords[0][topic]."
  [base-url query-params field-name ancestors-map parent-indexes value has-siblings? _]
  (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
        index-to-use (if (or has-siblings? (empty? parent-indexes))
                       (inc (get-max-index-for-field-name query-params base-field))
                       (first parent-indexes))
        updated-field-name (format "%s[%d][%s]" base-field index-to-use subfield)
        updated-query-params (assoc query-params updated-field-name value)
        updated-query-params (if (or has-siblings? (empty? parent-indexes))
                               ;; Add all of the ancestors for this index
                               (reduce
                                (fn [query-params [k v]]
                                  (let [query-param (format "%s[%d][%s]" base-field index-to-use k)]
                                    (assoc query-params query-param v)))
                                updated-query-params
                                (dissoc ancestors-map "category"))
                               updated-query-params)]
    {:apply (lh/generate-query-string base-url updated-query-params)}))

(defn- get-keys-to-update
  "Returns a sequence of keys that have multiple values where at least one of values matches the
  passed in value. Looks for matches case insensitively."
  [query-params value]
  (let [value (str/lower-case value)]
    (keep (fn [[k value-or-values]]
            (when (coll? value-or-values)
              (when (some #{value} (map str/lower-case value-or-values))
                k)))
          query-params)))

(defn- get-keys-to-remove
  "Returns a sequence of keys that have a single value which matches the passed in value. Looks for
  matches case insensitively."
  [query-params value]
  (let [value (str/lower-case value)]
    (keep (fn [[k value-or-values]]
            (when-not (coll? value-or-values)
              (when (= (str/lower-case value-or-values) value)
                k)))
          query-params)))

(defn get-potential-matching-query-params
  "Returns a subset of query parameters whose keys match the provided field-name and ignoring the
  index.

  As an example, consider passing in a field-name of foo[0][alpha] and query parameters
  of foo[0][alpha]=fish, foo[0][beta]=cat, and foo[1][alpha]=dog. The returned query params would be
  foo[0][alpha]=fish and foo[1][alpha]=dog, but not foo[0][beta]=cat. Note that the same query
  params would also be returned for any field-name of foo[<n>][alpha] where n is an integer.
  Field-name must be of the form <string>[<int>][<string>]."
  [query-params field-name]
  (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
        field-regex (re-pattern (format "%s.*%s]" base-field subfield))
        matching-keys (keep #(re-matches field-regex %) (keys query-params))]
    (when (seq matching-keys)
      (select-keys query-params matching-keys))))

(defn- remove-value-from-query-params-for-hierachical-field
  "Removes the value from anywhere it matches in the provided potential-query-param-matches.
  Each key in the potential-query-param-matches may contain a single value or a collection of
  values. If the key contains a single value which matches the passed in value the query parameter
  is removed completely. Otherwise if the value matches one of the values in a collection of values
  only the matching value is removed for that query parameter. All value comparisons are performed
  case insensitively."
  [query-params potential-query-param-matches value]
  (let [updated-query-params (apply dissoc query-params
                                    (get-keys-to-remove potential-query-param-matches value))]
    (reduce (fn [updated-params k]
                (update updated-params k
                 (fn [existing-values]
                   (remove (fn [existing-value]
                             (= value (str/lower-case existing-value)))
                           existing-values))))
            updated-query-params
            (get-keys-to-update potential-query-param-matches value))))

(defn- process-removal-for-field-value-tuple
  "Helper to process a subfield and value tuple to remove the appropriate term from the query
  parameters."
  ([base-field potential-qp-matches query-params field-value-tuple]
   (let [[field value] field-value-tuple
         value (str/lower-case value)
         field-name (format "%s[0][%s]" base-field (csk/->snake_case_string field))
         potential-qp-matches (or potential-qp-matches
                                  (get-potential-matching-query-params query-params field-name))]
     (remove-value-from-query-params-for-hierachical-field query-params potential-qp-matches value))))

(defn- remove-duplicate-params
  "Removes any parameters for the provided field which are exact subsets of another index for the
  same field."
  [query-params base-field]
  (let [potential-qps (filter (fn [[k _]]
                                (re-find (re-pattern base-field) k))
                              query-params)   ;; Eliminate any params we do not care about
        ;; Group the remaining params by index
        param-groups-by-index (group-by (fn [[k _]]
                                          (second (re-find #"\[\d+\]" k)))
                                        potential-qps)
        ;; Iterate through each set of parameters
        indexes-to-remove
         (set
          (flatten
           (for [[idx qps] param-groups-by-index
                 :let [qps (util/map-keys #(str/replace % #"\[\d+\]" "")
                                          (into {} qps))]]
             (keep (fn [[matching-index matching-qps]]
                     (when (and (not= idx matching-index)
                                ;; remove the index
                                (let [matching-qps (util/map-keys #(str/replace % #"\[\d+\]" "")
                                                                  (into {} matching-qps))]
                                  ;; another group of params fully contains this group of params
                                  (and (= qps (select-keys matching-qps (keys qps)))
                                       (or (not= qps matching-qps)
                                           (< (Integer/parseInt (format "%s" idx))
                                              (Integer/parseInt (format "%s" matching-index)))))))
                       idx))
                   param-groups-by-index))))
        query-keys-to-remove (mapcat #(keys (get param-groups-by-index %)) indexes-to-remove)]
    (if (seq query-keys-to-remove)
      (apply dissoc query-params query-keys-to-remove)
      query-params)))

(defn create-remove-link-for-hierarchical-field
  "Create a link that will modify the current search to no longer filter on the given hierarchical
  field-name and value. Looks for matches case insensitively.
  Field-name must be of the form <string>[<int>][<string>].

  applied-children-tuples - Tuples of [subfield term] for any applied children terms that should
                            also be removed in the remove link being generated."
  ([base-url query-params field-name _ _ value _ applied-children-tuples]
   (create-remove-link-for-hierarchical-field base-url query-params field-name _ _ value _ applied-children-tuples nil))
  ([base-url query-params field-name _ _ value _ applied-children-tuples potential-qp-matches]
   (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
         updated-params (reduce (partial process-removal-for-field-value-tuple base-field potential-qp-matches)
                                query-params
                                (conj applied-children-tuples [subfield value]))
         updated-params (remove-duplicate-params updated-params base-field)]
     {:remove (lh/generate-query-string base-url updated-params)})))

(defn create-link-for-hierarchical-field
  "Creates either a remove or an apply link based on whether this particular value is already
  selected within a query. Returns a map with the key being the type of link created and value is
  the link itself. The Field-name must be a hierarchical field which has the form
  <string>[<int>][<string>].

  applied-children-tuples - Tuples of [subfield term] for any applied children terms that should
                            also be removed if a remove link is being generated."
  ([base-url query-params field-name value]
   (create-link-for-hierarchical-field base-url query-params field-name nil nil value false nil))
  ([base-url query-params field-name ancestors-map parent-indexes value has-siblings?
    applied-children-tuples]
   (if (keys (dissoc ancestors-map "category"))
     ;; Check if all ancestors are in the query-params with the parent index
    ;  (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
     (let [[_ base-field subfield] (re-find #"(.*)\[\d+\]\[(.*)\]" field-name)
           ;; In order for a field to be considered for removal, it and all of its ancestors must
           ;; be found in the query parameters. This builds a sequence of query parameters to check
           ;; against (one set of query parameters for each potential parent index).
           ancestors-to-match (map (fn [idx]
                                     (util/map-keys #(format "%s[%d][%s]" base-field idx %)
                                                    (assoc ancestors-map subfield value)))
                                   parent-indexes)
           num-ancestors (count (first ancestors-to-match))
           ;; Sequences of actual matches against the query parameters for each potential index
           ancestor-matches (map (fn [ancestor]
                                   (into {} (for [[k v] ancestor
                                                  :when (= (str/lower-case v)
                                                           (some-> (get query-params k) str/lower-case))]
                                              [k v])))
                                 ancestors-to-match)
           ;; Check if any of the sequences of query parameters to match, matched every parameter
           ancestors-found? (= num-ancestors (apply max -1 (map count ancestor-matches)))]
       (if ancestors-found?
         (let [potential-qp-matches (->> (filter #(= (count (first ancestors-to-match)) (count %))
                                                 ancestor-matches)
                                         (map keys)
                                         (map first)
                                         (map (fn [qp]
                                                (str/replace-first qp #"\]\[.*\]"
                                                                   (format "][%s]" subfield))))
                                         (select-keys query-params))
               indexes (some->> potential-qp-matches
                                keys
                                (map #(re-find #"\[\d+\]" %))
                                (map second)
                                set)
               child-matches (mapcat
                               (fn [idx]
                                 (concat (for [[k v] applied-children-tuples]
                                           [(format "%s[%s][%s]" base-field idx (csk/->snake_case_string k))
                                            v])))
                               indexes)]
           (create-remove-link-for-hierarchical-field
            base-url query-params field-name ancestors-map parent-indexes value has-siblings?
            applied-children-tuples (concat child-matches potential-qp-matches)))
         (create-apply-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples)))
     (let [potential-query-params (get-potential-matching-query-params query-params field-name)
           value-exists? (or (seq (get-keys-to-remove potential-query-params value))
                             (seq (get-keys-to-update potential-query-params value)))]
       (if value-exists?
         (create-remove-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples)
         (create-apply-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples))))))

(ns cmr.search.services.query-execution.facets.hierarchical-links-helper
  "Functions to create links for hierarchical fields within v2 facets. Facets (v2) includes links
  within each value to conduct the same search with either a value added to the query or with the
  value removed. This namespace contains functions to create the links that include or exclude a
  particular parameter.

  Commonly used parameters in the functions include:

  base-url - root URL for the link being created.
  query-params - the query parameters from the current search as a map with a key for each
                 parameter name and the value as either a single value or a collection of values.
  field-name - the query-field that needs to be added to (or removed from) the current search.
  value - the value to apply (or remove) for the given field-name."
  (:require [camel-snake-kebab.core :as csk]
            [clojure.string :as str]
            [cmr.common.util :as util]
            [cmr.search.services.query-execution.facets.links-helper :as lh]))

(defn- get-max-index-for-field-name
  "Returns the max index for the provided field-name within the query parameters.

  For example if the query parameters included fields foo[0][alpha]=bar and foo[6][beta]=zeta the
  max index of field foo would be 6. If the field is not found then -1 is returned."
  [query-params base-field]
  (let [field-regex (re-pattern (format "%s\\[(\\d+)\\]\\[.*\\]" base-field))
        indexes (keep #(some-> (re-matches field-regex %) second Integer/parseInt)
                      (keys query-params))]
    (apply max -1 indexes)))

(defn- split-into-base-field-and-subfield
  "Takes a query parameter name and returns the base field and subfield for that query parameter.
  For example \"science_keywords_h[0][topic]\" returns [\"science_keywords_h\" \"topic\"]"
  [param-name]
  (let [[_ base-field subfield] (re-find #"(.*)\[\d+\]\[(.*)\]" param-name)]
    [base-field subfield]))

(defn create-apply-link-for-hierarchical-field
  "Create a link that will modify the current search to also filter by the given hierarchical
  field-name and value.
  Field-name must be of the form <string>[<int>][<string>] such as science_keywords[0][topic]."
  [base-url query-params field-name ancestors-map parent-indexes value has-siblings? _]
  (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
        index-to-use (if (or has-siblings? (empty? parent-indexes))
                       (inc (get-max-index-for-field-name query-params base-field))
                       (first parent-indexes))
        updated-field-name (format "%s[%d][%s]" base-field index-to-use subfield)
        updated-query-params (assoc query-params updated-field-name value)
        updated-query-params (if (or has-siblings? (empty? parent-indexes))
                               ;; Add all of the ancestors for this index
                               (reduce
                                (fn [query-params [k v]]
                                  (let [query-param (format "%s[%d][%s]" base-field index-to-use k)]
                                    (assoc query-params query-param v)))
                                updated-query-params
                                (dissoc ancestors-map "category"))
                               updated-query-params)]
    {:apply (lh/generate-query-string base-url updated-query-params)}))

(defn- get-keys-to-update
  "Returns a sequence of keys that have multiple values where at least one of values matches the
  passed in value. Looks for matches case insensitively."
  [query-params value]
  (let [value (str/lower-case value)]
    (keep (fn [[k value-or-values]]
            (when (coll? value-or-values)
              (when (some #{value} (map str/lower-case value-or-values))
                k)))
          query-params)))

(defn- get-keys-to-remove
  "Returns a sequence of keys that have a single value which matches the passed in value. Looks for
  matches case insensitively."
  [query-params value]
  (let [value (str/lower-case value)]
    (keep (fn [[k value-or-values]]
            (when-not (coll? value-or-values)
              (when (= (str/lower-case value-or-values) value)
                k)))
          query-params)))

(defn get-potential-matching-query-params
  "Returns a subset of query parameters whose keys match the provided field-name and ignoring the
  index.

  As an example, consider passing in a field-name of foo[0][alpha] and query parameters
  of foo[0][alpha]=fish, foo[0][beta]=cat, and foo[1][alpha]=dog. The returned query params would be
  foo[0][alpha]=fish and foo[1][alpha]=dog, but not foo[0][beta]=cat. Note that the same query
  params would also be returned for any field-name of foo[<n>][alpha] where n is an integer.
  Field-name must be of the form <string>[<int>][<string>]."
  [query-params field-name]
  (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
        field-regex (re-pattern (format "%s.*%s]" base-field subfield))
        matching-keys (keep #(re-matches field-regex %) (keys query-params))]
    (when (seq matching-keys)
      (select-keys query-params matching-keys))))

(defn- remove-value-from-query-params-for-hierachical-field
  "Removes the value from anywhere it matches in the provided potential-query-param-matches.
  Each key in the potential-query-param-matches may contain a single value or a collection of
  values. If the key contains a single value which matches the passed in value the query parameter
  is removed completely. Otherwise if the value matches one of the values in a collection of values
  only the matching value is removed for that query parameter. All value comparisons are performed
  case insensitively."
  [query-params potential-query-param-matches value]
  (let [updated-query-params (apply dissoc query-params
                                    (get-keys-to-remove potential-query-param-matches value))]
    (reduce (fn [updated-params k]
                (update updated-params k
                 (fn [existing-values]
                   (remove (fn [existing-value]
                             (= value (str/lower-case existing-value)))
                           existing-values))))
            updated-query-params
            (get-keys-to-update potential-query-param-matches value))))

(defn- process-removal-for-field-value-tuple
  "Helper to process a subfield and value tuple to remove the appropriate term from the query
  parameters."
  ([base-field potential-qp-matches query-params field-value-tuple]
   (let [[field value] field-value-tuple
         value (str/lower-case value)
         field-name (format "%s[0][%s]" base-field (csk/->snake_case_string field))
         potential-qp-matches (or potential-qp-matches
                                  (get-potential-matching-query-params query-params field-name))]
     (remove-value-from-query-params-for-hierachical-field query-params potential-qp-matches value))))

(defn- remove-index-from-params
  "Returns the query parameters for the provided base-field with the index removed from the
  parameter name."
  [query-params base-field]
  (util/map-keys #(str/replace % #"\[\d+\]" "") query-params))

(defn- find-duplicate-indexes
  "Returns a set of indexes that have query parameters that are completely duplicated by another
  index for the given base field."
  [base-field params-by-index]
  (set
   (flatten
    (for [[idx qps] params-by-index
          :let [qps (remove-index-from-params qps base-field)]]
      (keep (fn [[matching-index matching-qps]]
              (when (and (not= idx matching-index)
                         ;; remove the index from the parameters to compare
                         (let [matching-qps (remove-index-from-params matching-qps base-field)]
                           ;; another group of params fully contains this group of params
                           (and (= qps (select-keys matching-qps (keys qps)))
                                (or (not= qps matching-qps)
                                    ;; If multiple sets of parameters exactly match, get rid of one
                                    ;; and keep one
                                    (< idx matching-index)))))
                idx))
            params-by-index)))))

(defn- remove-duplicate-params
  "Removes any parameters for the provided field which are exact subsets of another index for the
  same field."
  [query-params base-field]
  (let [base-field-params-by-index (group-by (fn [[k _]]
                                               (when (re-find (re-pattern base-field) k)
                                                 (->> (re-find #"\[\d+\]" k)
                                                      second
                                                      (format "%s")
                                                      Integer/parseInt)))
                                             query-params)
        indexes-to-remove (find-duplicate-indexes base-field base-field-params-by-index)
        query-keys-to-remove (mapcat #(keys (get base-field-params-by-index %)) indexes-to-remove)]
    (if (seq query-keys-to-remove)
      (apply dissoc query-params query-keys-to-remove)
      query-params)))

(defn create-remove-link-for-hierarchical-field
  "Create a link that will modify the current search to no longer filter on the given hierarchical
  field-name and value. Looks for matches case insensitively.
  Field-name must be of the form <string>[<int>][<string>].

  applied-children-tuples - Tuples of [subfield term] for any applied children terms that should
                            also be removed in the remove link being generated."
  ([base-url query-params field-name _ _ value _ applied-children-tuples]
   (create-remove-link-for-hierarchical-field base-url query-params field-name _ _ value _ applied-children-tuples nil))
  ([base-url query-params field-name _ _ value _ applied-children-tuples potential-qp-matches]
   (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
         updated-params (reduce (partial process-removal-for-field-value-tuple base-field potential-qp-matches)
                                query-params
                                (conj applied-children-tuples [subfield value]))
         updated-params (remove-duplicate-params updated-params base-field)]
     {:remove (lh/generate-query-string base-url updated-params)})))

(defn create-link-for-hierarchical-field
  "Creates either a remove or an apply link based on whether this particular value is already
  selected within a query. Returns a map with the key being the type of link created and value is
  the link itself. The Field-name must be a hierarchical field which has the form
  <string>[<int>][<string>].

  applied-children-tuples - Tuples of [subfield term] for any applied children terms that should
                            also be removed if a remove link is being generated."
  ([base-url query-params field-name value]
   (create-link-for-hierarchical-field base-url query-params field-name nil nil value false nil))
  ([base-url query-params field-name ancestors-map parent-indexes value has-siblings?
    applied-children-tuples]
   (if (keys (dissoc ancestors-map "category"))
     ;; Check if all ancestors are in the query-params with the parent index
     (let [[base-field subfield] (split-into-base-field-and-subfield field-name)
           ;; In order for a field to be considered for removal, it and all of its ancestors must
           ;; be found in the query parameters. This builds a sequence of query parameters to check
           ;; against (one set of query parameters for each potential parent index).
           ancestors-to-match (map (fn [idx]
                                     (util/map-keys #(format "%s[%d][%s]" base-field idx %)
                                                    (assoc ancestors-map subfield value)))
                                   parent-indexes)
           num-ancestors (count (first ancestors-to-match))
           ;; Sequences of actual matches against the query parameters for each potential index
           ancestor-matches (map (fn [ancestor]
                                   (into {} (for [[k v] ancestor
                                                  :when (= (str/lower-case v)
                                                           (some-> (get query-params k) str/lower-case))]
                                              [k v])))
                                 ancestors-to-match)
           ;; Check if any of the sequences of query parameters to match, matched every parameter
           ancestors-found? (= num-ancestors (apply max -1 (map count ancestor-matches)))]
       (if ancestors-found?
         (let [potential-qp-matches (->> (filter #(= (count (first ancestors-to-match)) (count %))
                                                 ancestor-matches)
                                         (map keys)
                                         (map first)
                                         (map (fn [qp]
                                                (str/replace-first qp #"\]\[.*\]"
                                                                   (format "][%s]" subfield))))
                                         (select-keys query-params))
               indexes (some->> potential-qp-matches
                                keys
                                (map #(re-find #"\[\d+\]" %))
                                (map second)
                                set)
               child-matches (mapcat
                               (fn [idx]
                                 (concat (for [[k v] applied-children-tuples]
                                           [(format "%s[%s][%s]" base-field idx (csk/->snake_case_string k))
                                            v])))
                               indexes)]
           (create-remove-link-for-hierarchical-field
            base-url query-params field-name ancestors-map parent-indexes value has-siblings?
            applied-children-tuples (concat child-matches potential-qp-matches)))
         (create-apply-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples)))
     (let [potential-query-params (get-potential-matching-query-params query-params field-name)
           value-exists? (or (seq (get-keys-to-remove potential-query-params value))
                             (seq (get-keys-to-update potential-query-params value)))]
       (if value-exists?
         (create-remove-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples)
         (create-apply-link-for-hierarchical-field
          base-url query-params field-name ancestors-map parent-indexes value has-siblings?
          applied-children-tuples))))))

Refactor remove-duplicate-params

CMR-3207: Refactor remove-duplicate-params


(ns lambdaui.example.simple-pipeline
  (:use [compojure.core])
  (:require [lambdacd.steps.shell :as shell]
            [lambdacd.steps.manualtrigger :refer [wait-for-manual-trigger]]
            [lambdacd.steps.control-flow :refer [either with-workspace in-parallel run] :as step]
            [lambdacd.core :as lambdacd]
            [org.httpkit.server :as server]
            [lambdacd.ui.api]
            [lambdaui.core :as ui]
            [lambdacd.steps.manualtrigger :refer [wait-for-manual-trigger parameterized-trigger]]
            [lambdacd.runners :as pipeline-runners]
            [lambdacd.steps.support :as support])
  (:import (java.nio.file.attribute FileAttribute)
           (java.nio.file Files)))

(defonce lastStatus (atom nil))

(defn swapStatus [lastStatus]
  (case lastStatus
    :success :failure
    :failure :waiting
    :waiting :success
    :success))

(defn successfullStep [args ctx]
  {:status :success :out "Wohoo!"})

(defn a-lot-output [args context]
  (shell/bash context (:cwd args) "for i in {1..200}; do echo \"Outputline ${i}\"; done"))

(defn long-running-task-20s [args context]
  (shell/bash context (:cwd args) "for i in {1..200}; do echo \"Outputline ${i}\"; sleep 0.1s; done"))

(defn different-status [_ _]
  {:status (swap! lastStatus swapStatus)})

(defn output-parameters [args ctx]
  (let [p (support/new-printer)
        out #(support/print-to-output ctx p %)
        revision (get args :revision)

        ]
    (out (str "result from previous step \n" (clojure.pprint/write args :stream nil)))

    (if revision (out (str "Revision entered: " revision))
                 (out "You did not use the parameterized trigger."))
    {:status :success}
    ))

(defn wait-for-git-revision [_ ctx]
  (let [result
        (parameterized-trigger {:revision {:desc "Input git revision"}} ctx)]

    (update result :global #(assoc % :revision (:revision result)))))

(def pipeline-structure
  `((step/alias "press \u25B6 to start build"
                (either
                  wait-for-manual-trigger
                  wait-for-git-revision
                  ))
     output-parameters
     output-parameters
     a-lot-output
     (step/alias "i have substeps"
                 (run successfullStep
                      successfullStep
                      (step/alias "i have more substeps"
                                  (run a-lot-output
                                       different-status))
                      a-lot-output)
                 )
     (in-parallel
       (step/alias "double-long" (run long-running-task-20s long-running-task-20s))
       long-running-task-20s
       long-running-task-20s
       )
     long-running-task-20s
     ))

(defn try-parse [input default]
  (if input
    (try
      (Integer/parseInt input) (catch RuntimeException e (doall (println "cannot parse int " input) default)))
    (do
      (println "No argument given. Fallback to default port " default)
      default)))

(defonce server (atom nil))

(defn- create-temp-dir []
  (str (Files/createTempDirectory "lambdacd" (into-array FileAttribute []))))

(defn -main [& args]
  (let [home-dir (create-temp-dir)
        config {:home-dir  home-dir
                :name      "Example Pipeline"
                :ui-config {
                            :navbar               {:links [{:text "Configure Link to github" :url "https://github.com/sroidl/lambda-ui"}]}
                            :showStartBuildButton false}

                }
        port (try-parse (System/getenv "PORT") 8082)
        pipeline (lambdacd/assemble-pipeline pipeline-structure config)]

    (pipeline-runners/start-one-run-after-another pipeline)
    (reset! server
            (server/run-server (routes

                                 (ui/pipeline-routes pipeline))
                               {:open-browser? false
                                :port          port}))))

(defn stop []
  (when-let [shutdown @server] (shutdown) (reset! server nil)))

(defn start []
  (stop)
  (-main))

(ns lambdaui.example.simple-pipeline
  (:use [compojure.core])
  (:require [lambdacd.steps.shell :as shell]
            [lambdacd.steps.manualtrigger :refer [wait-for-manual-trigger]]
            [lambdacd.steps.control-flow :refer [either with-workspace in-parallel run] :as step]
            [lambdacd.core :as lambdacd]
            [org.httpkit.server :as server]
            [lambdacd.ui.api]
            [lambdaui.core :as ui]
            [lambdacd.steps.manualtrigger :refer [wait-for-manual-trigger parameterized-trigger]]
            [lambdacd.runners :as pipeline-runners]
            [lambdacd.stepsupport.output :as output])
  (:import (java.nio.file.attribute FileAttribute)
           (java.nio.file Files)))

(defonce lastStatus (atom nil))

(defn swapStatus [lastStatus]
  (case lastStatus
    :success :failure
    :failure :waiting
    :waiting :success
    :success))

(defn successfullStep [args ctx]
  {:status :success :out "Wohoo!"})

(defn a-lot-output [args context]
  (shell/bash context (:cwd args) "for i in {1..200}; do echo \"Outputline ${i}\"; done"))

(defn long-running-task-20s [args context]
  (shell/bash context (:cwd args) "for i in {1..200}; do echo \"Outputline ${i}\"; sleep 0.1s; done"))

(defn different-status [_ _]
  {:status (swap! lastStatus swapStatus)})

(defn output-parameters [args ctx]
  (let [p (output/new-printer)
        out #(output/print-to-output ctx p %)
        revision (get args :revision)

        ]
    (out (str "result from previous step \n" (clojure.pprint/write args :stream nil)))

    (if revision (out (str "Revision entered: " revision))
                 (out "You did not use the parameterized trigger."))
    {:status :success}
    ))

(defn wait-for-git-revision [_ ctx]
  (let [result
        (parameterized-trigger {:revision {:desc "Input git revision"}} ctx)]

    (update result :global #(assoc % :revision (:revision result)))))

(def pipeline-structure
  `((step/alias "press \u25B6 to start build"
                (either
                  wait-for-manual-trigger
                  wait-for-git-revision
                  ))
     output-parameters
     output-parameters
     a-lot-output
     (step/alias "i have substeps"
                 (run successfullStep
                      successfullStep
                      (step/alias "i have more substeps"
                                  (run a-lot-output
                                       different-status))
                      a-lot-output)
                 )
     (in-parallel
       (step/alias "double-long" (run long-running-task-20s long-running-task-20s))
       long-running-task-20s
       long-running-task-20s
       )
     long-running-task-20s
     ))

(defn try-parse [input default]
  (if input
    (try
      (Integer/parseInt input) (catch RuntimeException e (doall (println "cannot parse int " input) default)))
    (do
      (println "No argument given. Fallback to default port " default)
      default)))

(defonce server (atom nil))

(defn- create-temp-dir []
  (str (Files/createTempDirectory "lambdacd" (into-array FileAttribute []))))

(defn -main [& args]
  (let [home-dir (create-temp-dir)
        config {:home-dir  home-dir
                :name      "Example Pipeline"
                :ui-config {
                            :navbar               {:links [{:text "Configure Link to github" :url "https://github.com/sroidl/lambda-ui"}]}
                            :showStartBuildButton false}

                }
        port (try-parse (System/getenv "PORT") 8082)
        pipeline (lambdacd/assemble-pipeline pipeline-structure config)]

    (pipeline-runners/start-one-run-after-another pipeline)
    (reset! server
            (server/run-server (routes

                                 (ui/pipeline-routes pipeline))
                               {:open-browser? false
                                :port          port}))))

(defn stop []
  (when-let [shutdown @server] (shutdown) (reset! server nil)))

(defn start []
  (stop)
  (-main))

Replace use of deprecated lambdacd.step.support namespace with the current alternative


(ns comic-reader.sites-test
  (:require [clojure.test :refer :all]
            [comic-reader.sites :refer :all]
            [comic-reader.sites.test-util :as tu]
            [clojure.java.io :as io]
            [net.cgrand.enlive-html :as html]))

(deftest base-name-test
  (is (= (base-name "abc.123")
         "abc"))
  (is (= (base-name "thingy.clj")
         "thingy"))
  (is (= (base-name "thing.part.two.clj")
         "thing.part.two"))
  (is (= (base-name "dir/two/three/four.clj")
         "four")))

(deftest get-all-sites-test
  (is (some #{"test-site"} (get-all-sites))))

(deftest read-site-options-test
  (is (thrown?
       java.lang.IllegalArgumentException
       (read-site-options "non-existent")))
  (is (= (class (read-site-options "test-site"))
         clojure.lang.PersistentArrayMap)))

(deftest make-site-entry-test
  (is (= (make-site-entry "non-existent")
         ["non-existent" nil]))

  (let [[label opts] (make-site-entry "test-site")]
    (is (= label
           "test-site"))
    (is (= (class opts)
           comic_reader.sites.MangaSite))))

(defn expect-opts-are-map [site]
  (try
    (let [opts (read-site-options site)]
      (is (map? opts)
          (str "Contents of `sites/" site ".clj'"
               " must be a map literal")))
    (catch java.lang.RuntimeException re
      (is false
          (str "Contents of `sites/" site ".clj'"
               " cannot be empty")))))

(def ^:dynamic site-name)

(defn site-test-folder []
  (format "test/%s" site-name))

(defn resource-exists? [path]
  (some-> path
          io/resource
          io/as-file
          .exists))

(defn site-resource [resource]
  (let [resource-path (format "%s/%s"
                              (site-test-folder)
                              resource)]
    (if (resource-exists? resource-path)
      (io/resource resource-path)
      nil)))

(defn has-test-folder? []
  (some-> (site-test-folder)
          resource-exists?))

(defn error-must-have-test-data []
  (is false
      (str "There must be a site test data folder at "
           "`resources/test/" site-name "'")))

(defn image-page-html []
  (when-let [image-resource (site-resource "image.html")]
    (html/html-resource image-resource)))

(defn test-extract-image-tag []
  (if-let [html (image-page-html)]
    (do)
    (is false
        (str "There must be a sample image html page at "
             "`resources/test/" site-name "/image.html'"))))

(defn testdef-form [site-name]
  `(deftest ~(symbol (str site-name "-test"))
     (is
      (binding [~'site-name ~site-name]
        (expect-opts-are-map ~site-name)
        (if (has-test-folder?)
          (do
            (test-extract-image-tag)
            )
          (error-must-have-test-data))
        true))))

(defmacro defsite-tests []
  (try
    (let [site-names (->> sites
                          (map first)
                          (filter (complement #{"test-site"})))]
      `(do ~@(map testdef-form site-names)))
    (catch RuntimeException e
      `(do))))

(defsite-tests)

(ns comic-reader.sites-test
  (:require [clojure.test :refer :all]
            [comic-reader.sites :refer :all]
            [comic-reader.sites.test-util :as tu]
            [clojure.java.io :as io]
            [net.cgrand.enlive-html :as html]))

(deftest base-name-test
  (is (= (base-name "abc.123")
         "abc"))
  (is (= (base-name "thingy.clj")
         "thingy"))
  (is (= (base-name "thing.part.two.clj")
         "thing.part.two"))
  (is (= (base-name "dir/two/three/four.clj")
         "four")))

(deftest get-all-sites-test
  (is (some #{"test-site"} (get-all-sites))))

(deftest read-site-options-test
  (is (thrown?
       java.lang.IllegalArgumentException
       (read-site-options "non-existent")))
  (is (= (class (read-site-options "test-site"))
         clojure.lang.PersistentArrayMap)))

(deftest make-site-entry-test
  (is (= (make-site-entry "non-existent")
         ["non-existent" nil]))

  (let [[label opts] (make-site-entry "test-site")]
    (is (= label
           "test-site"))
    (is (= (class opts)
           comic_reader.sites.MangaSite))))

(defn expect-opts-are-map [site]
  (try
    (let [opts (read-site-options site)]
      (is (map? opts)
          (str "Contents of `sites/" site ".clj'"
               " must be a map literal")))
    (catch java.lang.RuntimeException re
      (is false
          (str "Contents of `sites/" site ".clj'"
               " cannot be empty")))))

(defn try-read-file [filename]
  (try
    (read-file filename)
    (catch java.lang.RuntimeException re
      (is false
          (str "Contents of `" filename "'"
               " cannot be empty")))))

(def ^:dynamic site-name)

(defn site-test-folder []
  (format "test/%s" site-name))

(defn resource-exists? [path]
  (some-> path
          io/resource
          io/as-file
          .exists))

(defn site-resource [resource]
  (let [resource-path (format "%s/%s"
                              (site-test-folder)
                              resource)]
    (if (resource-exists? resource-path)
      (io/resource resource-path)
      nil)))

(defn has-test-folder? []
  (some-> (site-test-folder)
          resource-exists?))

(defn error-must-have-test-data []
  (is false
      (str "There must be a site test data folder at "
           "`resources/test/" site-name "'")))

(defn image-page-html []
  (when-let [image-resource (site-resource "image.html")]
    (html/html-resource image-resource)))

(defn test-extract-image-tag []
  (if-let [html (image-page-html)]
    (do)
    (is false
        (str "There must be a sample image html page at "
             "`resources/test/" site-name "/image.html'"))))

(defn testdef-form [site-name]
  `(deftest ~(symbol (str site-name "-test"))
     (is
      (binding [~'site-name ~site-name]
        (expect-opts-are-map ~site-name)
        (if (has-test-folder?)
          (do
            (test-extract-image-tag)
            )
          (error-must-have-test-data))
        true))))

(defmacro defsite-tests []
  (try
    (let [site-names (->> sites
                          (map first)
                          (filter (complement #{"test-site"})))]
      `(do ~@(map testdef-form site-names)))
    (catch RuntimeException e
      `(do))))

(defsite-tests)

Add a generic try-read-file function to tests


(ns doctopus.test-utilities
  (:require [clojure.string :as str]
            [clojure.test :refer :all]
            [doctopus.storage :refer [remove-from-storage backend]]
            [doctopus.test-utilities :refer :all])
  (:import [org.joda.time DateTime]
           [org.joda.time.format DateTimeFormat]))

(def iso-formatter (DateTimeFormat/forPattern "yyyy-MM-dd"))

(defn make-today
  []
  (let [today (DateTime.)]
    (.print iso-formatter today)))

(defn clean-up-test-html
  [k]
  (remove-from-storage backend k))

(defmulti mock-data (fn [kind length] kind))

(defmethod mock-data :int
  [_ length]
  (rand-int length))

(defmethod mock-data :string
  [_ length]
  (let [upper-alphas "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        lower-alphas (str/lower-case upper-alphas)
        nums "0123456789"
        punct-and-spaces " -!,?:~_ \"'$%&"
        candidate-chars (apply str
                               upper-alphas
                               lower-alphas
                               nums
                               punct-and-spaces)]
    (loop [acc []]
      (if (= (count acc) length)
        (apply str acc)
        (recur (conj acc (rand-nth candidate-chars)))))))

(ns doctopus.test-utilities
  (:require [clojure.string :as str]
            [clojure.test :refer :all]
            [doctopus.doctopus.head :refer [->Head]]
            [doctopus.doctopus.tentacle :refer [map->Tentacle]]
            [doctopus.storage :refer [remove-from-storage backend]]
            [doctopus.test-utilities :refer :all])
  (:import [org.joda.time DateTime]
           [org.joda.time.format DateTimeFormat]))

(def iso-formatter (DateTimeFormat/forPattern "yyyy-MM-dd"))

(defn make-today
  []
  (let [today (DateTime.)]
    (.print iso-formatter today)))

(defn clean-up-test-html
  [k]
  (remove-from-storage backend k))

(defmulti mock-data (fn [kind length] kind))

(defmethod mock-data :int
  [_ length]
  (rand-int length))

(defmethod mock-data :string
  [_ length]
  (let [upper-alphas "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        lower-alphas (str/lower-case upper-alphas)
        nums "0123456789"
        punct-and-spaces " -!,?:~_ \"'$%&"
        candidate-chars (apply str
                               upper-alphas
                               lower-alphas
                               nums
                               punct-and-spaces)]
    (loop [acc []]
      (if (= (count acc) length)
        (apply str acc)
        (recur (conj acc (rand-nth candidate-chars)))))))

(defmethod mock-data :tentacle
  [_ _]
  (map->Tentacle {:name (mock-data :string 10)
                  :html-commands [(mock-data :string 10)]
                  :output-root (mock-data :string 15)
                  :source-location (mock-data :string 10)
                  :entry-point (mock-data :string 10)}))

(defmethod mock-data :head
  [_ _]
  (->Head (mock-data :string 18)))

Expand the test utilities to support mocking out heads and tentacles. This is.... on the clunky side at the moment (second arg unused); think of a better way to do this.


(ns scrape-summitpost-data.extract-result-links-test
  (:require [clojure.string :as string]
            [clojure.test :refer [deftest is]]
            [scrape-summitpost-data.extract-result-links :as test-ns]))

(defn- make-test-page
  [url]
  (let [template "

"]
    (string/replace template "{}" url)))

(deftest extract-result-links-test
  (let [page (make-test-page "/test-item-name/12345")]
    (is (= ["/test-item-name/12345"]
           (test-ns/extract-result-links page))
        "extracts link to item from search results table")))

(ns scrape-summitpost-data.extract-result-links-test
  (:require [clojure.string :as string]
            [clojure.test :refer [deftest is]]
            [scrape-summitpost-data.extract-result-links :as test-ns]))

(defn- make-test-page
  [urls]
  (let [header "

"
        row-template "

"
        footer "

"
        rows (mapv #(string/replace row-template "{}" %) urls)
        page (conj (cons header rows) footer)]
    (apply str page)))

(deftest extract-result-links-test
  (let [urls ["/test1"]]
    (is (= urls
           (test-ns/extract-result-links (make-test-page urls)))
        "extracts single link from search results table"))
  (let [urls ["/test1" "/test2" "/test3"]]
    (is (= urls
           (test-ns/extract-result-links (make-test-page urls)))
        "extracts multiple links from search results table")))

Improve make-test-page to allow multiple urls and add multiple url test for extract-result-links.


(ns
  ^{:doc "This is primarily a specification for SuperCollider synthesizer
          definition files.  Additionally there are functions for reading and
          writing to and from byte arrays, files, and URLs.  "
     :author "Jeff Rose"}
  overtone.sc.machinery.synthdef
  (:import [java.net URL])
  (:use [overtone.byte-spec]
        [overtone.util lib]
        [overtone.libs event deps]
        [overtone.sc server]
        [overtone.sc.machinery.server comms])
  (:require [overtone.util.log :as log]))

;; param-name is :
;;   pstring - the name of the parameter
;;   int16 - its index in the parameter array
(defspec param-spec
         :name  :string
         :index :int16)

;; input-spec is :
;;   int16 - index of unit generator or -1 for a constant
;;   if (unit generator index == -1) {
;;     int16 - index of constant
;;   } else {
;;     int16 - index of unit generator output
;;   }
;; end
(defspec input-spec
				 :src   :int16
				 :index :int16)

;; an output-spec is :
;;   int8 - calculation rate
;; end
(defspec output-spec
				 :rate :int8)

;; ugen-spec is :
;;   pstring - the name of the SC unit generator class
;;   int8 - calculation rate
;;   int16 - number of inputs (I)
;;   int16 - number of outputs (O)
;;   int16 - special index
;;   [input-spec] * I
;;   [output-spec] * O
;;
;;  * special index - custom argument used by some ugens
;;    - (e.g. UnaryOpUGen and BinaryOpUGen use it to indicate which operator to perform.)
;;    - If not used it should be set to zero.
(defspec ugen-spec
				 :name      :string
				 :rate      :int8
				 :n-inputs  :int16
				 :n-outputs :int16
         :special   :int16 0
				 :inputs    [input-spec]
         :outputs   [output-spec])

;; variants are a mechanism to store a number of presets for a synthdef
;;   pstring - name of the variant
;;   [float32] - an array of preset values, one for each synthdef parameter
(defspec variant-spec
         :name   :string
         :params [:float32])

;; synth-definition (sdef):
;;   pstring - the name of the synth definition
;;
;;   int16 - number of constants (K)
;;   [float32] * K - constant values
;;
;;   int16 - number of parameters (P)
;;   [float32] * P - initial parameter values
;;
;;   int16 - number of parameter names (N)
;;   [param-name] * N
;;
;;   int16 - number of unit generators (U)
;;   [ugen-spec] * U
;;
;;  * constants are static floating point inputs
;;  * parameters are named input floats that can be dynamically controlled
;;    - (/s.new, /n.set, /n.setn, /n.fill, /n.map)
(defspec synth-spec
         :name         :string
         :n-constants  :int16
         :constants    [:float32]
         :n-params     :int16
         :params       [:float32]
         :n-pnames     :int16
         :pnames       [param-spec]
         :n-ugens      :int16
         :ugens        [ugen-spec]
         :n-variants   :int16 0
         :variants     [variant-spec])

;; a synth-definition-file is :
;;   int32 - four byte file type id containing the ASCII characters: "SCgf"
;;   int32 - file version, currently zero.
;;   int16 - number of synth definitions in this file (D).
;;   [synth-definition] * D
;; end

(def SCGF-MAGIC "SCgf")
(def SCGF-VERSION 1)

(defspec synthdef-file-spec
         :id       :int32 SCGF-MAGIC
         :version  :int32 SCGF-VERSION
         :n-synths :int16 1
         :synths   [synth-spec])

(defn- synthdef-file [& sdefs]
  (with-meta {:n-synths (short (count sdefs))
              :synths sdefs}
             {:type ::synthdef-file}))

(defn- synthdef-file? [obj] (= ::synthdef-file (type obj)))

(defn- synthdef-file-bytes [sfile]
  (spec-write-bytes synthdef-file-spec sfile))

(defn synthdef? [obj] (= ::synthdef (type obj)))

(defn- supercollider-synthdef-path
  "Returns a constructed path to a named synthdef on the current platform"
  [synth-name]
  (case (get-os)
        :mac   (str "/Users/" (user-name) "/Library/Application Support/SuperCollider/synthdefs/" synth-name ".scsyndef")))

; TODO: byte array shouldn't really be the default here, but I don't
; know how to test for one correctly... (byte-array? data) please?
(defn synthdef-read
  "Reads synthdef data from either a file specified using a string path
  a URL, or a byte array."
  [data]
  (first (:synths
          (cond
           (keyword? data) (spec-read-url synthdef-file-spec (java.net.URL. (str "file:" (supercollider-synthdef-path (to-str data)))) )
           (string? data) (spec-read-url synthdef-file-spec (java.net.URL. (str "file:" data)))
           (instance? java.net.URL data) (spec-read-url synthdef-file-spec data)
           (byte-array? data) (spec-read-bytes synthdef-file-spec data)
           :default (throw (IllegalArgumentException. (str "synthdef-read expects either a string, a URL, or a byte-array argument.")))))))

(defn synthdef-write
  "Write a synth definition to a new file at the given path, which includes
  the name of the file itself.  (e.g. /home/rosejn/synths/bass.scsyndef)"
  [sdef path]
  (spec-write-file synthdef-file-spec (synthdef-file sdef) path))

(defn synthdef-bytes
  "Produces a serialized representation of the synth definition understood
  by SuperCollider, and returns it in a byte array."
  [sdef]
  (spec-write-bytes synthdef-file-spec
    (cond
      (synthdef? sdef) (synthdef-file sdef)
      (synthdef-file? sdef) sdef)))

(defn- ugen-print [u]
  (println
    "--"
    "\n    name: "      (:name u)
    "\n    rate: "      (:rate u)
    "\n    n-inputs: "  (:n-inputs u)
    "\n    n-outputs: " (:n-outputs u)
    "\n    special: "   (:special u)
    "\n    inputs: "    (:inputs u)
    "\n    outputs: "   (:outputs u)))

(declare synthdef-print)
(defn- synthdef-file-print [s]
  (println
    "id: "         (:id s)
    "\nversion: "  (:version s)
    "\nn-synths: " (:n-synths s)
    "\nsynths:")
  (doseq [synth (:synths s)]
    (synthdef-print synth)))

(defn synthdef-print [s]
  (println
    "  name: "          (:name s)
    "\n  n-constants: " (:n-constants s)
    "\n  constants: "   (:constants s)
    "\n  n-params: "    (:n-params s)
    "\n  params: "      (:params s)
    "\n  n-pnames: "    (:n-pnames s)
    "\n  pnames: "      (:pnames s)
    "\n  n-ugens: "     (:n-ugens s))
  (doseq [ugen (:ugens s)]
    (ugen-print ugen)))

(defn synth-controls
  "Returns the set of control parameter name/default-value pairs for a synth
  definition."
  [sdef]
  (let [names (map #(keyword (:name %1)) (:pnames sdef))
        vals (:params sdef)]
  (apply hash-map (interleave names vals))))

(defonce loaded-synthdefs* (ref {}))

;; ### Synth Definition
;;
;; Synths are created from Synth Definitions. Synth Definition files are
;; created by Overtone and then loaded into the synth server using the synth
;; and inst forms and their derivatives.
(defn load-synthdef
  "Load an Overtone synth definition onto the audio server. The synthdef is also
  stored so that it can be re-loaded if the server needs rebooted. If the server
  is currently not running, the synthdef loading is delayed until the server has
  succesfully connected."
  [sdef]
  (assert (synthdef? sdef))
  (dosync (alter loaded-synthdefs* assoc (:name sdef) sdef))

  (when (connected?)
    (with-server-sync
      #(snd "/d_recv" (synthdef-bytes sdef)))))

(defn- load-all-synthdefs []
  (doseq [[sname sdef] @loaded-synthdefs*]
    (snd "/d_recv" (synthdef-bytes sdef)))
  (satisfy-deps :synthdefs-loaded))

(on-deps :server-connected ::load-all-synthdefs load-all-synthdefs)

(defn load-synth-file
  "Load a synth definition file onto the audio server."
  [path]
  (snd "/d_recv" (synthdef-bytes (synthdef-read path))))

(ns
  ^{:doc "This is primarily a specification for SuperCollider synthesizer
          definition files.  Additionally there are functions for reading and
          writing to and from byte arrays, files, and URLs.  "
     :author "Jeff Rose"}
  overtone.sc.machinery.synthdef
  (:import [java.net URL])
  (:use [overtone.byte-spec]
        [overtone.util lib]
        [overtone.libs event deps]
        [overtone.sc server]
        [overtone.sc.machinery.server comms]
        [overtone.helpers.file :only [resolve-tilde-path]])
  (:require [overtone.util.log :as log]))

;; param-name is :
;;   pstring - the name of the parameter
;;   int16 - its index in the parameter array
(defspec param-spec
         :name  :string
         :index :int16)

;; input-spec is :
;;   int16 - index of unit generator or -1 for a constant
;;   if (unit generator index == -1) {
;;     int16 - index of constant
;;   } else {
;;     int16 - index of unit generator output
;;   }
;; end
(defspec input-spec
				 :src   :int16
				 :index :int16)

;; an output-spec is :
;;   int8 - calculation rate
;; end
(defspec output-spec
				 :rate :int8)

;; ugen-spec is :
;;   pstring - the name of the SC unit generator class
;;   int8 - calculation rate
;;   int16 - number of inputs (I)
;;   int16 - number of outputs (O)
;;   int16 - special index
;;   [input-spec] * I
;;   [output-spec] * O
;;
;;  * special index - custom argument used by some ugens
;;    - (e.g. UnaryOpUGen and BinaryOpUGen use it to indicate which operator to perform.)
;;    - If not used it should be set to zero.
(defspec ugen-spec
				 :name      :string
				 :rate      :int8
				 :n-inputs  :int16
				 :n-outputs :int16
         :special   :int16 0
				 :inputs    [input-spec]
         :outputs   [output-spec])

;; variants are a mechanism to store a number of presets for a synthdef
;;   pstring - name of the variant
;;   [float32] - an array of preset values, one for each synthdef parameter
(defspec variant-spec
         :name   :string
         :params [:float32])

;; synth-definition (sdef):
;;   pstring - the name of the synth definition
;;
;;   int16 - number of constants (K)
;;   [float32] * K - constant values
;;
;;   int16 - number of parameters (P)
;;   [float32] * P - initial parameter values
;;
;;   int16 - number of parameter names (N)
;;   [param-name] * N
;;
;;   int16 - number of unit generators (U)
;;   [ugen-spec] * U
;;
;;  * constants are static floating point inputs
;;  * parameters are named input floats that can be dynamically controlled
;;    - (/s.new, /n.set, /n.setn, /n.fill, /n.map)
(defspec synth-spec
         :name         :string
         :n-constants  :int16
         :constants    [:float32]
         :n-params     :int16
         :params       [:float32]
         :n-pnames     :int16
         :pnames       [param-spec]
         :n-ugens      :int16
         :ugens        [ugen-spec]
         :n-variants   :int16 0
         :variants     [variant-spec])

;; a synth-definition-file is :
;;   int32 - four byte file type id containing the ASCII characters: "SCgf"
;;   int32 - file version, currently zero.
;;   int16 - number of synth definitions in this file (D).
;;   [synth-definition] * D
;; end

(def SCGF-MAGIC "SCgf")
(def SCGF-VERSION 1)

(defspec synthdef-file-spec
         :id       :int32 SCGF-MAGIC
         :version  :int32 SCGF-VERSION
         :n-synths :int16 1
         :synths   [synth-spec])

(defn- synthdef-file [& sdefs]
  (with-meta {:n-synths (short (count sdefs))
              :synths sdefs}
             {:type ::synthdef-file}))

(defn- synthdef-file? [obj] (= ::synthdef-file (type obj)))

(defn- synthdef-file-bytes [sfile]
  (spec-write-bytes synthdef-file-spec sfile))

(defn synthdef? [obj] (= ::synthdef (type obj)))

(defn- supercollider-synthdef-path
  "Returns a constructed path to a named synthdef on the current platform"
  [synth-name]
  (case (get-os)
        :mac   (str "/Users/" (user-name) "/Library/Application Support/SuperCollider/synthdefs/" synth-name ".scsyndef")))

; TODO: byte array shouldn't really be the default here, but I don't
; know how to test for one correctly... (byte-array? data) please?
(defn synthdef-read
  "Reads synthdef data from either a file specified using a string path
  a URL, or a byte array."
  [data]
  (first (:synths
          (cond
           (keyword? data) (spec-read-url synthdef-file-spec (java.net.URL. (str "file:" (supercollider-synthdef-path (to-str data)))) )
           (string? data) (spec-read-url synthdef-file-spec (java.net.URL. (str "file:" (resolve-tilde-path data))))
           (instance? java.net.URL data) (spec-read-url synthdef-file-spec data)
           (byte-array? data) (spec-read-bytes synthdef-file-spec data)
           :default (throw (IllegalArgumentException. (str "synthdef-read expects either a string, a URL, or a byte-array argument.")))))))

(defn synthdef-write
  "Write a synth definition to a new file at the given path, which includes
  the name of the file itself.  (e.g. /home/rosejn/synths/bass.scsyndef)"
  [sdef path]
  (spec-write-file synthdef-file-spec (synthdef-file sdef) path))

(defn synthdef-bytes
  "Produces a serialized representation of the synth definition understood
  by SuperCollider, and returns it in a byte array."
  [sdef]
  (spec-write-bytes synthdef-file-spec
    (cond
      (synthdef? sdef) (synthdef-file sdef)
      (synthdef-file? sdef) sdef)))

(defn- ugen-print [u]
  (println
    "--"
    "\n    name: "      (:name u)
    "\n    rate: "      (:rate u)
    "\n    n-inputs: "  (:n-inputs u)
    "\n    n-outputs: " (:n-outputs u)
    "\n    special: "   (:special u)
    "\n    inputs: "    (:inputs u)
    "\n    outputs: "   (:outputs u)))

(declare synthdef-print)
(defn- synthdef-file-print [s]
  (println
    "id: "         (:id s)
    "\nversion: "  (:version s)
    "\nn-synths: " (:n-synths s)
    "\nsynths:")
  (doseq [synth (:synths s)]
    (synthdef-print synth)))

(defn synthdef-print [s]
  (println
    "  name: "          (:name s)
    "\n  n-constants: " (:n-constants s)
    "\n  constants: "   (:constants s)
    "\n  n-params: "    (:n-params s)
    "\n  params: "      (:params s)
    "\n  n-pnames: "    (:n-pnames s)
    "\n  pnames: "      (:pnames s)
    "\n  n-ugens: "     (:n-ugens s))
  (doseq [ugen (:ugens s)]
    (ugen-print ugen)))

(defn synth-controls
  "Returns the set of control parameter name/default-value pairs for a synth
  definition."
  [sdef]
  (let [names (map #(keyword (:name %1)) (:pnames sdef))
        vals (:params sdef)]
  (apply hash-map (interleave names vals))))

(defonce loaded-synthdefs* (ref {}))

;; ### Synth Definition
;;
;; Synths are created from Synth Definitions. Synth Definition files are
;; created by Overtone and then loaded into the synth server using the synth
;; and inst forms and their derivatives.
(defn load-synthdef
  "Load an Overtone synth definition onto the audio server. The synthdef is also
  stored so that it can be re-loaded if the server needs rebooted. If the server
  is currently not running, the synthdef loading is delayed until the server has
  succesfully connected."
  [sdef]
  (assert (synthdef? sdef))
  (dosync (alter loaded-synthdefs* assoc (:name sdef) sdef))

  (when (connected?)
    (with-server-sync
      #(snd "/d_recv" (synthdef-bytes sdef)))))

(defn- load-all-synthdefs []
  (doseq [[sname sdef] @loaded-synthdefs*]
    (snd "/d_recv" (synthdef-bytes sdef)))
  (satisfy-deps :synthdefs-loaded))

(on-deps :server-connected ::load-all-synthdefs load-all-synthdefs)

(defn load-synth-file
  "Load a synth definition file onto the audio server."
  [path]
  (let [path (resolve-tilde-path path)]
    (snd "/d_recv" (synthdef-bytes (synthdef-read path)))))

resolve tilde paths loading synthdefs from files