(ns paredit-widget.core
  (:require [paredit.core]
            [paredit.loc-utils]
            [paredit.parser]
            [paredit.text-utils]
            [seesaw.core :as s])
  (:import [java.awt.event InputMethodListener KeyEvent KeyListener]))

(defn exec-command!
  [cmd widget buffer]
  (let [old-parse-tree (paredit.parser/buffer-parse-tree @buffer nil)
        old-text (paredit.loc-utils/node-text old-parse-tree)
        new-text (s/value widget)
        diff (paredit.text-utils/text-diff old-text new-text)
        new-buffer (->> [@buffer (:offset diff) (:length diff) (:text diff)]
                        (apply paredit.parser/edit-buffer)
                        (reset! buffer))
        new-parse-tree (paredit.parser/buffer-parse-tree new-buffer nil)]
    (paredit.core/paredit cmd
                          {:parse-tree new-parse-tree :buffer new-buffer}
                          {:text new-text
                           :offset (min (.getSelectionStart widget)
                                        (.getCaretPosition widget))
                           :length (- (.getSelectionEnd widget)
                                      (.getSelectionStart widget))})))

(defn insert-result!
  [w pe]
  (dorun
    (map #(if (= 0 (:length %))
            (.insert w (:text %) (:offset %))
            (.replaceRange w (:text %) (:offset %) (+ (:length %) (:offset %))))
         (:modifs pe)))
  (.setCaretPosition w (:offset pe))
  (when (< 0 (:length pe))
    (.setSelectionStart w (:offset pe))
    (.setSelectionEnd w (+ (:offset pe) (:length pe)))))

(def ^:const os-x-charmap
  {"‚" ")" ;;close and round newline
   "Æ" "\"" ;; meta double quote
   "…" ";"  ;; paredit-commit-dwim
   "∂" "d"  ;;paredit-forward-kill-word
   "·" "(" ;; paredit-wrap-round
   "ß" "s" ;;paredit splice
   "®" "r" ;; raise expr
   "Í" "S" ;; split
   "Ô" "J" ;;join
   })

(def ^:const default-keymap
  {[nil "Tab"] :paredit-indent-line
   [nil "⇥"] :paredit-indent-line
   [nil "Enter"] :paredit-newline
   [nil "⏎"] :paredit-newline})

(def ^:const advanced-keymap
  {[nil "("] :paredit-open-round
   [nil ")"] :paredit-close-round
   [nil "["] :paredit-open-square
   [nil "]"] :paredit-close-square
   [nil "{"] :paredit-open-curly
   [nil "}"] :paredit-close-curly
   [nil "Backspace"] :paredit-backward-delete
   [nil "\""] :paredit-doublequote ;; \"
   ["C" "9"] :paredit-backward-slurp-sexp
   ["C" "0"] :paredit-forward-slurp-sexp
   ["C" "["] :paredit-backward-barf-sexp
   ["C" "]"] :paredit-forward-barf-sexp
   ["M" "("] :paredit-wrap-round
   ["M" "s"] :paredit-splice-sexp
   ["M" "r"] :paredit-raise-sexp
   ["M" "S"] :paredit-split-sexp
   ["M" "J"] :paredit-join-sexps
   ["M" "Left"] :paredit-expand-left
   ["M" "Right"] :paredit-expand-right})

(def ^:const advanced-alternative-keymap
  {[nil "⌫"] :paredit-backward-delete
   ["C" "Open Bracket"] :paredit-backward-barf-sexp
   ["C" "Close Bracket"] :paredit-forward-barf-sexp
   ["M" "←"] :paredit-expand-left
   ["M" "→"] :paredit-expand-right})

(def ^:const foreign-keymap
  {["M" "["] :paredit-open-square
   ["M" "]"] :paredit-close-square
   ["M" "{"] :paredit-open-curly
   ["M" "}"] :paredit-close-curly})

(def ^:const special-chars
  #{"(" ")" "[" "]" "{" "}" "\""}) ;; \"

(defn exec-paredit!
  [k w buffer enable-default? enable-advanced?]
  (when-let [cmd (or (and enable-default?
                          (default-keymap k))
                     (and @enable-advanced?
                          (or (advanced-keymap k)
                              (advanced-alternative-keymap k)
                              (foreign-keymap k))))]
    (insert-result! w (exec-command! cmd w buffer))
    cmd))

(defn convert-key-event
  [event]
  (let [key-code (.getKeyCode event)
        key-char (.getKeyChar event)]
    [(cond
       (and (.isAltDown event) (.isControlDown event)) nil
       (.isAltDown event) "M"
       (.isControlDown event) "C"
       :else nil)
     (if (or (Character/isLetterOrDigit key-char)
             (special-chars (str key-char)))
       (str key-char)
       (KeyEvent/getKeyText key-code))]))

(defn key-event-handler
  [w buffer enable-default? enable-advanced?]
  (reify KeyListener
    (keyReleased [this e] nil)
    (keyTyped [this e]
      (when (and @enable-advanced? (special-chars (str (.getKeyChar e))))
        (.consume e)))
    (keyPressed [this e]
      (when-not (.isConsumed e)
        (let [k (convert-key-event e)
              p (exec-paredit! k w buffer enable-default? enable-advanced?)]
          (when p (.consume e)))))))

(defn convert-input-method-event
  [event]
  ["M" (os-x-charmap (str (.first (.getText event))))])

(defn input-method-event-handler
  [w buffer enable-default? enable-advanced?]
  (reify InputMethodListener
    (inputMethodTextChanged [this e]
      (let [k (convert-input-method-event e)
            p (exec-paredit! k w buffer enable-default? enable-advanced?)]
        (when p (.consume e))))))

(defn init-paredit!
  [w enable-default?]
  (let [buffer (atom (paredit.parser/edit-buffer nil 0 -1 (s/value w)))
        enable-advanced? (atom true)]
    (doto w
      (.addKeyListener
        (key-event-handler w buffer enable-default? enable-advanced?))
      (.addInputMethodListener
        (input-method-event-handler w buffer enable-default? enable-advanced?)))
    (fn [enable?]
      (reset! enable-advanced? enable?))))

(ns paredit-widget.core
  (:require [paredit.core]
            [paredit.loc-utils]
            [paredit.parser]
            [paredit.text-utils]
            [seesaw.core :as s])
  (:import [java.awt.event InputMethodListener KeyEvent KeyListener]))

(defn exec-command!
  [cmd widget buffer]
  (let [old-parse-tree (paredit.parser/buffer-parse-tree @buffer nil)
        old-text (paredit.loc-utils/node-text old-parse-tree)
        new-text (s/value widget)
        diff (paredit.text-utils/text-diff old-text new-text)
        new-buffer (->> [@buffer (:offset diff) (:length diff) (:text diff)]
                        (apply paredit.parser/edit-buffer)
                        (reset! buffer))
        new-parse-tree (paredit.parser/buffer-parse-tree new-buffer nil)]
    (paredit.core/paredit cmd
                          {:parse-tree new-parse-tree :buffer new-buffer}
                          {:text new-text
                           :offset (min (.getSelectionStart widget)
                                        (.getCaretPosition widget))
                           :length (- (.getSelectionEnd widget)
                                      (.getSelectionStart widget))})))

(defn insert-result!
  [w pe]
  (dorun
    (map #(if (= 0 (:length %))
            (.insert w (:text %) (:offset %))
            (.replaceRange w (:text %) (:offset %) (+ (:length %) (:offset %))))
         (:modifs pe)))
  (.setCaretPosition w (:offset pe))
  (when (< 0 (:length pe))
    (.setSelectionStart w (:offset pe))
    (.setSelectionEnd w (+ (:offset pe) (:length pe)))))

(def ^:const os-x-charmap
  {"‚" ")" ;;close and round newline
   "Æ" "\"" ;; meta double quote
   "…" ";"  ;; paredit-commit-dwim
   "∂" "d"  ;;paredit-forward-kill-word
   "·" "(" ;; paredit-wrap-round
   "ß" "s" ;;paredit splice
   "®" "r" ;; raise expr
   "Í" "S" ;; split
   "Ô" "J" ;;join
   })

(def ^:const default-keymap
  {[nil "Tab"] :paredit-indent-line
   [nil "⇥"] :paredit-indent-line
   [nil "Enter"] :paredit-newline
   [nil "⏎"] :paredit-newline})

(def ^:const advanced-keymap
  {[nil "("] :paredit-open-round
   [nil ")"] :paredit-close-round
   [nil "["] :paredit-open-square
   [nil "]"] :paredit-close-square
   [nil "{"] :paredit-open-curly
   [nil "}"] :paredit-close-curly
   [nil "\""] :paredit-doublequote ;; \"
   ["C" "9"] :paredit-backward-slurp-sexp
   ["C" "0"] :paredit-forward-slurp-sexp
   ["C" "["] :paredit-backward-barf-sexp
   ["C" "]"] :paredit-forward-barf-sexp
   ["M" "("] :paredit-wrap-round
   ["M" "s"] :paredit-splice-sexp
   ["M" "r"] :paredit-raise-sexp
   ["M" "S"] :paredit-split-sexp
   ["M" "J"] :paredit-join-sexps
   ["M" "Left"] :paredit-expand-left
   ["M" "Right"] :paredit-expand-right})

(def ^:const advanced-alternative-keymap
  {["C" "Open Bracket"] :paredit-backward-barf-sexp
   ["C" "Close Bracket"] :paredit-forward-barf-sexp
   ["M" "←"] :paredit-expand-left
   ["M" "→"] :paredit-expand-right})

(def ^:const foreign-keymap
  {["M" "["] :paredit-open-square
   ["M" "]"] :paredit-close-square
   ["M" "{"] :paredit-open-curly
   ["M" "}"] :paredit-close-curly})

(def ^:const special-chars
  #{"(" ")" "[" "]" "{" "}" "\""}) ;; \"

(defn exec-paredit!
  [k w buffer enable-default? enable-advanced?]
  (when-let [cmd (or (and enable-default?
                          (default-keymap k))
                     (and @enable-advanced?
                          (or (advanced-keymap k)
                              (advanced-alternative-keymap k)
                              (foreign-keymap k))))]
    (insert-result! w (exec-command! cmd w buffer))
    cmd))

(defn convert-key-event
  [event]
  (let [key-code (.getKeyCode event)
        key-char (.getKeyChar event)]
    [(cond
       (and (.isAltDown event) (.isControlDown event)) nil
       (.isAltDown event) "M"
       (.isControlDown event) "C"
       :else nil)
     (if (or (Character/isLetterOrDigit key-char)
             (special-chars (str key-char)))
       (str key-char)
       (KeyEvent/getKeyText key-code))]))

(defn key-event-handler
  [w buffer enable-default? enable-advanced?]
  (reify KeyListener
    (keyReleased [this e] nil)
    (keyTyped [this e]
      (when (and @enable-advanced? (special-chars (str (.getKeyChar e))))
        (.consume e)))
    (keyPressed [this e]
      (when-not (.isConsumed e)
        (let [k (convert-key-event e)
              p (exec-paredit! k w buffer enable-default? enable-advanced?)]
          (when p (.consume e)))))))

(defn convert-input-method-event
  [event]
  ["M" (os-x-charmap (str (.first (.getText event))))])

(defn input-method-event-handler
  [w buffer enable-default? enable-advanced?]
  (reify InputMethodListener
    (inputMethodTextChanged [this e]
      (let [k (convert-input-method-event e)
            p (exec-paredit! k w buffer enable-default? enable-advanced?)]
        (when p (.consume e))))))

(defn init-paredit!
  [w enable-default?]
  (let [buffer (atom (paredit.parser/edit-buffer nil 0 -1 (s/value w)))
        enable-advanced? (atom true)]
    (doto w
      (.addKeyListener
        (key-event-handler w buffer enable-default? enable-advanced?))
      (.addInputMethodListener
        (input-method-event-handler w buffer enable-default? enable-advanced?)))
    (fn [enable?]
      (reset! enable-advanced? enable?))))

Remove backspace behavior

Remove backspace behavior


(ns digitalocean-expect.test
  (:require [digitalocean.droplet :refer :all]
            [environ.core :refer [env]])
  (:use expectations))

(def nodes (droplets (env :digitalocean-client-id) (env :digitalocean-api-key)))
(def creds {:client (env :digitalocean-client-id) :key (env :digitalocean-api-key)})

(defn nodes-by-status [status]
  (droplets-with-status creds status))

(def stopped-nodes (nodes-by-status "stopped"))
(def active-nodes (nodes-by-status "active"))

; these magic numbers are unfortunate details
; of the DigitalOcean API
(defn small? [size] (= 66 size))
(defn medium? [size] (= 62 size))
(defn large? [size] (= 60 size))
(defn london? [region] (= 7 region))
(defn sf? [region] (= 3 region))

; not more than 100 nodes
(expect (< (count nodes) 100))

; check number of stopped nodes
(expect 0 (count stopped-nodes))

; check node with specific name
(expect (droplet-by-name creds "test-digitalocean"))

; check backups are disabled for all nodes
(expect false? (from-each
  [node nodes] (:backups_active node)))

; check private networks are disabled for all nodes
(expect nil? (from-each
  [node nodes] (:private_ip_address node)))

; only use prescribed sizes
(expect 0
  (count
    (filter (complement large?)
      (filter (complement medium?)
        (filter (complement small?) (map :size_id nodes))))))

; only use prescribed regions
(expect 0
  (count
    (filter (complement london?)
      (filter (complement sf?) (map :region_id nodes)))))

; no more than 2 large nodes
(expect (< (count (filter large? (map :size_id nodes))) 2))

(ns digitalocean-expect.test
  (:require [digitalocean.droplet :refer :all]
            [environ.core :refer [env]])
  (:use expectations))

(def nodes (droplets (env :digitalocean-client-id) (env :digitalocean-api-key)))
(def creds {:client (env :digitalocean-client-id) :key (env :digitalocean-api-key)})

(defn nodes-by-status [status]
  (droplets-with-status creds status))

(def stopped-nodes (nodes-by-status "stopped"))
(def active-nodes (nodes-by-status "active"))

; these magic numbers are unfortunate details
; of the DigitalOcean API
(defn small? [size] (= 66 size))
(defn medium? [size] (= 62 size))
(defn large? [size] (= 60 size))
(defn london? [region] (= 7 region))
(defn sf? [region] (= 3 region))

; not more than 100 nodes
(expect (< (count nodes) 100))

; check number of stopped nodes
(expect 0 (count stopped-nodes))

; check node with specific name
(expect (droplet-by-name creds "test-digitalocean"))

; check backups are disabled for all nodes
(expect false? (from-each
  [node nodes] (:backups_active node)))

; check private networks are disabled for all nodes
(expect nil? (from-each
  [node nodes] (:private_ip_address node)))

; only use prescribed sizes
(expect 0
  (count
    (remove large?
      (remove medium?
        (remove small? (map :size_id nodes))))))

; only use prescribed regions
(expect 0
  (count
    (remove london?
      (remove sf? (map :region_id nodes)))))

; no more than 2 large nodes
(expect (< (count (filter large? (map :size_id nodes))) 2))

use remove rather than filter

use remove rather than filter


(ns braid.client.gateway.user-auth.views
  (:require
    [clojure.string :as string]
    [re-frame.core :refer [dispatch subscribe]]))

(defn auth-providers-view []
  [:span.auth-providers
   (for [provider [:github :google :facebook]]
     ^{:key provider}
     [:button
      {:class (name provider)
       :on-click (fn [e]
                   (.preventDefault e)
                   (dispatch [:gateway.user-auth/remote-oauth provider]))}
      (string/capitalize (name provider))])])

(defn returning-email-field-view []
  (let [field-id :gateway.user-auth/email
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.email
       {:class (name @status)}
       [:h2 "Email"]
       [:label
        [:div.field
         [:input {:type "email"
                  :placeholder "you@awesome.com"
                  :autocomplete true
                  :autocorrect false
                  :autocapitalize false
                  :spellcheck false
                  :auto-focus true
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))
                  }]]
        (when (= :invalid @status)
          [:div.error-message (first @errors)])
        [:p "Or, log in with: "
         [auth-providers-view]]]])))

(defn returning-password-field-view []
  (let [field-id :gateway.user-auth/password
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.password
       {:class (name @status)}
       [:h2 "Password"]
       [:label
        [:div.field
         [:input {:type "password"
                  :placeholder "•••••••••••"
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]]
       (when (= :invalid @status)
         [:div.error-message (first @errors)])
       [:p "Don't remember?"
        [:button
         {:on-click (fn [e]
                      (.preventDefault e)
                      (dispatch [:gateway.user-auth/set-mode :reset-password]))}
         "Reset your password"]]])))

(defn login-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email
                     :gateway.user-auth/password]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Log in to Braid"])))

(defn error-view []
  (let [error (subscribe [:gateway.user-auth/error])]
    (fn []
      (when @error
        (case @error
          :auth-fail
          [:div.error-message
           "The email or password is incorrect. Please try again."]
          :email-exists
          [:div.error-message
           "A user is already registered with that email."
           [:button
            {:on-click (fn [e]
                         (.preventDefault e)
                         (dispatch [:gateway.user-auth/set-mode :log-in]))}
            "Log In"]]
          :no-such-email
          [:div.error-message
           "An account with that email does not exist."]

          :password-reset-email-sent
          [:div.message
           "A password recovery email was sent. Please check your inbox."]

          ; catch-all
          [:div.error-message
           "An error occured. Please try again."])))))

(defn password-reset-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Reset Your Password"])))

(defn reset-password-view []
  [:form.reset-password
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email]
                  :dispatch-when-valid [:gateway.user-auth/remote-request-password-reset]}]))}
   [:h1 "Reset your password"]
   [:p
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Register"]

    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Log In"]]
   [returning-email-field-view]
   [password-reset-button-view]
   [error-view]])

(defn returning-user-view []
  [:form.returning-user
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email
                                    :gateway.user-auth/password]
                  :dispatch-when-valid [:gateway.user-auth/remote-log-in]}]))}
   [:h1 "Log in to Braid"]
   [:p "Don't have an account?"
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Register"]]
   [returning-email-field-view]
   [returning-password-field-view]
   [login-button-view]
   [error-view]])

(defn new-password-field-view []
  (let [field-id :gateway.user-auth/password
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.password
       {:class (name @status)}
       [:h2 "Password"]
       [:label
        [:div.field
         [:input {:type "password"
                  :placeholder "•••••••••••"
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]]
       (when (= :invalid @status)
         [:div.error-message (first @errors)])
       [:p "At least 8 characters. More is better!"]])))

(defn new-email-field-view []
  (let [field-id :gateway.user-auth/email
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.email
       {:class (name @status)}
       [:h2 "Email"]
       [:label
        [:div.field
         [:input {:type "email"
                  :placeholder "you@awesome.com"
                  :autocomplete true
                  :autocorrect false
                  :autocapitalize false
                  :spellcheck false
                  :auto-focus true
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]
        (when (= :invalid @status)
          [:div.error-message (first @errors)])
        [:p "Or, register with: "
         [auth-providers-view]]]])))

(defn register-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email
                     :gateway.user-auth/password]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Create a Braid Account"])))

(defn new-user-view []
  [:form.new-user
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email
                                    :gateway.user-auth/password]
                  :dispatch-when-valid [:gateway.user-auth/remote-register]}]))}
   [:h1 "Create a Braid Account"]
   [:p "Already have one?"
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :log-in]))}
     "Log In"]]
   [new-email-field-view]
   [new-password-field-view]
   [register-button-view]
   [error-view]])

(defn authed-user-view []
  (let [user (subscribe [:gateway.user-auth/user])]
    (fn []
      [:div.authed-user
       [:div.profile
        [:img.avatar {:src (@user :avatar)}]
        [:div.info
         [:div.nickname "@" (@user :nickname)]
         [:div.email (@user :email)]]]
       [:p "Not you?"
        [:button {:on-click (fn []
                              (dispatch [:gateway.user-auth/switch-account]))}
         "Sign in with a different account"]]])))

(defn checking-user-view []
  [:div.checking
   [:span "Authenticating..."]])

(defn oauth-in-progress-view []
  (let [provider (subscribe [:gateway.user-auth/oauth-provider])]
    [:div.authorizing
     [:span "Authenticating with " (string/capitalize (name @provider)) "..."]]))

(defn user-auth-view []
  (let [mode (subscribe [:gateway.user-auth/user-auth-mode])]
    (fn []
      [:div.section.user-auth
       (case @mode
         :checking [checking-user-view]
         :register [new-user-view]
         :reset-password [reset-password-view]
         :log-in [returning-user-view]
         :authed [authed-user-view]
         :oauth-in-progress [oauth-in-progress-view])])))

(ns braid.client.gateway.user-auth.views
  (:require
    [clojure.string :as string]
    [re-frame.core :refer [dispatch subscribe]]))

(defn auth-providers-view []
  [:span.auth-providers
   (for [provider [:github :google :facebook]]
     ^{:key provider}
     [:button
      {:class (name provider)
       :on-click (fn [e]
                   (.preventDefault e)
                   (dispatch [:gateway.user-auth/remote-oauth provider]))}
      (string/capitalize (name provider))])])

(defn returning-email-field-view []
  (let [field-id :gateway.user-auth/email
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.email
       {:class (name @status)}
       [:h2 "Email"]
       [:label
        [:div.field
         [:input {:type "email"
                  :placeholder "you@awesome.com"
                  :autocomplete true
                  :autocorrect false
                  :autocapitalize false
                  :spellcheck false
                  :auto-focus true
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))
                  }]]
        (when (= :invalid @status)
          [:div.error-message (first @errors)])
        ; TODO
        #_[:p "Or, log in with: "
           [auth-providers-view]]]])))

(defn returning-password-field-view []
  (let [field-id :gateway.user-auth/password
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.password
       {:class (name @status)}
       [:h2 "Password"]
       [:label
        [:div.field
         [:input {:type "password"
                  :placeholder "•••••••••••"
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]]
       (when (= :invalid @status)
         [:div.error-message (first @errors)])
       [:p "Don't remember?"
        [:button
         {:on-click (fn [e]
                      (.preventDefault e)
                      (dispatch [:gateway.user-auth/set-mode :reset-password]))}
         "Reset your password"]]])))

(defn login-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email
                     :gateway.user-auth/password]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Log in to Braid"])))

(defn error-view []
  (let [error (subscribe [:gateway.user-auth/error])]
    (fn []
      (when @error
        (case @error
          :auth-fail
          [:div.error-message
           "The email or password is incorrect. Please try again."]
          :email-exists
          [:div.error-message
           "A user is already registered with that email."
           [:button
            {:on-click (fn [e]
                         (.preventDefault e)
                         (dispatch [:gateway.user-auth/set-mode :log-in]))}
            "Log In"]]
          :no-such-email
          [:div.error-message
           "An account with that email does not exist."]

          :password-reset-email-sent
          [:div.message
           "A password recovery email was sent. Please check your inbox."]

          ; catch-all
          [:div.error-message
           "An error occured. Please try again."])))))

(defn password-reset-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Reset Your Password"])))

(defn reset-password-view []
  [:form.reset-password
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email]
                  :dispatch-when-valid [:gateway.user-auth/remote-request-password-reset]}]))}
   [:h1 "Reset your password"]
   [:p
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Register"]

    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Log In"]]
   [returning-email-field-view]
   [password-reset-button-view]
   [error-view]])

(defn returning-user-view []
  [:form.returning-user
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email
                                    :gateway.user-auth/password]
                  :dispatch-when-valid [:gateway.user-auth/remote-log-in]}]))}
   [:h1 "Log in to Braid"]
   [:p "Don't have an account?"
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :register]))}
     "Register"]]
   [returning-email-field-view]
   [returning-password-field-view]
   [login-button-view]
   [error-view]])

(defn new-password-field-view []
  (let [field-id :gateway.user-auth/password
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.password
       {:class (name @status)}
       [:h2 "Password"]
       [:label
        [:div.field
         [:input {:type "password"
                  :placeholder "•••••••••••"
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]]
       (when (= :invalid @status)
         [:div.error-message (first @errors)])
       [:p "At least 8 characters. More is better!"]])))

(defn new-email-field-view []
  (let [field-id :gateway.user-auth/email
        value (subscribe [:gateway/field-value field-id])
        status (subscribe [:gateway/field-status field-id])
        errors (subscribe [:gateway/field-errors field-id])]
    (fn []
      [:div.option.email
       {:class (name @status)}
       [:h2 "Email"]
       [:label
        [:div.field
         [:input {:type "email"
                  :placeholder "you@awesome.com"
                  :autocomplete true
                  :autocorrect false
                  :autocapitalize false
                  :spellcheck false
                  :auto-focus true
                  :value @value
                  :on-blur (fn [_]
                             (dispatch [:gateway/blur field-id]))
                  :on-change (fn [e]
                               (let [value (.. e -target -value)]
                                 (dispatch [:gateway/update-value field-id value])))}]]
        (when (= :invalid @status)
          [:div.error-message (first @errors)])
        ; TODO
        #_[:p "Or, register with: "
         [auth-providers-view]]]])))

(defn register-button-view []
  (let [fields-valid?
        (subscribe [:gateway/fields-valid?
                    [:gateway.user-auth/email
                     :gateway.user-auth/password]])]
    (fn []
      [:button.submit
       {:class (when-not @fields-valid? "disabled")}
       "Create a Braid Account"])))

(defn new-user-view []
  [:form.new-user
   {:on-submit
    (fn [e]
      (.preventDefault e)
      (dispatch [:gateway/submit-form
                 {:validate-fields [:gateway.user-auth/email
                                    :gateway.user-auth/password]
                  :dispatch-when-valid [:gateway.user-auth/remote-register]}]))}
   [:h1 "Create a Braid Account"]
   [:p "Already have one?"
    [:button
     {:on-click (fn [e]
                  (.preventDefault e)
                  (dispatch [:gateway.user-auth/set-mode :log-in]))}
     "Log In"]]
   [new-email-field-view]
   [new-password-field-view]
   [register-button-view]
   [error-view]])

(defn authed-user-view []
  (let [user (subscribe [:gateway.user-auth/user])]
    (fn []
      [:div.authed-user
       [:div.profile
        [:img.avatar {:src (@user :avatar)}]
        [:div.info
         [:div.nickname "@" (@user :nickname)]
         [:div.email (@user :email)]]]
       [:p "Not you?"
        [:button {:on-click (fn []
                              (dispatch [:gateway.user-auth/switch-account]))}
         "Sign in with a different account"]]])))

(defn checking-user-view []
  [:div.checking
   [:span "Authenticating..."]])

(defn oauth-in-progress-view []
  (let [provider (subscribe [:gateway.user-auth/oauth-provider])]
    [:div.authorizing
     [:span "Authenticating with " (string/capitalize (name @provider)) "..."]]))

(defn user-auth-view []
  (let [mode (subscribe [:gateway.user-auth/user-auth-mode])]
    (fn []
      [:div.section.user-auth
       (case @mode
         :checking [checking-user-view]
         :register [new-user-view]
         :reset-password [reset-password-view]
         :log-in [returning-user-view]
         :authed [authed-user-view]
         :oauth-in-progress [oauth-in-progress-view])])))

Remove oAuth providers from gateway form (for now)


(ns leiningen.new.game-javascript
  (:require [leiningen.new.templates :as t]))

(defn game-javascript
  [name package-name]
  (let [render (t/renderer "game-javascript")
        package-name (t/sanitize (t/multi-segment (or package-name name)))
        main-ns (t/sanitize-ns package-name)
        data {:name name
              :namespace main-ns
              :path (t/name-to-path main-ns)}]
    (t/->files data
               ["project.clj" (render "project.clj" data)]
               ["README.md" (render "README.md" data)]
               [".gitignore" (render "gitignore" data)]
               ["src/{{path}}.clj" (render "server.clj" data)]
               ["resources/public/index.html" "index.html"]
               ["resources/public/main.js" "main.js"]
               ["resources/public/phaser.min.js" "phaser.min.js"])))

(ns leiningen.new.game-javascript
  (:require [leiningen.new.templates :as t]))

(defn game-javascript
  [name package-name]
  (let [render (t/renderer "game-javascript")
        package-name (t/sanitize (t/multi-segment (or package-name name)))
        main-ns (t/sanitize-ns package-name)
        data {:name name
              :namespace main-ns
              :path (t/name-to-path main-ns)}]
    (t/->files data
               ["project.clj" (render "project.clj" data)]
               ["README.md" (render "README.md" data)]
               [".gitignore" (render "gitignore" data)]
               ["src/{{path}}.clj" (render "server.clj" data)]
               ["resources/public/index.html" (render "index.html")]
               ["resources/public/main.js" (render "main.js")]
               ["resources/public/phaser.min.js" (render "phaser.min.js")])))

Fix javascript game template

Fix javascript game template


(ns clojush.pushgp.selection.preselection
  (:use [clojush random globals]))

(defn one-individual-per-error-vector-for-lexicase
  "When :parent-selection is a lexicase method, returns only one random individual
  to represent each error vector."
  [pop {:keys [parent-selection]}]
  (if (some #{parent-selection}
            #{:lexicase :leaky-lexicase :epsilon-lexicase :elitegroup-lexicase
              :random-threshold-lexicase :random-toggle-lexicase
              :randomly-truncated-lexicase})
    (map lrand-nth (vals (group-by #(:errors %) pop)))
    pop))

(defn nonempties-for-autoconstruction
  "When :autoconstuctive is truthy, and at least one individual in pop has a non-empty
  genome, returns only those individuals with non-empty genomes."
  [pop {:keys [autoconstructive]}]
  (if autoconstructive
    (let [with-non-empty-genomes (filter #(not (empty? (:genome %))) pop)]
      (if (not (empty? with-non-empty-genomes))
        with-non-empty-genomes
        pop))
    pop))

(defn age-mediate
  "If age-mediated-parent-selection is falsy, returns pop. Otherwise,
  age-mediated-parent-selection should be a vector of [pmin pmax] with pmin and pmax both
  being between 0 and 1 (inclusive) with pmin + pmax <= 1.0. Then, with probability pmin,
  returns individuals in pop with the minimum age; with probability pmax, returns all of pop;
  with probability (- 1.0 pmin pmax), selects an age cutoff uniformly from those present
  in the population and returns individuals with the cutoff age or lower. If a third
  element of :invert is included in age-mediated-parent-selection then with probability
  pmin, returns individuals in pop with the maximum age; with probability pmax, returns
  all of pop; with probability (- 1.0 pmin pmax), selects an age cutoff uniformly from
  those present in the population and returns individuals with the cutoff age or higher."
  [pop {:keys [age-mediated-parent-selection]}]
  (if (not age-mediated-parent-selection)
    pop
    (let [rand-val (lrand)
          amps age-mediated-parent-selection ;; just abbreviate
          invert (> (count amps) 2)] ;; assume any more args are just :invert
      (if (<= rand-val (first amps))
        (let [extreme-age (reduce (if invert max min) (map :age pop))]
          (filter #(= (:age %) extreme-age) pop))
        (if (<= rand-val (+ (first amps) (second amps)))
          pop
          (let [age-limit (lrand-nth (distinct (map :age pop)))]
            (filter (fn [ind] ((if invert >= <=) (:age ind) age-limit))
                    pop)))))))

(defn screen
  "If random-screen is falsy, returns pop. Otherwise, random-screen should be a map with
  values for :criterion and :probability. Then, with probability (- 1 :probability), again
  returns pop. Otherwise, a value is chosen randomly from the :grain-size values of
  the individuals in pop, and returns the individuals with that :grain-size or smaller."
  [pop {:keys [random-screen]}]
  (if (not random-screen)
    pop
    (if (> (lrand) (:probability random-screen))
      pop
      (let [grain-size-limit (lrand-nth (distinct (map :grain-size pop)))]
        (filter (fn [ind] ((if (:reversible random-screen)
                             (lrand-nth [<= >=])
                             <=)
                           (:grain-size ind)
                           grain-size-limit))
                pop)))))

(defn knock-off-chip-off-the-old-block
  "If (:knock-off-chip-off-the-old-block argmap) is true, then if any individual in
  pop has an error vector that is different from its mother's, then return pop without
  any individuals with error vectors identical to their mother's. Otherwise return pop
  unchanged. If the value is a vector of the form [diffs outof] then instead of the
  requirement being that the error vector must be diffrent from its mother's, it is
  that there must be at least diffs many different error vectors in the most recent
  outof many. If diffs is :random, then it is chosen randomly from the range from 1
  to outof. If outof is also :random, then the value should actually be a vector
  of the form [:random :random limit], and outof will be chosen from the range from
  1 to limit. If the value is of the form [:random :random limit minfrac] then diffs
  will be chosen randomly from the range of (int (* minfrac outof)) to outof.
  If the value is of the form [:random :random limit minfrac maxfrac] then diffs
  will be chosen randomly from the range of (int (* minfrac outof)) to
  (int (* maxfrac outof)). If the first item in (:knock-off-chip-off-the-old-block argmap)
  is :subset, then the remainder are interpreted as above, but only a random subset
  of errors is considered in the filtering. If it is :single, then only
  a random single error. If the first item in is :min2, then the remainder are
  interpreted as above, but the minimum for random values is 2 rather than 1."
  [pop argmap]
  (let [knock-spec (:knock-off-chip-off-the-old-block argmap)]
    (if (not knock-spec)
      pop
      (if (not (:print-history argmap))
        (throw
         (Exception.
          ":print-history must be true for :knock-off-chip-off-the-old-block"))
        (let [knock-spec (if (= true knock-spec) [2 2] knock-spec)
              min2? (= :min2 (first knock-spec))
              knock-spec (if min2? (rest knock-spec) knock-spec)
              subset? (= :subset (first knock-spec))
              knock-spec (if subset? (rest knock-spec) knock-spec)
              single? (= :single (first knock-spec))
              knock-spec (if single? (rest knock-spec) knock-spec)
              filtered-history
              (if (or subset? single?)
                (let [all (shuffle (range (count (first (:history (first pop))))))
                      keepers (cons (first all)
                                    (if single? [] (take (rand (count all)) all)))]
                  (fn [ind]
                    (map (fn [errs]
                           (for [i keepers] (nth errs i)))
                         (:history ind))))
                :history)
              diffs (first knock-spec)
              outof (second knock-spec)
              limit (if (= outof :random) (nth knock-spec 2) nil)
              outof (if (= outof :random)
                      (if min2?
                        (inc (inc (lrand-int (dec limit))))
                        (inc (lrand-int limit)))
                      outof)
              diffs (if (= diffs :random)
                      (inc (if (> (count knock-spec) 3)
                             (let [mindiff (int (* (nth knock-spec 3) outof))
                                   maxdiff (if (> (count knock-spec) 4)
                                             (int (* (nth knock-spec 4) outof))
                                             outof)]
                               (+ mindiff (lrand-int (max 1 (- maxdiff mindiff)))))
                             (if min2?
                               (inc (lrand-int (dec outof)))
                               (lrand-int outof))))
                      diffs)
              changed (vec (filter (fn [ind]
                                     (or (< (count (:history ind)) diffs)
                                         (let [hist (filtered-history ind)
                                               case-hists (apply map list hist)]
                                           (some (fn [h]
                                                   (>= (count (distinct (take outof h)))
                                                       diffs))
                                                 case-hists))))
                                   pop))]
          (if (empty? changed)
            (do (println "Universal violation of knock-off-chip-off-the-old-block constraint.")
                pop)
            changed))))))

(defn preselect
  "Returns the population pop reduced as appropriate considering the settings for
  age-mediation, screening, selection method, and autoconstruction."
  [pop argmap]
  (-> pop
      (nonempties-for-autoconstruction argmap)
      (age-mediate argmap)
      (screen argmap)
      (knock-off-chip-off-the-old-block argmap)
      ((fn [subpop argmap]
         (when (:print-preselection-fraction argmap)
           (swap! preselection-counts #(conj % (count subpop))))
         subpop)
       argmap)
      (one-individual-per-error-vector-for-lexicase argmap)))

(ns clojush.pushgp.selection.preselection
  (:use [clojush random globals]))

(defn one-individual-per-error-vector-for-lexicase
  "When :parent-selection is a lexicase method, returns only one random individual
  to represent each error vector."
  [pop {:keys [parent-selection]}]
  (if (some #{parent-selection}
            #{:lexicase :leaky-lexicase :epsilon-lexicase :elitegroup-lexicase
              :random-threshold-lexicase :random-toggle-lexicase
              :randomly-truncated-lexicase})
    (map lrand-nth (vals (group-by #(:errors %) pop)))
    pop))

(defn nonempties-for-autoconstruction
  "When :autoconstuctive is truthy, and at least one individual in pop has a non-empty
  genome, returns only those individuals with non-empty genomes."
  [pop {:keys [autoconstructive]}]
  (if autoconstructive
    (let [with-non-empty-genomes (filter #(not (empty? (:genome %))) pop)]
      (if (not (empty? with-non-empty-genomes))
        with-non-empty-genomes
        pop))
    pop))

(defn age-mediate
  "If age-mediated-parent-selection is falsy, returns pop. Otherwise,
  age-mediated-parent-selection should be a vector of [pmin pmax] with pmin and pmax both
  being between 0 and 1 (inclusive) with pmin + pmax <= 1.0. Then, with probability pmin,
  returns individuals in pop with the minimum age; with probability pmax, returns all of pop;
  with probability (- 1.0 pmin pmax), selects an age cutoff uniformly from those present
  in the population and returns individuals with the cutoff age or lower. If a third
  element of :invert is included in age-mediated-parent-selection then with probability
  pmin, returns individuals in pop with the maximum age; with probability pmax, returns
  all of pop; with probability (- 1.0 pmin pmax), selects an age cutoff uniformly from
  those present in the population and returns individuals with the cutoff age or higher."
  [pop {:keys [age-mediated-parent-selection]}]
  (if (not age-mediated-parent-selection)
    pop
    (let [rand-val (lrand)
          amps age-mediated-parent-selection ;; just abbreviate
          invert (> (count amps) 2)] ;; assume any more args are just :invert
      (if (<= rand-val (first amps))
        (let [extreme-age (reduce (if invert max min) (map :age pop))]
          (filter #(= (:age %) extreme-age) pop))
        (if (<= rand-val (+ (first amps) (second amps)))
          pop
          (let [age-limit (lrand-nth (distinct (map :age pop)))]
            (filter (fn [ind] ((if invert >= <=) (:age ind) age-limit))
                    pop)))))))

(defn screen
  "If random-screen is falsy, returns pop. Otherwise, random-screen should be a map with
  values for :criterion and :probability. Then, with probability (- 1 :probability), again
  returns pop. Otherwise, a value is chosen randomly from the :grain-size values of
  the individuals in pop, and returns the individuals with that :grain-size or smaller."
  [pop {:keys [random-screen]}]
  (if (not random-screen)
    pop
    (if (> (lrand) (:probability random-screen))
      pop
      (let [grain-size-limit (lrand-nth (distinct (map :grain-size pop)))]
        (filter (fn [ind] ((if (:reversible random-screen)
                             (lrand-nth [<= >=])
                             <=)
                           (:grain-size ind)
                           grain-size-limit))
                pop)))))

(defn knock-off-chip-off-the-old-block
  "If (:knock-off-chip-off-the-old-block argmap) is true, then if any individual in
  pop has an error vector that is different from its mother's, then return pop without
  any individuals with error vectors identical to their mother's. Otherwise return pop
  unchanged. If the value is a vector of the form [diffs outof] then instead of the
  requirement being that the error vector must be diffrent from its mother's, it is
  that there must be at least diffs many different error vectors in the most recent
  outof many. If diffs is :random, then it is chosen randomly from the range from 1
  to outof. If outof is also :random, then the value should actually be a vector
  of the form [:random :random limit], and outof will be chosen from the range from
  1 to limit. If the value is of the form [:random :random limit minfrac] then diffs
  will be chosen randomly from the range of (int (* minfrac outof)) to outof.
  If the value is of the form [:random :random limit minfrac maxfrac] then diffs
  will be chosen randomly from the range of (int (* minfrac outof)) to
  (int (* maxfrac outof)). If the first item in (:knock-off-chip-off-the-old-block argmap)
  is :subset, then the remainder are interpreted as above, but only a random subset
  of errors is considered in the filtering. If it is :single, then only
  a random single error. If the first item in is :min2, then the remainder are
  interpreted as above, but the minimum for random values is 2 rather than 1."
  [pop argmap]
  (let [knock-spec (:knock-off-chip-off-the-old-block argmap)]
    (if (not knock-spec)
      pop
      (if (not (:print-history argmap))
        (throw
         (Exception.
          ":print-history must be true for :knock-off-chip-off-the-old-block"))
        (let [knock-spec (if (= true knock-spec) [2 2] knock-spec)
              min2? (= :min2 (first knock-spec))
              knock-spec (if min2? (rest knock-spec) knock-spec)
              subset? (= :subset (first knock-spec))
              knock-spec (if subset? (rest knock-spec) knock-spec)
              single? (= :single (first knock-spec))
              knock-spec (if single? (rest knock-spec) knock-spec)
              filtered-history
              (if (or subset? single?)
                (let [all (shuffle (range (count (first (:history (first pop))))))
                      keepers (cons (first all)
                                    (if single? [] (take (rand (count all)) (rest all))))]
                  (fn [ind]
                    (mapv (fn [errs]
                           (vec (for [i keepers] (nth errs i)))
                         (:history ind)))))
                :history)
              diffs (first knock-spec)
              outof (second knock-spec)
              limit (if (= outof :random) (nth knock-spec 2) nil)
              outof (if (= outof :random)
                      (if min2?
                        (inc (inc (lrand-int (dec limit))))
                        (inc (lrand-int limit)))
                      outof)
              diffs (if (= diffs :random)
                      (inc (if (> (count knock-spec) 3)
                             (let [mindiff (int (* (nth knock-spec 3) outof))
                                   maxdiff (if (> (count knock-spec) 4)
                                             (int (* (nth knock-spec 4) outof))
                                             outof)]
                               (+ mindiff (lrand-int (max 1 (- maxdiff mindiff)))))
                             (if min2?
                               (inc (lrand-int (dec outof)))
                               (lrand-int outof))))
                      diffs)
              changed (vec (filter (fn [ind]
                                     (or (< (count (:history ind)) diffs)
                                         (let [hist (filtered-history ind)
                                               case-hists (apply map list hist)]
                                           (some (fn [h]
                                                   (>= (count (distinct (take outof h)))
                                                       diffs))
                                                 case-hists))))
                                   pop))]
          (if (empty? changed)
            (do (println "Universal violation of knock-off-chip-off-the-old-block constraint.")
                pop)
            changed))))))

(defn preselect
  "Returns the population pop reduced as appropriate considering the settings for
  age-mediation, screening, selection method, and autoconstruction."
  [pop argmap]
  (-> pop
      (nonempties-for-autoconstruction argmap)
      (age-mediate argmap)
      (screen argmap)
      (knock-off-chip-off-the-old-block argmap)
      ((fn [subpop argmap]
         (when (:print-preselection-fraction argmap)
           (swap! preselection-counts #(conj % (count subpop))))
         subpop)
       argmap)
      (one-individual-per-error-vector-for-lexicase argmap)))

Fix off-by-one error and convert to vectors in knock-off-chip-off-the-old-block


(ns com.wsscode.pathom.graphql
  (:require
    #?(:clj [clojure.data.json :as json])
            [clojure.string :as str]
            [clojure.spec.alpha :as s]

            [om.next :as om]))

(defn pad-depth [depth]
  (str/join (repeat depth "  ")))

(defn has-call? [children]
  (->> children
       (filter (fn [{:keys [type]}] (= :call type)))
       first boolean))

(defn find-id [m]
  (->> m
       (filter (fn [[_ v]] (om/tempid? v)))
       first))

(defn stringify [x]
  #?(:clj  (json/write-str x)
     :cljs (js/JSON.stringify (clj->js x))))

(defn params->graphql
  ([x js-name] (params->graphql x js-name true))
  ([x js-name root?]
   (cond
     (map? x)
     (let [params (->> (into [] (comp
                                  (remove (fn [[_ v]] (om/tempid? v)))
                                  (map (fn [[k v]] (str (js-name k) ": " (params->graphql v js-name false))))) x)
                       (str/join ", "))]
       (if root?
         (str "(" params ")")
         (str "{" params "}")))

     (symbol? x)
     (name x)

     :else
     (stringify x))))

(defn ident->alias
  "Convert ident like [:Contact/by-id 123] to an usable GraphQL alias (eg: _COLON_Contact_SLASH_by_id_123)."
  [[base value]]
  (let [value (if (vector? value) (str/join "_" value) value)]
    (-> (str base "_" value) (str/replace #"[^a-zA-Z0-9_]" "_"))))

(defn ident-transform [[key value]]
  (let [fields (if-let [field-part (name key)]
                 (str/split field-part #"-and-") ["id"])
        value (if (vector? value) value [value])]
    (if-not (= (count fields) (count value))
      (throw (ex-info "The number of fields on value needs to match the entries" {:key key :value value})))
    {::selector (-> (namespace key) (str/split #"\.") last)
     ::params   (zipmap fields value)}))

(defn node->graphql [{:keys  [type children key dispatch-key params union-key]
                      ::keys [js-name depth ident-transform]
                      :or    {depth 0}}]
  (letfn [(continue
            ([x] (continue x inc))
            ([x depth-iterate]
             (node->graphql (assoc x ::depth (depth-iterate depth) ::js-name js-name
                                     ::ident-transform ident-transform))))]
    (case type
      :root
      (str (if (has-call? children) "mutation " "query ")
           "{\n" (str/join (map continue children)) "}\n")

      :join
      (let [header (if (vector? key)
                     (assoc (ident-transform key)
                       ::index (ident->alias key))
                     {::selector dispatch-key
                      ::params   nil})
            params (merge (::params header) params)]
        (str (pad-depth depth)
             (if (::index header) (str (::index header) ": "))
             (js-name (::selector header)) (some-> params (params->graphql js-name)) " {\n"
             (str/join (map continue children))
             (pad-depth depth) "}\n"))

      :call
      (let [{::keys [mutate-join]} params
            children (or (some-> mutate-join om/query->ast :children)
                         children)]
        (str (pad-depth depth) (js-name dispatch-key)
             (params->graphql (dissoc params ::mutate-join) js-name)
             " {\n"
             (if (seq children)
               (str/join (map continue children))
               (if-let [[k _] (find-id params)]
                 (str (pad-depth (inc depth))
                      (js-name k) "\n")))
             (pad-depth depth) "}\n"))

      :union
      (str (pad-depth depth) "__typename\n"
           (str/join (map #(continue % identity) children)))

      :union-entry
      (str (pad-depth depth) "... on " (js-name union-key) " {\n"
           (str/join (map continue children))
           (pad-depth depth) "}\n")

      :prop
      (str (pad-depth depth)
           (js-name dispatch-key)
           (if params (params->graphql params js-name))
           "\n"))))

(s/fdef node->graphql
  :args (s/cat :input (s/keys :req [::js-name]
                              :opt [::ident-transform])))

(defn query->graphql
  ([query] (query->graphql query {}))
  ([query options]
   (node->graphql (merge
                    (om/query->ast query)
                    {::js-name         name
                     ::ident-transform ident-transform}
                    options))))

(comment
  (str/join (repeat 1 "  "))
  (println (query->graphql '[({:all [:id :name]}
                               {:last "csaa"})] {}))

  (params->graphql {:a 1 :b {:c 3}} name)
  (om/query->ast '[(call-something {:a 1 :b {:c 3}})])
  (ident-transform [:Counter/by-id 123])
  (println (query->graphql [{[:Counter/by-id 123] [:a :b]}])))

(ns com.wsscode.pathom.graphql
  (:require
    #?(:clj [clojure.data.json :as json])
            [clojure.string :as str]
            [clojure.spec.alpha :as s]

            [om.next :as om]))

(defn pad-depth [depth]
  (str/join (repeat depth "  ")))

(defn has-call? [children]
  (->> children
       (filter (fn [{:keys [type]}] (= :call type)))
       first boolean))

(defn find-id [m]
  (->> m
       (filter (fn [[_ v]] (om/tempid? v)))
       first))

(defn stringify [x]
  #?(:clj  (json/write-str (cond-> x
                             (uuid? x) str))
     :cljs (js/JSON.stringify (clj->js x))))

(defn params->graphql
  ([x js-name] (params->graphql x js-name true))
  ([x js-name root?]
   (cond
     (map? x)
     (let [params (->> (into [] (comp
                                  (remove (fn [[_ v]] (om/tempid? v)))
                                  (map (fn [[k v]] (str (js-name k) ": " (params->graphql v js-name false))))) x)
                       (str/join ", "))]
       (if root?
         (str "(" params ")")
         (str "{" params "}")))

     (symbol? x)
     (name x)

     :else
     (stringify x))))

(defn ident->alias
  "Convert ident like [:Contact/by-id 123] to an usable GraphQL alias (eg: _COLON_Contact_SLASH_by_id_123)."
  [[base value]]
  (let [value (if (vector? value) (str/join "_" value) value)]
    (-> (str base "_" value) (str/replace #"[^a-zA-Z0-9_]" "_"))))

(defn ident-transform [[key value]]
  (let [fields (if-let [field-part (name key)]
                 (str/split field-part #"-and-") ["id"])
        value (if (vector? value) value [value])]
    (if-not (= (count fields) (count value))
      (throw (ex-info "The number of fields on value needs to match the entries" {:key key :value value})))
    {::selector (-> (namespace key) (str/split #"\.") last)
     ::params   (zipmap fields value)}))

(defn node->graphql [{:keys  [type children key dispatch-key params union-key]
                      ::keys [js-name depth ident-transform]
                      :or    {depth 0}}]
  (letfn [(continue
            ([x] (continue x inc))
            ([x depth-iterate]
             (node->graphql (assoc x ::depth (depth-iterate depth) ::js-name js-name
                                     ::ident-transform ident-transform))))]
    (case type
      :root
      (str (if (has-call? children) "mutation " "query ")
           "{\n" (str/join (map continue children)) "}\n")

      :join
      (let [header (if (vector? key)
                     (assoc (ident-transform key)
                       ::index (ident->alias key))
                     {::selector dispatch-key
                      ::params   nil})
            params (merge (::params header) params)]
        (str (pad-depth depth)
             (if (::index header) (str (::index header) ": "))
             (js-name (::selector header)) (some-> params (params->graphql js-name)) " {\n"
             (str/join (map continue children))
             (pad-depth depth) "}\n"))

      :call
      (let [{::keys [mutate-join]} params
            children (or (some-> mutate-join om/query->ast :children)
                         children)]
        (str (pad-depth depth) (js-name dispatch-key)
             (params->graphql (dissoc params ::mutate-join) js-name)
             " {\n"
             (if (seq children)
               (str/join (map continue children))
               (if-let [[k _] (find-id params)]
                 (str (pad-depth (inc depth))
                      (js-name k) "\n")))
             (pad-depth depth) "}\n"))

      :union
      (str (pad-depth depth) "__typename\n"
           (str/join (map #(continue % identity) children)))

      :union-entry
      (str (pad-depth depth) "... on " (js-name union-key) " {\n"
           (str/join (map continue children))
           (pad-depth depth) "}\n")

      :prop
      (str (pad-depth depth)
           (js-name dispatch-key)
           (if params (params->graphql params js-name))
           "\n"))))

(s/fdef node->graphql
  :args (s/cat :input (s/keys :req [::js-name]
                              :opt [::ident-transform])))

(defn query->graphql
  ([query] (query->graphql query {}))
  ([query options]
   (node->graphql (merge
                    (om/query->ast query)
                    {::js-name         name
                     ::ident-transform ident-transform}
                    options))))

(comment
  (str/join (repeat 1 "  "))
  (println (query->graphql '[({:all [:id :name]}
                               {:last "csaa"})] {}))

  (params->graphql {:a 1 :b {:c 3}} name)
  (om/query->ast '[(call-something {:a 1 :b {:c 3}})])
  (ident-transform [:Counter/by-id 123])
  (println (query->graphql [{[:Counter/by-id 123] [:a :b]}])))

Support uuid on js stringify

Support uuid on js stringify


(ns catacumba.core-tests
  (:require [clojure.core.async :refer [put! take! chan <! >! go close! go-loop onto-chan timeout] :as a]
            [clojure.test :refer :all]
            [clojure.java.io :as io]
            [clojure.pprint :refer [pprint]]
            [clojure.core.async :as async]
            [clj-http.client :as client]
            [promissum.core :as p]
            [catacumba.stream :as stream]
            [cats.core :as m]
            [cuerdas.core :as str]
            [manifold.stream :as ms]
            [manifold.deferred :as md]
            [catacumba.core :as ct]
            [catacumba.http :as http]
            [catacumba.testing :refer [with-server]]
            [catacumba.handlers.interceptor])
  (:import ratpack.exec.Execution
           ratpack.func.Action
           ratpack.func.Block
           ratpack.exec.ExecInterceptor
           ratpack.exec.ExecInterceptor$ExecType
           java.io.ByteArrayInputStream))

(def base-url "http://localhost:5050")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftest public-address
  (let [p (promise)
        handler (fn [context]
                  (deliver p (ct/public-address context))
                  "hello world")]
    (with-server {:handler handler}
      (let [response (client/get base-url)
            uri (deref p 1000 nil)]
        (is (= (str uri) "http://localhost:5050"))))))

(deftest cookies
  (testing "Setting new cookie."
    (letfn [(handler [context]
              (ct/set-cookies! context {:foo {:value "bar" :secure true :http-only true}})
              "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (contains? response :cookies))
          (is (= (get-in response [:cookies "foo" :path]) "/"))
          (is (= (get-in response [:cookies "foo" :value]) "bar"))
          (is (= (get-in response [:cookies "foo" :secure]) true)))))))

(deftest request-response
  (testing "Using send! with context"
    (let [handler (fn [ctx] (ct/send! ctx "hello world"))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using string as return value."
    (let [handler (fn [ctx] "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using response object as return value with string as body."
    (let [handler (fn [ctx]
                    (http/ok "hello world" {:x-header "foobar"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (get-in response [:headers :x-header]) "foobar"))
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using channel as response."
    (let [handler (fn [ctx]
                    (go
                      (<! (timeout 100))
                      (http/ok "hello world")))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using channel as body."
    (let [handler (fn [ctx]
                    (let [ch (chan)]
                      (go
                        (<! (timeout 100))
                        (>! ch "hello ")
                        (<! (timeout 100))
                        (>! ch "world")
                        (close! ch))
                      (http/ok ch)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using completable future as response."
    (letfn [(handler [ctx]
              (p/promise (fn [resolve]
                           (async/<!! (async/timeout 1000))
                           (resolve (http/ok "hello world")))))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using completable future as body."
    (letfn [(handler [ctx]
              (http/ok (p/promise (fn [resolve]
                                    (async/<!! (async/timeout 1000))
                                    (resolve "hello world")))))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using publisher as body"
    (letfn [(handler [ctx]
              (let [p (stream/publisher ["hello" " " "world"])
                    p (stream/transform (map str/upper) p)]
                (http/accepted p)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "HELLO WORLD"))
          (is (= (:status response) 202))))))

  (testing "Using manifold deferred as response."
    (letfn [(handler [ctx]
              (let [d (md/deferred)]
                (async/thread
                  (md/success! d (http/accepted "hello world")))
                d))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using manifold deferred as body."
    (letfn [(handler [ctx]
              (let [d (md/deferred)]
                (async/thread
                  (md/success! d "hello world"))
                (http/accepted d)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using manifold stream as body."
    (letfn [(handler [ctx]
              (let [d (ms/stream 3)]
                (async/thread
                  @(ms/put! d "hello")
                  @(ms/put! d " ")
                  @(ms/put! d "world")
                  (ms/close! d))
                (http/accepted d)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using InputStream as body"
    (let [data (ByteArrayInputStream. (.getBytes "Hello world!" "UTF-8"))
          handler (fn [context]
                    (http/ok data {:content-type "text/plain;charset=utf-8"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "Hello world!"))
          (is (= (:status response) 200))))))

  (testing "Using InputStream as body"
    (let [data (.getBytes "Hello world!" "UTF-8")
          handler (fn [context]
                    (http/ok data {:content-type "text/plain;charset=utf-8"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "Hello world!"))
          (is (= (:status response) 200))))))
)

(deftest routing
  (testing "Routing with parameter."
    (let [handler (fn [ctx]
                    (let [params (:route-params ctx)]
                      (str "hello " (:name params))))
          app (ct/routes [[:any (fn [_] (ct/delegate))]
                          [:get ":name" handler]])]
      (with-server {:handler app}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "hello foo"))
          (is (= (:status response) 200))))))

  (testing "Routing assets with prefix."
    (let [handler (ct/routes [[:assets "static" {:dir "public"}]])]
      (with-server {:handler handler}
        (let [response (client/get (str base-url "/static/test.txt"))]
          (is (= (:body response) "hello world from test.txt\n"))
          (is (= (:status response) 200)))))

    (let [handler (ct/routes [[:assets "static" {:dir "public"
                                                 :indexes ["index.html"]}]])]
      (with-server {:handler handler}
        (let [response (client/get (str base-url "/static/"))]
          (is (= (:body response) "hello world\n"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers in one route."
    (let [handler1 (fn [ctx]
                     (ct/delegate {:foo "bar"}))
          handler2 (fn [ctx]
                     (str "hello " (:foo ctx)))
          router (ct/routes [[:get "" handler1 handler2]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url ""))]
          (is (= (:body response) "hello bar"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers in more than one route."
    (let [handler1 (fn [ctx]
                     (ct/delegate {:foo "bar"}))
          handler2 (fn [ctx]
                     (str "hello " (:foo ctx)))
          router (ct/routes [[:prefix "foo"
                              [:any handler1]
                              [:get handler2]]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "hello bar"))
          (is (= (:status response) 200))))))

  (testing "User defined error handler"
    (let [error-handler (fn [ctx error] (http/ok "no error"))
          handler (fn [ctx] (throw (Exception. "foobar")))
          router (ct/routes [[:error error-handler]
                             [:any handler]])]
      (with-server {:handler router}
        (let [response (client/get base-url)]
          (is (= (:body response) "no error"))
          (is (= (:status response) 200))))))

  (testing "User defined error handler"
    (let [error-handler1 (fn [ctx error] (http/ok "no error1"))
          error-handler2 (fn [ctx error] (http/ok "no error2"))
          handler (fn [ctx] (throw (Exception. "foobar")))
          router (ct/routes [[:prefix "foo"
                              [:error error-handler1]
                              [:any handler]]
                             [:prefix "bar"
                              [:error error-handler2]
                              [:any handler]]])]
      (with-server {:handler router}
        (let [response1 (client/get (str base-url "/foo"))
              response2 (client/get (str base-url "/bar"))]
          (is (= (:body response1) "no error1"))
          (is (= (:body response2) "no error2"))
          (is (= (:status response1) 200))
          (is (= (:status response2) 200))))))

  (testing "Chaining handlers by request method"
    (let [handler1 (fn [ctx] "from get")
          handler2 (fn [ctx] "from post")
          router (ct/routes [[:prefix "foo"
                              [:by-method
                               {:get handler1
                                :post handler2}]]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "from get"))
          (is (= (:status response) 200)))
        (let [response (client/post (str base-url "/foo"))]
          (is (= (:body response) "from post"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers with :all"
    (let [handler (fn [ctx] "from get")
          router (ct/routes [[:all "foo" handler]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "from get"))
          (is (= (:status response) 200))))))

  (testing "Routing with regex matchig"
    (letfn [(handler [ctx]
              (let [params (:route-params ctx)]
                (http/ok (:id params))))]
      (let [app (ct/routes [[:prefix ":id:\\d+"
                             [:any handler]]])]
        (with-server {:handler app}
          (let [response (client/get (str base-url "/2"))]
            (is (= (:body response) "2"))
            (is (= (:status response) 200)))
          (try
            (client/get (str base-url "/foo"))
            (throw (RuntimeException. "not expected"))
            (catch clojure.lang.ExceptionInfo e
              (let [data (ex-data e)]
                (is (= (:status data) 404)))))))))
)

(deftest request-body-handling
  (testing "Read body as text"
    (let [p (promise)
          handler (fn [ctx]
                    (let [body (:body ctx)]
                      (deliver p (slurp body)))
                    "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url {:body "Hello world"
                                             :content-type "application/zip"})]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))
          (let [bodydata (deref p 1000 nil)]
            (is (= bodydata "Hello world"))))))))

(deftest cps-handler-type
  (let [handler (fn [context next]
                   (a/thread
                     (a/<!! (a/timeout 500))
                     (next "hello world cps")))]
    (with-server {:handler (with-meta handler {:handler-type :catacumba/cps})}
      (let [response (client/get base-url)]
        (is (= (:body response) "hello world cps"))
        (is (= (:status response) 200))))))

(deftest context-data-forwarding
  (letfn [(handler1 [context]
            (ct/delegate {:foo 1}))
          (handler2 [context]
            (ct/delegate {:bar 2}))
          (handler3 [context]
            (ct/delegate {:baz (+ (:foo context)
                                  (:bar context))}))
          (handler4 [p context]
            (deliver p (select-keys context [:foo :bar :baz]))
            "hello world")]
    (let [p (promise)]
      (with-server {:handler (ct/routes [[:any handler1]
                                              [:any handler2]
                                              [:any handler3]
                                              [:any (partial handler4 p)]])}
      (let [response (client/get base-url)]
        (is (= (:body response) "hello world"))
        (is (= (:status response) 200))
        (is (= (deref p 1000 nil)
               {:foo 1 :bar 2 :baz 3})))))))

(deftest async-context-delegation
  (letfn [(handler1 [context]
            (md/future
              (ct/delegate)))
          (handler2 [context]
            (md/future
              (http/accepted "hello world" {:Content-Type "plain/text"})))]
    (with-server {:handler (ct/routes [[:any handler1]
                                       [:any handler2]])}
      (let [response (client/get (str base-url))]
        (is (= (:body response) "hello world"))
        (is (= (:status response) 202))))))

;; (deftest experiments
;;   (letfn [(handler1 [context]
;;             (println 1111)
;;             "hello world")
;;           (handler4 [context]
;;             (println 4444)
;;             (ct/delegate ))
;;           (handler2 [context]
;;             (println 2222)
;;             "hello world")
;;           (handler3 [context]
;;             (println 3333)
;;             "hello world")]
;;     (with-server (ct/routes [[:insert
;;                               [:any handler4]
;;                               [:get "foo" handler1]]
;;                              [:insert
;;                               [:any handler4]
;;                               [:get "bar" handler2]]
;;                              [:any handler3]])
;;       (let [response (client/get (str base-url "/bar"))]
;;         (is (= (:body response) "hello world"))
;;         (is (= (:status response) 200))))))

(ns catacumba.core-tests
  (:require [clojure.core.async :refer [put! take! chan <! >! go close! go-loop onto-chan timeout] :as a]
            [clojure.test :refer :all]
            [clojure.java.io :as io]
            [clojure.pprint :refer [pprint]]
            [clojure.core.async :as async]
            [clj-http.client :as client]
            [promissum.core :as p]
            [catacumba.stream :as stream]
            [cats.core :as m]
            [cuerdas.core :as str]
            [manifold.stream :as ms]
            [manifold.deferred :as md]
            [catacumba.core :as ct]
            [catacumba.http :as http]
            [catacumba.testing :refer [with-server]]
            [catacumba.handlers.interceptor])
  (:import ratpack.exec.Execution
           ratpack.func.Action
           ratpack.func.Block
           ratpack.exec.ExecInterceptor
           ratpack.exec.ExecInterceptor$ExecType
           java.io.ByteArrayInputStream))

(def base-url "http://localhost:5050")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftest public-address
  (let [p (promise)
        handler (fn [context]
                  (deliver p (ct/public-address context))
                  "hello world")]
    (with-server {:handler handler}
      (let [response (client/get base-url)
            uri (deref p 1000 nil)]
        (is (= (str uri) "http://localhost:5050"))))))

(deftest cookies
  (testing "Setting new cookie."
    (letfn [(handler [context]
              (ct/set-cookies! context {:foo {:value "bar" :secure true :http-only true}})
              "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (contains? response :cookies))
          (is (= (get-in response [:cookies "foo" :path]) "/"))
          (is (= (get-in response [:cookies "foo" :value]) "bar"))
          (is (= (get-in response [:cookies "foo" :secure]) true)))))))

(deftest request-response
  (testing "Using send! with context"
    (let [handler (fn [ctx] (ct/send! ctx "hello world"))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using string as return value."
    (let [handler (fn [ctx] "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using response object as return value with string as body."
    (let [handler (fn [ctx]
                    (http/ok "hello world" {:x-header "foobar"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (get-in response [:headers :x-header]) "foobar"))
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using channel as response."
    (let [handler (fn [ctx]
                    (go
                      (<! (timeout 100))
                      (http/ok "hello world")))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using channel as body."
    (let [handler (fn [ctx]
                    (let [ch (chan)]
                      (go
                        (<! (timeout 100))
                        (>! ch "hello ")
                        (<! (timeout 100))
                        (>! ch "world")
                        (close! ch))
                      (http/ok ch)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using completable future as response."
    (letfn [(handler [ctx]
              (p/promise (fn [resolve]
                           (async/<!! (async/timeout 1000))
                           (resolve (http/ok "hello world")))))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using completable future as body."
    (letfn [(handler [ctx]
              (http/ok (p/promise (fn [resolve]
                                    (async/<!! (async/timeout 1000))
                                    (resolve "hello world")))))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))))))

  (testing "Using publisher as body"
    (letfn [(handler [ctx]
              (let [p (stream/publisher ["hello" " " "world"])
                    p (stream/transform (map str/upper) p)]
                (http/accepted p)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "HELLO WORLD"))
          (is (= (:status response) 202))))))

  (testing "Using manifold deferred as response."
    (letfn [(handler [ctx]
              (let [d (md/deferred)]
                (async/thread
                  (md/success! d (http/accepted "hello world")))
                d))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using manifold deferred as body."
    (letfn [(handler [ctx]
              (let [d (md/deferred)]
                (async/thread
                  (md/success! d "hello world"))
                (http/accepted d)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using manifold stream as body."
    (letfn [(handler [ctx]
              (let [d (ms/stream 3)]
                (async/thread
                  @(ms/put! d "hello")
                  @(ms/put! d " ")
                  @(ms/put! d "world")
                  (ms/close! d))
                (http/accepted d)))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 202))))))

  (testing "Using InputStream as body"
    (let [data (ByteArrayInputStream. (.getBytes "Hello world!" "UTF-8"))
          handler (fn [context]
                    (http/ok data {:content-type "text/plain;charset=utf-8"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "Hello world!"))
          (is (= (:status response) 200))))))

  (testing "Using InputStream as body"
    (let [data (.getBytes "Hello world!" "UTF-8")
          handler (fn [context]
                    (http/ok data {:content-type "text/plain;charset=utf-8"}))]
      (with-server {:handler handler}
        (let [response (client/get base-url)]
          (is (= (:body response) "Hello world!"))
          (is (= (:status response) 200))))))
)

(deftest routing
  (testing "Routing with parameter."
    (let [handler (fn [ctx]
                    (let [params (:route-params ctx)]
                      (str "hello " (:name params))))
          app (ct/routes [[:any (fn [_] (ct/delegate))]
                          [:get ":name" handler]])]
      (with-server {:handler app}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "hello foo"))
          (is (= (:status response) 200))))))

  (testing "Routing assets with prefix."
    (let [handler (ct/routes [[:assets "static" {:dir "public"}]])]
      (with-server {:handler handler}
        (let [response (client/get (str base-url "/static/test.txt"))]
          (is (= (:body response) "hello world from test.txt\n"))
          (is (= (:status response) 200)))))

    (let [handler (ct/routes [[:assets "static" {:dir "public"
                                                 :indexes ["index.html"]}]])]
      (with-server {:handler handler}
        (let [response (client/get (str base-url "/static/"))]
          (is (= (:body response) "hello world\n"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers in one route."
    (let [handler1 (fn [ctx]
                     (ct/delegate {:foo "bar"}))
          handler2 (fn [ctx]
                     (str "hello " (:foo ctx)))
          router (ct/routes [[:get "" handler1 handler2]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url ""))]
          (is (= (:body response) "hello bar"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers in more than one route."
    (let [handler1 (fn [ctx]
                     (ct/delegate {:foo "bar"}))
          handler2 (fn [ctx]
                     (str "hello " (:foo ctx)))
          router (ct/routes [[:prefix "foo"
                              [:any handler1]
                              [:get handler2]]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "hello bar"))
          (is (= (:status response) 200))))))

  (testing "User defined error handler"
    (let [error-handler (fn [ctx error] (http/ok "no error"))
          handler (fn [ctx] (throw (Exception. "foobar")))
          router (ct/routes [[:error error-handler]
                             [:any handler]])]
      (with-server {:handler router}
        (let [response (client/get base-url)]
          (is (= (:body response) "no error"))
          (is (= (:status response) 200))))))

  (testing "User defined error handler"
    (let [error-handler1 (fn [ctx error] (http/ok "no error1"))
          error-handler2 (fn [ctx error] (http/ok "no error2"))
          handler (fn [ctx] (throw (Exception. "foobar")))
          router (ct/routes [[:prefix "foo"
                              [:error error-handler1]
                              [:any handler]]
                             [:prefix "bar"
                              [:error error-handler2]
                              [:any handler]]])]
      (with-server {:handler router}
        (let [response1 (client/get (str base-url "/foo"))
              response2 (client/get (str base-url "/bar"))]
          (is (= (:body response1) "no error1"))
          (is (= (:body response2) "no error2"))
          (is (= (:status response1) 200))
          (is (= (:status response2) 200))))))

  (testing "Chaining handlers by request method"
    (let [p (promise)
          handler1 (fn [ctx] "from get")
          handler2 (fn [ctx] "from post")
          handler3 (fn [ctx] (deliver p true) (ct/delegate))
          router (ct/routes [[:prefix "foo"
                              [:by-method
                               {:get [handler3 handler1]
                                :post handler2}]]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "from get"))
          (is (= (:status response) 200))
          (is (true? (deref p 1000 nil))))
        (let [response (client/post (str base-url "/foo"))]
          (is (= (:body response) "from post"))
          (is (= (:status response) 200))))))

  (testing "Chaining handlers with :all"
    (let [handler (fn [ctx] "from get")
          router (ct/routes [[:all "foo" handler]])]
      (with-server {:handler router}
        (let [response (client/get (str base-url "/foo"))]
          (is (= (:body response) "from get"))
          (is (= (:status response) 200))))))

  (testing "Routing with regex matchig"
    (letfn [(handler [ctx]
              (let [params (:route-params ctx)]
                (http/ok (:id params))))]
      (let [app (ct/routes [[:prefix ":id:\\d+"
                             [:any handler]]])]
        (with-server {:handler app}
          (let [response (client/get (str base-url "/2"))]
            (is (= (:body response) "2"))
            (is (= (:status response) 200)))
          (try
            (client/get (str base-url "/foo"))
            (throw (RuntimeException. "not expected"))
            (catch clojure.lang.ExceptionInfo e
              (let [data (ex-data e)]
                (is (= (:status data) 404)))))))))
)

(deftest request-body-handling
  (testing "Read body as text"
    (let [p (promise)
          handler (fn [ctx]
                    (let [body (:body ctx)]
                      (deliver p (slurp body)))
                    "hello world")]
      (with-server {:handler handler}
        (let [response (client/get base-url {:body "Hello world"
                                             :content-type "application/zip"})]
          (is (= (:body response) "hello world"))
          (is (= (:status response) 200))
          (let [bodydata (deref p 1000 nil)]
            (is (= bodydata "Hello world"))))))))

(deftest cps-handler-type
  (let [handler (fn [context next]
                   (a/thread
                     (a/<!! (a/timeout 500))
                     (next "hello world cps")))]
    (with-server {:handler (with-meta handler {:handler-type :catacumba/cps})}
      (let [response (client/get base-url)]
        (is (= (:body response) "hello world cps"))
        (is (= (:status response) 200))))))

(deftest context-data-forwarding
  (letfn [(handler1 [context]
            (ct/delegate {:foo 1}))
          (handler2 [context]
            (ct/delegate {:bar 2}))
          (handler3 [context]
            (ct/delegate {:baz (+ (:foo context)
                                  (:bar context))}))
          (handler4 [p context]
            (deliver p (select-keys context [:foo :bar :baz]))
            "hello world")]
    (let [p (promise)]
      (with-server {:handler (ct/routes [[:any handler1]
                                              [:any handler2]
                                              [:any handler3]
                                              [:any (partial handler4 p)]])}
      (let [response (client/get base-url)]
        (is (= (:body response) "hello world"))
        (is (= (:status response) 200))
        (is (= (deref p 1000 nil)
               {:foo 1 :bar 2 :baz 3})))))))

(deftest async-context-delegation
  (letfn [(handler1 [context]
            (md/future
              (ct/delegate)))
          (handler2 [context]
            (md/future
              (http/accepted "hello world" {:Content-Type "plain/text"})))]
    (with-server {:handler (ct/routes [[:any handler1]
                                       [:any handler2]])}
      (let [response (client/get (str base-url))]
        (is (= (:body response) "hello world"))
        (is (= (:status response) 202))))))

;; (deftest experiments
;;   (letfn [(handler1 [context]
;;             (println 1111)
;;             "hello world")
;;           (handler4 [context]
;;             (println 4444)
;;             (ct/delegate ))
;;           (handler2 [context]
;;             (println 2222)
;;             "hello world")
;;           (handler3 [context]
;;             (println 3333)
;;             "hello world")]
;;     (with-server (ct/routes [[:insert
;;                               [:any handler4]
;;                               [:get "foo" handler1]]
;;                              [:insert
;;                               [:any handler4]
;;                               [:get "bar" handler2]]
;;                              [:any handler3]])
;;       (let [response (client/get (str base-url "/bar"))]
;;         (is (= (:body response) "hello world"))
;;         (is (= (:status response) 200))))))

Add testcase for chaining handlers on by-method routing directive.