;;
;; Copyright (c) Two Sigma Open Source, LLC
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;;  http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;
(ns waiter.auth.spnego
  (:require [clojure.core.async :as async]
            [clojure.data.codec.base64 :as b64]
            [clojure.string :as str]
            [clojure.tools.logging :as log]
            [metrics.counters :as counters]
            [metrics.meters :as meters]
            [metrics.timers :as timers]
            [ring.middleware.cookies :as cookies]
            [ring.util.response :as rr]
            [waiter.auth.authentication :as auth]
            [waiter.correlation-id :as cid]
            [waiter.metrics :as metrics]
            [waiter.status-codes :refer :all]
            [waiter.util.utils :as utils])
  (:import (java.util.concurrent ThreadPoolExecutor)
           (org.ietf.jgss GSSContext GSSCredential GSSException GSSManager)))

(def ^:const negotiate-prefix "Negotiate ")
(def ^:const error-class-kerberos-negotiate "waiter.KerberosNegotiate")
(def ^:const error-class-kerberos-queue-length "waiter.KerberosQueueLength")

(defn- negotiate-token?
  "Predicate to determine if an authorization header represents a spnego negotiate token."
  [authorization]
  (str/starts-with? (str authorization) negotiate-prefix))

(defn decode-input-token
  "Decode the input token from the negotiate line, expects the authorization token to exist"
  ^bytes [request]
  (when-let [negotiate-token (auth/select-auth-header request negotiate-token?)]
    (some-> negotiate-token (str/split #" " 2) last str .getBytes b64/decode)))

(defn encode-output-token
  "Take a token from a gss accept context call and encode it for use in a -authenticate header"
  [token]
  (str negotiate-prefix (String. ^bytes (b64/encode token))))

(defn do-gss-auth-check
  [^GSSContext gss-context req]
  (when-let [intok (decode-input-token req)]
    (when-let [ntok (.acceptSecContext gss-context intok 0 (alength intok))]
      (encode-output-token ntok))))

(defn- response-http-401-unauthorized
  [request cause]
  (log/info "triggering 401 response for spnego authentication" cause)
  (counters/inc! (metrics/waiter-counter "core" "response-status" "401"))
  (meters/mark! (metrics/waiter-meter "core" "response-status-rate" "401"))
  (-> {:message "Unauthorized"
       :status http-401-unauthorized}
    (utils/data->error-response request)
    (cookies/cookies-response)))

(defn response-http-401-unauthorized-negotiate
  "Tell the client you'd like them to use kerberos"
  [request]
  (log/info "triggering 401 negotiate for spnego authentication")
  (-> (response-http-401-unauthorized request "for negotiation")
    (assoc :error-class error-class-kerberos-negotiate)
    (assoc-in [:headers "www-authenticate"] (str/trim negotiate-prefix))))

(defn response-http-401-unauthorized-spnego-disabled
  "Tell the client you'd like them to not use kerberos.
   Does not send the www-authenticate header, relies on upstream handlers to handle the missing negotiate header."
  [request]
  (response-http-401-unauthorized request "as it is disabled"))

(defn response-http-503-service-unavailable-temporarily-unavailable
  "Tell the client you're overloaded and would like them to try later"
  [request]
  (log/info "triggering 503 unavailable for spnego authentication")
  (counters/inc! (metrics/waiter-counter "core" "response-status" "503"))
  (meters/mark! (metrics/waiter-meter "core" "response-status-rate" "503"))
  (-> {:details {:error-class error-class-kerberos-queue-length}
       :message "Too many Kerberos authentication requests"
       :status http-503-service-unavailable}
    (utils/data->error-response request)
    (cookies/cookies-response)))

(defn gss-context-init
  "Initialize a new gss context with name 'svc_name'"
  []
  (let [manager (GSSManager/getInstance)
        creds (.createCredential manager GSSCredential/ACCEPT_ONLY)
        gss (.createContext manager creds)]
    (counters/inc! (metrics/waiter-counter "core" "gss-context-count"))
    (meters/mark! (metrics/waiter-meter "core" "gss-context-creation"))
    gss))

(defn gss-get-principal
  [^GSSContext gss]
  (str (.getSrcName gss)))

(defn too-many-pending-auth-requests?
  "Returns true if there are too many pending Kerberos auth requests."
  [^ThreadPoolExecutor thread-pool-executor max-queue-length]
  (-> thread-pool-executor
      .getQueue
      .size
      (>= max-queue-length)))

(defn populate-gss-credentials
  "Perform Kerberos authentication on the provided thread pool and populate the result in the response channel."
  [^ThreadPoolExecutor thread-pool-executor request response-chan]
  (let [current-correlation-id (cid/get-correlation-id)
        timer-context (timers/start (metrics/waiter-timer "core" "kerberos" "throttle" "delay"))]
    (.execute
      thread-pool-executor
      (fn process-gss-task []
        (cid/with-correlation-id
          current-correlation-id
          (try
            (timers/stop timer-context)
            (let [^GSSContext gss-context (gss-context-init)
                  token (do-gss-auth-check gss-context request)
                  principal (when (.isEstablished gss-context)
                              (gss-get-principal gss-context))]
              (async/>!! response-chan {:principal principal
                                        :token token}))
            (catch GSSException ex
              (log/error ex "gss exception during kerberos auth")
              (async/>!! response-chan
                         {:error (ex-info "Error during Kerberos authentication"
                                          {:details (.getMessage ex)
                                           :status http-403-forbidden}
                                          ex)}))
            (catch Throwable th
              (log/error th "error while performing kerberos auth")
              (async/>!! response-chan {:error th}))
            (finally
              (async/close! response-chan))))))))

(defn require-gss
  "This middleware enables the application to require a SPNEGO
   authentication. If SPNEGO is successful then the handler `request-handler`
   will be run, otherwise the handler will not be run and 401
   returned instead.  This middleware doesn't handle cookies for
   authentication, but that should be stacked before this handler."
  [request-handler ^ThreadPoolExecutor thread-pool-executor max-queue-length password]
  (fn require-gss-handler [request]
    (cond
      ;; spnego auth disabled for the service
      (= "false" (get-in request [:waiter-discovery :service-description-template "env" "USE_SPNEGO_AUTH"]))
      (response-http-401-unauthorized-spnego-disabled request)
      ;; Ensure we are not already queued with lots of Kerberos auth requests
      (too-many-pending-auth-requests? thread-pool-executor max-queue-length)
      (response-http-503-service-unavailable-temporarily-unavailable request)
      ;; Try and authenticate using kerberos and add cookie in response when valid
      (auth/select-auth-header request negotiate-token?)
      (let [current-correlation-id (cid/get-correlation-id)
            gss-response-chan (async/promise-chan)]
        ;; launch task that will populate the response in response-chan
        (populate-gss-credentials thread-pool-executor request gss-response-chan)
        (async/go
          (cid/with-correlation-id
            current-correlation-id
            (let [{:keys [error principal token]} (async/<! gss-response-chan)]
              (if-not error
                (try
                  (if principal
                    (let [auth-params-map (auth/build-auth-params-map :spnego principal)
                          response (auth/handle-request-auth request-handler request auth-params-map password nil true)]
                      (log/debug "added cookies to response")
                      (if token
                        (if (map? response)
                          (rr/header response "www-authenticate" token)
                          (let [actual-response (async/<! response)]
                            (rr/header actual-response "www-authenticate" token)))
                        response))
                    (response-http-401-unauthorized-negotiate request))
                  (catch Throwable th
                    (log/error th "error while processing response")
                    th))
                error)))))
      ;; Default to unauthorized
      :else
      (response-http-401-unauthorized-negotiate request))))

;;
;; Copyright (c) Two Sigma Open Source, LLC
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;;  http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;
(ns waiter.auth.spnego
  (:require [clojure.core.async :as async]
            [clojure.data.codec.base64 :as b64]
            [clojure.string :as str]
            [clojure.tools.logging :as log]
            [metrics.counters :as counters]
            [metrics.meters :as meters]
            [metrics.timers :as timers]
            [ring.middleware.cookies :as cookies]
            [ring.util.response :as rr]
            [waiter.auth.authentication :as auth]
            [waiter.correlation-id :as cid]
            [waiter.metrics :as metrics]
            [waiter.status-codes :refer :all]
            [waiter.util.utils :as utils])
  (:import (java.util.concurrent ThreadPoolExecutor)
           (org.ietf.jgss GSSContext GSSCredential GSSException GSSManager)))

(def ^:const negotiate-prefix "Negotiate ")
(def ^:const error-class-kerberos-negotiate "waiter.KerberosNegotiate")
(def ^:const error-class-kerberos-queue-length "waiter.KerberosQueueLength")

(defn- negotiate-token?
  "Predicate to determine if an authorization header represents a spnego negotiate token."
  [authorization]
  (str/starts-with? (str authorization) negotiate-prefix))

(defn decode-input-token
  "Decode the input token from the negotiate line, expects the authorization token to exist"
  ^bytes [request]
  (when-let [negotiate-token (auth/select-auth-header request negotiate-token?)]
    (some-> negotiate-token (str/split #" " 2) last str .getBytes b64/decode)))

(defn encode-output-token
  "Take a token from a gss accept context call and encode it for use in a -authenticate header"
  [token]
  (str negotiate-prefix (String. ^bytes (b64/encode token))))

(defn do-gss-auth-check
  [^GSSContext gss-context req]
  (when-let [intok (decode-input-token req)]
    (when-let [ntok (.acceptSecContext gss-context intok 0 (alength intok))]
      (encode-output-token ntok))))

(defn- response-http-401-unauthorized
  [request cause]
  (log/info "triggering 401 response for spnego authentication" cause)
  (counters/inc! (metrics/waiter-counter "core" "response-status" "401"))
  (meters/mark! (metrics/waiter-meter "core" "response-status-rate" "401"))
  (-> {:message "Unauthorized"
       :status http-401-unauthorized}
    (utils/data->error-response request)
    (cookies/cookies-response)))

(defn response-http-401-unauthorized-negotiate
  "Tell the client you'd like them to use kerberos"
  [request]
  (log/info "triggering 401 negotiate for spnego authentication")
  (-> (response-http-401-unauthorized request "for negotiation")
    (assoc :error-class error-class-kerberos-negotiate)
    (assoc-in [:headers "www-authenticate"] (str/trim negotiate-prefix))))

(defn response-http-401-unauthorized-spnego-disabled
  "Tell the client you'd like them to not use kerberos.
   Does not send the www-authenticate header, relies on upstream handlers to handle the missing negotiate header."
  [request]
  (response-http-401-unauthorized request "as it is disabled"))

(defn response-http-503-service-unavailable-temporarily-unavailable
  "Tell the client you're overloaded and would like them to try later"
  [request]
  (log/info "triggering 503 unavailable for spnego authentication")
  (counters/inc! (metrics/waiter-counter "core" "response-status" "503"))
  (meters/mark! (metrics/waiter-meter "core" "response-status-rate" "503"))
  (-> {:details {:error-class error-class-kerberos-queue-length}
       :message "Too many Kerberos authentication requests"
       :status http-503-service-unavailable}
    (utils/data->error-response request)
    (cookies/cookies-response)))

(defn gss-context-init
  "Initialize a new gss context with name 'svc_name'"
  []
  (let [manager (GSSManager/getInstance)
        creds (.createCredential manager GSSCredential/ACCEPT_ONLY)
        gss (.createContext manager creds)]
    (counters/inc! (metrics/waiter-counter "core" "gss-context-count"))
    (meters/mark! (metrics/waiter-meter "core" "gss-context-creation"))
    gss))

(defn gss-get-principal
  [^GSSContext gss]
  (str (.getSrcName gss)))

(defn too-many-pending-auth-requests?
  "Returns true if there are too many pending Kerberos auth requests."
  [^ThreadPoolExecutor thread-pool-executor max-queue-length]
  (-> thread-pool-executor
      .getQueue
      .size
      (>= max-queue-length)))

(defn populate-gss-credentials
  "Perform Kerberos authentication on the provided thread pool and populate the result in the response channel."
  [^ThreadPoolExecutor thread-pool-executor request response-chan]
  (let [current-correlation-id (cid/get-correlation-id)
        timer-context (timers/start (metrics/waiter-timer "core" "kerberos" "throttle" "delay"))]
    (.execute
      thread-pool-executor
      (fn process-gss-task []
        (cid/with-correlation-id
          current-correlation-id
          (try
            (timers/stop timer-context)
            (let [^GSSContext gss-context (gss-context-init)
                  token (do-gss-auth-check gss-context request)
                  principal (when (.isEstablished gss-context)
                              (gss-get-principal gss-context))]
              (async/>!! response-chan {:principal principal
                                        :token token}))
            (catch GSSException ex
              (log/error ex "gss exception during kerberos auth")
              (async/>!! response-chan
                         {:error (ex-info "Error during Kerberos authentication"
                                          {:details (.getMessage ex)
                                           :status http-403-forbidden}
                                          ex)}))
            (catch Throwable th
              (log/error th "error while performing kerberos auth")
              (async/>!! response-chan {:error th}))
            (finally
              (async/close! response-chan))))))))

(defn require-gss
  "This middleware enables the application to require a SPNEGO
   authentication. If SPNEGO is successful then the handler `request-handler`
   will be run, otherwise the handler will not be run and 401
   returned instead.  This middleware doesn't handle cookies for
   authentication, but that should be stacked before this handler."
  [request-handler ^ThreadPoolExecutor thread-pool-executor max-queue-length password]
  (fn require-gss-handler [request]
    (cond
      ;; spnego auth disabled for the service
      (= "false" (get-in request [:waiter-discovery :service-description-template "env" "USE_SPNEGO_AUTH"]))
      (response-http-401-unauthorized-spnego-disabled request)
      ;; Ensure we are not already queued with lots of Kerberos auth requests
      (too-many-pending-auth-requests? thread-pool-executor max-queue-length)
      (response-http-503-service-unavailable-temporarily-unavailable request)
      ;; Try and authenticate using kerberos and add cookie in response when valid
      (auth/select-auth-header request negotiate-token?)
      (let [current-correlation-id (cid/get-correlation-id)
            gss-response-chan (async/promise-chan)]
        ;; launch task that will populate the response in response-chan
        (populate-gss-credentials thread-pool-executor request gss-response-chan)
        (async/go
          (cid/with-correlation-id
            current-correlation-id
            (let [{:keys [error principal token]} (async/<! gss-response-chan)]
              (if-not error
                (try
                  (if principal
                    (let [auth-params-map (auth/build-auth-params-map :spnego principal)
                          response (auth/handle-request-auth request-handler request auth-params-map password nil true)]
                      (log/debug "added cookies to response")
                      (let [actual-response (if (map? response) response (async/<! response))]
                        (if token
                          (rr/header actual-response "www-authenticate" token)
                          actual-response)))
                    (response-http-401-unauthorized-negotiate request))
                  (catch Throwable th
                    (log/error th "error while processing response")
                    th))
                error)))))
      ;; Default to unauthorized
      :else
      (response-http-401-unauthorized-negotiate request))))

Fix type confusion when SPNEGO completes with no response (#1458)


(ns main
  (:use compojure.core cascade cascade.asset cascade.import ring.adapter.jetty)
  (:require
    [cascade.request :as cr]
    [compojure.route :as route]
    [compojure.handler :as handler]))

(set! *warn-on-reflection* true)

(defragment layout [title body]
  (import-stylesheet classpath-asset "cascade/bootstrap.css")
  :html [
  :head>title [title]
  :body>div.container [
    :h1 [title]
    body
    :hr
    :&copy " 2011 Howard M. Lewis Ship"
    ]])

(defview hello-world [req]
  (layout "Cascade Hello World"
    (markup
      :div.alert-message.success>p [
      "This page rendered at "
      :strong [(str (java.util.Date.))]
      "."
      ]
      :div.well [
      :a.btn.primary {:href "/hello"} ["Refresh"]
      :a.btn {:href "/hello/fail"} ["Force Failure"]
      ])))

(defroutes html-routes
  (GET "/hello" [] hello-world)
  ; /hello/fail provokes an exception:
  (GET "/hello/fail" [] (try (/ 0 0) (catch Exception e (throw (RuntimeException. "Failure dividing by zero." e))))))

(defroutes master-routes
  (cr/initialize "1.0"
    :public-folder "webapp"
    :html-routes html-routes)
  (route/not-found "Cascade Demo: No such resource"))

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

(run-jetty app {:port 8080})

(ns main
  (:use compojure.core cascade cascade.asset cascade.import ring.adapter.jetty)
  (:require
    [cascade.request :as cr]
    [ring.util.response :as response]
    [compojure.route :as route]
    [compojure.handler :as handler]))

(set! *warn-on-reflection* true)

(defragment layout [title body]
  (import-stylesheet classpath-asset "cascade/bootstrap.css")
  :html [
  :head>title [title]
  :body>div.container [
    :h1 [title]
    body
    :hr
    :&copy " 2011 Howard M. Lewis Ship"
    ]])

(defview hello-world [req]
  (layout "Cascade Hello World"
    (markup
      :div.alert-message.success>p [
      "This page rendered at "
      :strong [(str (java.util.Date.))]
      "."
      ]
      :div.well [
      :a.btn.primary {:href "/hello"} ["Refresh"]
      :a.btn {:href "/hello/fail"} ["Force Failure"]
      ])))

(defroutes html-routes
  (GET "/hello" [] hello-world)
  ; /hello/fail provokes an exception:
  (GET "/hello/fail" [] (try (/ 0 0) (catch Exception e (throw (RuntimeException. "Failure dividing by zero." e))))))

(defroutes master-routes
  (cr/initialize "1.0"
    :public-folder "webapp"
    :html-routes html-routes)
  (ANY "/" [] (response/redirect "/hello"))
  (route/not-found "Cascade Demo: No such resource"))

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

(run-jetty app {:port 8080})

Change test app to redirect / to /hello

Change test app to redirect / to /hello


;; Copyright (c) 2014-2015 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2014-2015 Alejandro Gómez <alejandro@dialelo.com>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(ns cats.builtin
  "Clojure(Script) built-in types extensions."
  (:require [clojure.set :as s]
            [cats.monad.maybe :as maybe]
            [cats.protocols :as p]
            [cats.context :as ctx]
            [cats.data :as d]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Nil as Nothing of Maybe monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(extend-type nil
  p/Context
  (-get-context [_] maybe/context)

  p/Extract
  (-extract [_] nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (Lazy) Sequence Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def sequence-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (concat sv sv'))

    p/Monoid
    (-mempty [_]
      (lazy-seq []))

    p/Functor
    (-fmap [_ f v]
      (map f v))

    p/Applicative
    (-pure [_ v]
      (lazy-seq [v]))

    (-fapply [_ self av]
      (for [f self
            v av]
           (f v)))

    p/Monad
    (-mreturn [_ v]
      (lazy-seq [v]))

    (-mbind [_ self f]
      (apply concat (map f self)))

    p/MonadZero
    (-mzero [_]
      (lazy-seq []))

    p/MonadPlus
    (-mplus [_ mv mv']
      (concat mv mv'))

    p/Foldable
    (-foldr [ctx f z xs]
      (lazy-seq
       (let [x (first xs)
             xs (rest xs)]
         (if (nil? x)
           z
           (f x (p/-foldr ctx f z xs))))))

    (-foldl [ctx f z xs]
      (lazy-seq
       (let [x (first xs)
             xs (rest xs)]
         (if (nil? x)
           z
           (p/-foldl ctx f (f z x) xs)))))))

(extend-type #?(:clj  clojure.lang.LazySeq
                :cljs cljs.core.LazySeq)
  p/Context
  (-get-context [_] sequence-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Vector Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def vector-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (into sv sv'))

    p/Monoid
    (-mempty [_]
      [])

    p/Functor
    (-fmap [_ f v]
      (vec (map f v)))

    p/Applicative
    (-pure [_ v]
      [v])

    (-fapply [_ self av]
      (vec (for [f self
                 v av]
             (f v))))

    p/Monad
    (-mreturn [_ v]
      [v])

    (-mbind [_ self f]
      (vec (mapcat f self)))

    p/MonadZero
    (-mzero [_]
      [])

    p/MonadPlus
    (-mplus [_ mv mv']
      (into mv mv'))

    p/Foldable
    (-foldr [ctx f z xs]
      (let [x (first xs)
            xs (rest xs)]
        (if (nil? x)
          z
          (f x (p/-foldr ctx f z xs)))))

    (-foldl [ctx f z xs]
      (let [x (first xs)
            xs (rest xs)]
        (if (nil? x)
          z
          (p/-foldl ctx f (f z x) xs))))))

(extend-type #?(:clj clojure.lang.PersistentVector
                :cljs cljs.core.PersistentVector)
  p/Context
  (-get-context [_] vector-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def set-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (s/union sv (set sv')))

    p/Monoid
    (-mempty [_]
      #{})

    p/Functor
    (-fmap [_ f self]
      (set (map f self)))

    p/Applicative
    (-pure [_ v]
      #{v})

    (-fapply [_ self av]
      (set (for [f self
                 v av]
             (f v))))

    p/Monad
    (-mreturn [_ v]
      #{v})

    (-mbind [_ self f]
      (apply s/union (map f self)))

    p/MonadZero
    (-mzero [_]
      #{})

    p/MonadPlus
    (-mplus [_ mv mv']
      (s/union mv mv'))))

(extend-type #?(:clj clojure.lang.PersistentHashSet
                :cljs cljs.core.PersistentHashSet)
  p/Context
  (-get-context [_] set-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monoids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def map-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (merge sv sv'))

    p/Monoid
    (-mempty [_]
      {})))

(extend-type #?(:clj clojure.lang.PersistentHashMap
                :cljs cljs.core.PersistentHashMap)
  p/Context
  (-get-context [_] map-monoid))

#?(:clj
   (extend-type clojure.lang.PersistentArrayMap
     p/Context
     (-get-context [_] map-monoid))
   :cljs
   (extend-type cljs.core.PersistentArrayMap
     p/Context
     (-get-context [_] map-monoid)))

#?(:clj
   (extend-type clojure.lang.PersistentTreeMap
     p/Context
     (-get-context [_] map-monoid))
   :cljs
   (extend-type cljs.core.PersistentTreeMap
     p/Context
     (-get-context [_] map-monoid)))

(def any-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (or sv sv'))

    p/Monoid
    (-mempty [_]
      false)))

(def all-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (and sv sv'))

    p/Monoid
    (-mempty [_]
      true)))

(def sum-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (+ sv sv'))

    p/Monoid
    (-mempty [_]
      0)))

(def prod-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (* sv sv'))

    p/Monoid
    (-mempty [_]
      1)))

(def string-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (str sv sv'))

    p/Monoid
    (-mempty [_]
      "")))

(extend-type #?(:clj java.lang.String
                :cljs js/String)
  p/Context
  (-get-context [_] string-monoid))

(def pair-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (d/pair
       (m/mappend (.fst sv) (.fst sv'))
       (m/mappend (.snd sv) (.snd sv'))))
    p/Monoid
    (-mempty [_]
      (d/pair
       (p/-mempty (ctx/get-current))
       (p/-mempty (ctx/get-current))))))

(extend-type cats.data.Pair
  p/Context
  (-get-context [_] pair-monoid))

;; Copyright (c) 2014-2015 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2014-2015 Alejandro Gómez <alejandro@dialelo.com>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(ns cats.builtin
  "Clojure(Script) built-in types extensions."
  (:require [clojure.set :as s]
            [cats.monad.maybe :as maybe]
            [cats.protocols :as p]
            [cats.context :as ctx]
            [cats.data :as d]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Nil as Nothing of Maybe monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(extend-type nil
  p/Context
  (-get-context [_] maybe/context)

  p/Extract
  (-extract [_] nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (Lazy) Sequence Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def sequence-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (concat sv sv'))

    p/Monoid
    (-mempty [_]
      (lazy-seq []))

    p/Functor
    (-fmap [_ f v]
      (map f v))

    p/Applicative
    (-pure [_ v]
      (lazy-seq [v]))

    (-fapply [_ self av]
      (for [f self
            v av]
           (f v)))

    p/Monad
    (-mreturn [_ v]
      (lazy-seq [v]))

    (-mbind [_ self f]
      (apply concat (map f self)))

    p/MonadZero
    (-mzero [_]
      (lazy-seq []))

    p/MonadPlus
    (-mplus [_ mv mv']
      (concat mv mv'))

    p/Foldable
    (-foldr [ctx f z xs]
      (lazy-seq
       (let [x (first xs)
             xs (rest xs)]
         (if (nil? x)
           z
           (f x (p/-foldr ctx f z xs))))))

    (-foldl [ctx f z xs]
      (lazy-seq
       (let [x (first xs)
             xs (rest xs)]
         (if (nil? x)
           z
           (p/-foldl ctx f (f z x) xs)))))))

(extend-type #?(:clj  clojure.lang.LazySeq
                :cljs cljs.core.LazySeq)
  p/Context
  (-get-context [_] sequence-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Vector Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def vector-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (into sv sv'))

    p/Monoid
    (-mempty [_]
      [])

    p/Functor
    (-fmap [_ f v]
      (vec (map f v)))

    p/Applicative
    (-pure [_ v]
      [v])

    (-fapply [_ self av]
      (vec (for [f self
                 v av]
             (f v))))

    p/Monad
    (-mreturn [_ v]
      [v])

    (-mbind [_ self f]
      (vec (mapcat f self)))

    p/MonadZero
    (-mzero [_]
      [])

    p/MonadPlus
    (-mplus [_ mv mv']
      (into mv mv'))

    p/Foldable
    (-foldr [ctx f z xs]
      (let [x (first xs)
            xs (rest xs)]
        (if (nil? x)
          z
          (f x (p/-foldr ctx f z xs)))))

    (-foldl [ctx f z xs]
      (let [x (first xs)
            xs (rest xs)]
        (if (nil? x)
          z
          (p/-foldl ctx f (f z x) xs))))))

(extend-type #?(:clj clojure.lang.PersistentVector
                :cljs cljs.core.PersistentVector)
  p/Context
  (-get-context [_] vector-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def set-context
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (s/union sv (set sv')))

    p/Monoid
    (-mempty [_]
      #{})

    p/Functor
    (-fmap [_ f self]
      (set (map f self)))

    p/Applicative
    (-pure [_ v]
      #{v})

    (-fapply [_ self av]
      (set (for [f self
                 v av]
             (f v))))

    p/Monad
    (-mreturn [_ v]
      #{v})

    (-mbind [_ self f]
      (apply s/union (map f self)))

    p/MonadZero
    (-mzero [_]
      #{})

    p/MonadPlus
    (-mplus [_ mv mv']
      (s/union mv mv'))))

(extend-type #?(:clj clojure.lang.PersistentHashSet
                :cljs cljs.core.PersistentHashSet)
  p/Context
  (-get-context [_] set-context))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monoids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def map-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (merge sv sv'))

    p/Monoid
    (-mempty [_]
      {})))

(extend-type #?(:clj clojure.lang.PersistentHashMap
                :cljs cljs.core.PersistentHashMap)
  p/Context
  (-get-context [_] map-monoid))

#?(:clj
   (extend-type clojure.lang.PersistentArrayMap
     p/Context
     (-get-context [_] map-monoid))
   :cljs
   (extend-type cljs.core.PersistentArrayMap
     p/Context
     (-get-context [_] map-monoid)))

#?(:clj
   (extend-type clojure.lang.PersistentTreeMap
     p/Context
     (-get-context [_] map-monoid))
   :cljs
   (extend-type cljs.core.PersistentTreeMap
     p/Context
     (-get-context [_] map-monoid)))

(def any-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (or sv sv'))

    p/Monoid
    (-mempty [_]
      false)))

(def all-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (and sv sv'))

    p/Monoid
    (-mempty [_]
      true)))

(def sum-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (+ sv sv'))

    p/Monoid
    (-mempty [_]
      0)))

(def prod-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (* sv sv'))

    p/Monoid
    (-mempty [_]
      1)))

(def string-monoid
  (reify
    p/ContextClass
    (-get-level [_] ctx/+level-default+)

    p/Semigroup
    (-mappend [_ sv sv']
      (str sv sv'))

    p/Monoid
    (-mempty [_]
      "")))

(extend-type #?(:clj java.lang.String
                :cljs js/String)
  p/Context
  (-get-context [_] string-monoid))

(defn pair-monoid
  "A pair monoid type constructor."
  [inner-monoid]
  (reify
    p/ContextClass
    (-get-level [_]
      (+ (p/-get-level inner-monoid)
         ctx/+level-default+))

    p/Semigroup
    (-mappend [_ sv sv']
      (d/pair
       (p/-mappend inner-monoid (.fst sv) (.fst sv'))
       (p/-mappend inner-monoid (.snd sv) (.snd sv'))))

    p/Monoid
    (-mempty [_]
      (d/pair
       (p/-mempty inner-monoid)
       (p/-mempty inner-monoid)))))

(extend-type cats.data.Pair
  p/Context
  (-get-context [data]
    (let [first' (.fst data)]
      (pair-monoid (p/-get-context first')))))

Make pair-monoid implementation as type constructor instead of static type.


(ns circleci.repl
  (:use [clojure.contrib.with-ns :only (with-ns)])
  (:require [clojure.java.jdbc :as jdbc]))

(defn init []
  (with-ns 'user
    (use 'clojure.repl)
    (use '[clojure.contrib.ns-utils :only (docs)])
    (use '[clojure.contrib.repl-utils :exclude (apropos source)])
    (require '[clojure.contrib.zip-filter :as zf]
             '[clojure.zip :as zip]
             '[clojure.contrib.zip-filter.xml :as zf-xml]
             '[clojure.xml :as xml])
    (require '[clojure.contrib.sql :as sql])

    (use '[circleci.db :only (with-conn)]))
  (println "repl/init done"))

(ns circleci.repl
  (:use [clojure.contrib.with-ns :only (with-ns)])
  (:require [clojure.java.jdbc :as jdbc]))

(defn init []
  (with-ns 'user
    (use 'clojure.repl)
    (use '[clojure.contrib.ns-utils :only (docs)])
    (use '[clojure.contrib.repl-utils :exclude (apropos source)])
    (require '[clojure.contrib.zip-filter :as zf]
             '[clojure.zip :as zip]
             '[clojure.contrib.zip-filter.xml :as zf-xml]
             '[clojure.xml :as xml])
    (use '[circleci.db :only (with-conn)]))
  (println "repl/init done"))

Remove outdated SQL statement

Remove outdated SQL statement


(ns scamp.core
  (:require [taoensso.timbre :as timbre]
            [schema.core :as s]))

(s/set-fn-validation! true)

(def envelope-id-counter (atom 0))

(defn ^:dynamic *get-envelope-id*
  "TODO: replace with UUIDs"
  []
  (str (swap! envelope-id-counter inc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Custom randomization (for predictable testing)
(def ^:dynamic *rand* rand)

(defn- ^Integer rand-int* [n]
  (int (*rand* n)))

(defn- rand-nth* [coll]
  (nth coll (rand-int* (count coll))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- concatv [coll & colls]
  (vec (apply concat coll colls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Schema definitions
(def NodeContactAddressSchema
  s/Str)

(def NodeCoreSchema
  {:id NodeContactAddressSchema})

(def NodeNeighborsSchema
  ;; TODO: decouple contact address and node ID.
  #{NodeContactAddressSchema})

(def NetworkedNodeSchema
  {:self NodeCoreSchema
   :upstream NodeNeighborsSchema
   :downstream NodeNeighborsSchema
   :messages-seen {MessageEnvelopeIdSchema s/Int}})

(def MessageTypeSchema
  (s/enum :forwarded-subscription
          :add-upstream))

(def SubscriptionSchema
  NodeContactAddressSchema)

#_
(defmacro or-schema
  [& schemas]
  (let [preds (map #(fn [x] (println :checking x %) (s/check % x)) schemas)]
    (println :preds preds)
    `(s/pred #(some nil? ~preds))))

#_
(s/defn or-schema :- (s/protocol s/Schema)
  "Take one or more schemas. Return a schema that matches at least one of them."
  [& schemas :- [(s/protocol s/Schema)]]
  (println :schemas schemas)
  (let [preds (map #(fn [x] (println :checking x %) (s/check % x)) schemas)]
    (println :preds preds)
    (s/pred #(some nil? preds))))

(def MessageBodySchema
  (s/pred #(some nil?
                 [(s/check SubscriptionSchema %)])))

(def MessageEnvelopeIdSchema s/Str)

(def MessageEnvelopeSchema
  [(s/one (s/eq :message-envelope) "envelope variant type")
   (s/one NodeContactAddressSchema "envelope destination")
   (s/one MessageTypeSchema "envelope message type")
   (s/one MessageBodySchema "envelope body")
   (s/one MessageEnvelopeIdSchema "envelope id")])

(def WorldConfigSchema
  {:connection-redundancy s/Int
   :message-dup-drop-after s/Int
   :logging {s/Keyword s/Any}})

(def WorldSchema
  {:message-envelopes [MessageEnvelopeSchema]
   :config WorldConfigSchema
   :network {NodeContactAddressSchema NetworkedNodeSchema}})

(def CommUpdateSchema
  [(s/one NetworkedNodeSchema "networked node (recipient of processed message)")
   ;; zereo or more new messages
   [MessageEnvelopeSchema]])

(def ProbabilitySchema
  (s/pred #(<= 0 % 1)))

"
TODO:
  * distinguish better between node contact info (network address, map entry in (:network world)) and node itself
  * add message-envelope UUIDs so nodes can count duplicates of forwarded subscriptions
"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defaults and samples
(def default-config
  {;; :c :connection-redundancy
   :connection-redundancy 2 ;; Emperically determined by [1]
   :message-dup-drop-after 10 ;; Empirically determined by [1]
   :logging (assoc timbre/*config*
                   :level :debug)
   }
  )

(def sample-node
  {:self {:id "node-id5"
          :host "127.0.0.1"
          :port 2005}

   :partial-view :downstream
   :local-view :downstream
   :downstream #{"node-id1" ; node-contact-address for node-id1
                 "node-id2" ; node-contact-address for node-id2
                 }

   :in-view :upstream
   :upstream #{"node-id3" ; node-contact-address for node-id3
               "node-id4" ; node-contact-address for node-id4
               }})

(def sample-subscription-request
  {:new-node-contact-address "node-id6"
   :contact-address "node-id1" ; clustered node-contact-address
   })

(def sample-world
  {:message-envelopes []
   :config default-config
   :network {"node-id0" {:self {:id "node-id0"}
                         :downstream #{}
                         :upstream #{}}
             "node-id1" sample-node}})

(s/defn node->node-contact-address :- NodeContactAddressSchema
  "Take a 'node, and return the contact address for the node.

  E.g., a node contact address in a simulation 'world might just be
  the node's name, whereas a node contact address in a TCP/IP gossip
  cluster might be a map with an IP address and a port number."
  [node :- NodeCoreSchema]
  {:pre [(map? node)]
   ;; For now, node-contact-addresses are strings that can be used to
   ;; get nodes from 'world:
   ;; (get-in world [:network node-contact-address)
   :post [(string? %)]}
  (:id node))

(s/defn networked-node->node-contact-address :- NodeContactAddressSchema
  [node :- NetworkedNodeSchema]
  (-> node
      :self
      node->node-contact-address))

(s/defn node-contact-address->node :- NetworkedNodeSchema
  "Take a node-contact-address, return a networked-node structure."
  [node-contact-address :- NodeContactAddressSchema]
  {:self {:id node-contact-address}
   :upstream #{}
   :downstream #{}
   :messages-seen {}})

(s/defn init-new-subscriber :- NetworkedNodeSchema
  "Take a 'subscriber-address for a new subscriber, and the
  'contact-node handling the subscription, and return an initialized
  networked-node for the new subscriber."
  [subscriber-address :- NodeContactAddressSchema
   contact-node :- NodeContactAddressSchema]
  (-> subscriber-address
      node-contact-address->node
      (assoc-in [:downstream] #{contact-node})))

(s/defn subscription-acceptance-probability :- ProbabilitySchema
  "Determine the probability that a node will accept a subscription
  request (for a node not already present in 'downstream), given the
  count of 'downstream."
  [downstream :- NodeNeighborsSchema]
  (/ 1 (+ 1 (count downstream))))

(s/defn handle-new-subscription :- [MessageEnvelopeSchema]
  "Forward the 'subscription to every :downstream node, duplicating
  the forwarded 'subscription to :connection-redundancy :downstream
  nodes. If :downstream is empty, do nothing."
  [config :- WorldConfigSchema
   {:keys [downstream] :as node} :- NetworkedNodeSchema
   subscription :- SubscriptionSchema]
  (if (empty? downstream)
    ;; There is no 'downstream. Do nothing, because the 'subscription
    ;; node will already have 'node in its :downstream.
    []

    ;; Forward subscription to :downstream.
    (let [downstream (seq downstream)
          downstream+ (reduce (fn [x _] (conj x (rand-nth* downstream)))
                              downstream
                              (range (:connection-redundancy config)))]
      (map
       (fn [node-id]
         [:message-envelope
          node-id
          :forwarded-subscription
          subscription
          (get-envelope-id)])
       downstream+))))

(s/defn do-probability :- s/Bool
  "'rand is inclusive of 0 and exclusive of 1, so our test should not have '=."
  [cutoff :- ProbabilitySchema]
  (< (*rand*) cutoff))

(s/defn forward-subscription :- [MessageEnvelopeSchema]
  "Take a node's 'downstream map, a new 'subscription, and the
  'envelope-id.

  Return a seq of message-envelopes that communicate the forwarded
  subscription."
  [downstream :- NodeNeighborsSchema
   subscription :- SubscriptionSchema
   envelope-id :- MessageEnvelopeIdSchema]
  {:post [(vector? %)]}
  (if (empty? downstream)
    []
    [[:message-envelope
      (rand-nth* (seq downstream))
      :forwarded-subscription
      subscription
      envelope-id]]))

(s/defn handle-add-upstream :- CommUpdateSchema
  "Take a node and a new 'upstream-node-contact-address, and return a
  vector matching CommUpdateSchema."
  [logging-config
   node :- NetworkedNodeSchema
   upstream-node-contact-address :- NodeContactAddressSchema]
  (timbre/log* logging-config :trace
               :handle-add-upstream
               :node node
               :upstream-node-contact-address upstream-node-contact-address)
  [(update node :upstream conj upstream-node-contact-address)
   []])

(s/defn notify-add-upstream :- MessageEnvelopeSchema
  "Take a new 'upstream-node-contact-address and a 'node, and return
  an :add-upstream message envelope for
  'upstream-node-contact-address."
  [node :- NetworkedNodeSchema
   upstream-node-contact-address :- NodeContactAddressSchema]
  [:message-envelope
   upstream-node-contact-address
   :add-upstream
   (get-in node [:self :id])
   (*get-envelope-id*)])

(s/defn handle-forwarded-subscription :- CommUpdateSchema
  "Take 'logging-config, a node, a new subscription, and an
  'envelope-id. Either accept the subscription into :downstream, or
  forward it to a :downstream node.

  Return a vector matching 'CommUpdateSchema."
  [logging-config
   {:keys [downstream] :as node} :- NetworkedNodeSchema
   subscriber-contact-address :- NodeContactAddressSchema
   envelope-id :- MessageEnvelopeIdSchema]
  (timbre/log* logging-config :trace
               :handle-forwarded-subscription
               :node node
               :subscriber-contact-address subscriber-contact-address)
  (if (and (not= (get-in node [:self :id]) subscriber-contact-address)
           (not (downstream subscriber-contact-address))
           ;; The subscription id is not for this node itself, and
           ;; the subscription id is not already in node's downstream,
           ;; so check the probability that we add it to this node.
           (do-probability (subscription-acceptance-probability downstream)))
    [(update-in node [:downstream] conj subscriber-contact-address)
     [(notify-add-upstream node subscriber-contact-address)]]

    (let [forwarded-subscription-messages (forward-subscription downstream
                                                                subscriber-contact-address
                                                                envelope-id)]
      (when (empty? forwarded-subscription-messages)
        (throw (ex-info "Failed either to accept or forward subscription"
                        {:node node :subscriber-contact-address subscriber-contact-address})))
      [node forwarded-subscription-messages])))

(def new-world
  "Return a new, pristine world."
  {:message-envelopes []
   :config default-config
   :network {}})

(s/defn add-new-node :- WorldSchema
  "Update world to 'turn on' node."
  [world :- WorldSchema
   networked-node :- NetworkedNodeSchema]
  (assoc-in world [:network (node->node-contact-address (:self networked-node))]
            networked-node))

(s/defn add-messages :- WorldSchema
  "Given 'world and new messages to add, return 'world with the new
  messages added."
  [world :- WorldSchema
   new-messages :- [MessageEnvelopeSchema]]
  (update-in world [:message-envelopes] concatv new-messages))

(s/defn subscribe :- WorldSchema
  "Given 'world, a 'new-node-contact-address for the node that is
  subscribing, and a 'networked-node, forward subscription requests
  from 'networked-node."
  [world :- WorldSchema
   new-node-contact-address :- NodeContactAddressSchema
   networked-node :- NodeContactAddressSchema]
  (let [new-node (init-new-subscriber new-node-contact-address networked-node)
        new-messages (handle-new-subscription
                      (:config world)
                      (get-in world [:network networked-node])
                      new-node-contact-address)]
    (-> world
        (add-new-node new-node)
        (add-messages new-messages))))

(defn read-mail
  "Take a 'destination-node and a 'message.

  Process the message for 'destination-node and return a vector
  matching 'CommUpdateSchema.

  If this envelope has been seen too many times by 'destination-node
  (as configured by :message-dup-drop-after in 'config), then ignore
  the message."
  [{:keys [logging message-dup-drop-after] :as config}
   destination-node :- NetworkedNodeSchema
   [message-type message-body envelope-id]]
  {:post [(vector? %) (-> % first map?) (-> % second vector?)]}
  (timbre/log* logging :trace
               :read-mail
               :destination-node destination-node
               :message-type message-type
               :message-body message-body
               :envelope-id envelope-id)
  (let [destination-node (update-in destination-node [:messages-seen envelope-id] #(if % (inc %) 1))]
    (if (< (get-in destination-node [:messages-seen envelope-id])
           message-dup-drop-after)
      (condp = message-type
        :add-upstream (handle-add-upstream logging destination-node message-body)
        :forwarded-subscription (handle-forwarded-subscription logging
                                                               destination-node
                                                               message-body
                                                               envelope-id)
        (println :read-mail "Unknown message type (" message-type "): " message-body))
      (do
        (timbre/log* logging :trace
                     :read-mail-dropping-dup
                     :destination-node destination-node
                     :envelope-id envelope-id)
        [destination-node []]))))

(defn do-comm
  "Take 'world. Process one message. Return new 'world."
  [{:keys [config] :as world}]
  (let [[[_ destination-node-id & message] & message-envelopes] (:message-envelopes world)
        destination-node (get-in world [:network destination-node-id])
        [new-destination-node new-message-envelopes] (read-mail (:logging config)
                                                                destination-node
                                                                message)]
    (-> world
        (assoc :message-envelopes (concat message-envelopes new-message-envelopes))
        (assoc-in [:network destination-node-id] new-destination-node))))

(comment
  [1] "Peer-to-Peer Membership Management for Gossip-Based Protocols"

  (-> new-world
      (add-node (node-contact-address->node "node-id0"))
      (subscribe "node-id1" "node-id0")
      do-comm
      ;; TODO: add more nodes here, test handle-forwarded-subscription, test forward-subscription, etc.
      (dissoc :config)
      clojure.pprint/pprint)

  )

(ns scamp.core
  (:require [taoensso.timbre :as timbre]
            [schema.core :as s]))

(s/set-fn-validation! true)

(def envelope-id-counter (atom 0))

(defn ^:dynamic *get-envelope-id*
  "TODO: replace with UUIDs"
  []
  (str (swap! envelope-id-counter inc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Custom randomization (for predictable testing)
(def ^:dynamic *rand* rand)

(defn- ^Integer rand-int* [n]
  (int (*rand* n)))

(defn- rand-nth* [coll]
  (nth coll (rand-int* (count coll))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- concatv [coll & colls]
  (vec (apply concat coll colls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Schema definitions
(def NodeContactAddressSchema
  s/Str)

(def NodeCoreSchema
  {:id NodeContactAddressSchema})

(def NodeNeighborsSchema
  ;; TODO: decouple contact address and node ID.
  #{NodeContactAddressSchema})

(def NetworkedNodeSchema
  {:self NodeCoreSchema
   :upstream NodeNeighborsSchema
   :downstream NodeNeighborsSchema
   :messages-seen {MessageEnvelopeIdSchema s/Int}})

(def MessageTypeSchema
  (s/enum :forwarded-subscription
          :add-upstream))

(def SubscriptionSchema
  NodeContactAddressSchema)

#_
(defmacro or-schema
  [& schemas]
  (let [preds (map #(fn [x] (println :checking x %) (s/check % x)) schemas)]
    (println :preds preds)
    `(s/pred #(some nil? ~preds))))

#_
(s/defn or-schema :- (s/protocol s/Schema)
  "Take one or more schemas. Return a schema that matches at least one of them."
  [& schemas :- [(s/protocol s/Schema)]]
  (println :schemas schemas)
  (let [preds (map #(fn [x] (println :checking x %) (s/check % x)) schemas)]
    (println :preds preds)
    (s/pred #(some nil? preds))))

(def MessageBodySchema
  (s/pred #(some nil?
                 [(s/check SubscriptionSchema %)])))

(def MessageEnvelopeIdSchema s/Str)

(def MessageEnvelopeSchema
  [(s/one (s/eq :message-envelope) "envelope variant type")
   (s/one NodeContactAddressSchema "envelope destination")
   (s/one MessageTypeSchema "envelope message type")
   (s/one MessageBodySchema "envelope body")
   (s/one MessageEnvelopeIdSchema "envelope id")])

(def WorldConfigSchema
  {:connection-redundancy s/Int
   :message-dup-drop-after s/Int
   :logging {s/Keyword s/Any}})

(def WorldSchema
  {:message-envelopes [MessageEnvelopeSchema]
   :config WorldConfigSchema
   :network {NodeContactAddressSchema NetworkedNodeSchema}})

(def CommUpdateSchema
  [(s/one NetworkedNodeSchema "networked node (recipient of processed message)")
   ;; zereo or more new messages
   [MessageEnvelopeSchema]])

(def ProbabilitySchema
  (s/pred #(<= 0 % 1)))

"
TODO:
  * distinguish better between node contact info (network address, map entry in (:network world)) and node itself
  * add message-envelope UUIDs so nodes can count duplicates of forwarded subscriptions
"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defaults and samples
(def default-config
  {;; :c :connection-redundancy
   :connection-redundancy 2 ;; Emperically determined by [1]
   :message-dup-drop-after 10 ;; Empirically determined by [1]
   :logging (assoc timbre/*config*
                   :level :debug)
   }
  )

(def sample-node
  {:self {:id "node-id5"
          :host "127.0.0.1"
          :port 2005}

   :partial-view :downstream
   :local-view :downstream
   :downstream #{"node-id1" ; node-contact-address for node-id1
                 "node-id2" ; node-contact-address for node-id2
                 }

   :in-view :upstream
   :upstream #{"node-id3" ; node-contact-address for node-id3
               "node-id4" ; node-contact-address for node-id4
               }})

(def sample-subscription-request
  {:new-node-contact-address "node-id6"
   :contact-address "node-id1" ; clustered node-contact-address
   })

(def sample-world
  {:message-envelopes []
   :config default-config
   :network {"node-id0" {:self {:id "node-id0"}
                         :downstream #{}
                         :upstream #{}}
             "node-id1" sample-node}})

(s/defn node->node-contact-address :- NodeContactAddressSchema
  "Take a 'node, and return the contact address for the node.

  E.g., a node contact address in a simulation 'world might just be
  the node's name, whereas a node contact address in a TCP/IP gossip
  cluster might be a map with an IP address and a port number."
  [node :- NodeCoreSchema]
  {:pre [(map? node)]
   ;; For now, node-contact-addresses are strings that can be used to
   ;; get nodes from 'world:
   ;; (get-in world [:network node-contact-address)
   :post [(string? %)]}
  (:id node))

(s/defn networked-node->node-contact-address :- NodeContactAddressSchema
  [node :- NetworkedNodeSchema]
  (-> node
      :self
      node->node-contact-address))

(s/defn node-contact-address->node :- NetworkedNodeSchema
  "Take a node-contact-address, return a networked-node structure."
  [node-contact-address :- NodeContactAddressSchema]
  {:self {:id node-contact-address}
   :upstream #{}
   :downstream #{}
   :messages-seen {}})

(s/defn init-new-subscriber :- NetworkedNodeSchema
  "Take a 'subscriber-address for a new subscriber, and the
  'contact-node handling the subscription, and return an initialized
  networked-node for the new subscriber."
  [subscriber-address :- NodeContactAddressSchema
   contact-node :- NodeContactAddressSchema]
  (-> subscriber-address
      node-contact-address->node
      (assoc-in [:downstream] #{contact-node})))

(s/defn subscription-acceptance-probability :- ProbabilitySchema
  "Determine the probability that a node will accept a subscription
  request (for a node not already present in 'downstream), given the
  count of 'downstream."
  [downstream :- NodeNeighborsSchema]
  (/ 1 (+ 1 (count downstream))))

(s/defn handle-new-subscription :- [MessageEnvelopeSchema]
  "Forward the 'subscription to every :downstream node, duplicating
  the forwarded 'subscription to :connection-redundancy :downstream
  nodes. If :downstream is empty, do nothing."
  [config :- WorldConfigSchema
   {:keys [downstream] :as node} :- NetworkedNodeSchema
   subscription :- SubscriptionSchema]
  (if (empty? downstream)
    ;; There is no 'downstream. Do nothing, because the 'subscription
    ;; node will already have 'node in its :downstream.
    []

    ;; Forward subscription to :downstream.
    (let [downstream (seq downstream)
          downstream+ (reduce (fn [x _] (conj x (rand-nth* downstream)))
                              downstream
                              (range (:connection-redundancy config)))]
      (map
       (fn [node-id]
         [:message-envelope
          node-id
          :forwarded-subscription
          subscription
          (get-envelope-id)])
       downstream+))))

(s/defn do-probability :- s/Bool
  "'rand is inclusive of 0 and exclusive of 1, so our test should not have '=."
  [cutoff :- ProbabilitySchema]
  (< (*rand*) cutoff))

(s/defn forward-subscription :- [MessageEnvelopeSchema]
  "Take a node's 'downstream map, a new 'subscription, and the
  'envelope-id.

  Return a seq of message-envelopes that communicate the forwarded
  subscription."
  [downstream :- NodeNeighborsSchema
   subscription :- SubscriptionSchema
   envelope-id :- MessageEnvelopeIdSchema]
  {:post [(vector? %)]}
  (if (empty? downstream)
    []
    [[:message-envelope
      (rand-nth* (seq downstream))
      :forwarded-subscription
      subscription
      envelope-id]]))

(s/defn handle-add-upstream :- CommUpdateSchema
  "Take a node and a new 'upstream-node-contact-address, and return a
  vector matching CommUpdateSchema."
  [logging-config
   node :- NetworkedNodeSchema
   upstream-node-contact-address :- NodeContactAddressSchema]
  (timbre/log* logging-config :trace
               :handle-add-upstream
               :node node
               :upstream-node-contact-address upstream-node-contact-address)
  [(update node :upstream conj upstream-node-contact-address)
   []])

(s/defn notify-add-upstream :- MessageEnvelopeSchema
  "Take a new 'upstream-node-contact-address and a 'node, and return
  an :add-upstream message envelope for
  'upstream-node-contact-address."
  [node :- NetworkedNodeSchema
   upstream-node-contact-address :- NodeContactAddressSchema]
  [:message-envelope
   upstream-node-contact-address
   :add-upstream
   (get-in node [:self :id])
   (*get-envelope-id*)])

(s/defn handle-forwarded-subscription :- CommUpdateSchema
  "Take 'logging-config, a node, a new subscription, and an
  'envelope-id. Either accept the subscription into :downstream, or
  forward it to a :downstream node.

  Return a vector matching 'CommUpdateSchema."
  [logging-config
   {:keys [downstream] :as node} :- NetworkedNodeSchema
   subscriber-contact-address :- NodeContactAddressSchema
   envelope-id :- MessageEnvelopeIdSchema]
  (timbre/log* logging-config :trace
               :handle-forwarded-subscription
               :node node
               :subscriber-contact-address subscriber-contact-address)
  (if (and (not= (get-in node [:self :id]) subscriber-contact-address)
           (not (downstream subscriber-contact-address))
           ;; The subscription id is not for this node itself, and
           ;; the subscription id is not already in node's downstream,
           ;; so check the probability that we add it to this node.
           (do-probability (subscription-acceptance-probability downstream)))
    [(update-in node [:downstream] conj subscriber-contact-address)
     [(notify-add-upstream node subscriber-contact-address)]]

    (let [forwarded-subscription-messages (forward-subscription downstream
                                                                subscriber-contact-address
                                                                envelope-id)]
      (when (empty? forwarded-subscription-messages)
        (throw (ex-info "Failed either to accept or forward subscription"
                        {:node node :subscriber-contact-address subscriber-contact-address})))
      [node forwarded-subscription-messages])))

(def new-world
  "Return a new, pristine world."
  {:message-envelopes []
   :config default-config
   :network {}})

(s/defn add-new-node :- WorldSchema
  "Update world to 'turn on' node."
  [world :- WorldSchema
   networked-node :- NetworkedNodeSchema]
  (assoc-in world [:network (node->node-contact-address (:self networked-node))]
            networked-node))

(s/defn add-messages :- WorldSchema
  "Given 'world and new messages to add, return 'world with the new
  messages added."
  [world :- WorldSchema
   new-messages :- [MessageEnvelopeSchema]]
  (update-in world [:message-envelopes] concatv new-messages))

(s/defn update-self :- WorldSchema
  "Given world and 'self, update self with 'f and 'args."
  [world :- WorldSchema
   self :- NetworkedNodeSchema
   f & args]
  (let [self-id (get-in self [:self :id])]
    (update-in world
               [:network self-id]
               #(apply f % args))))

(s/defn get-node-from-world :- NetworkedNodeSchema
  [world :- WorldSchema
   node-contact-address :- NodeContactAddressSchema]
  (get-in world [:network node-contact-address]))

(s/defn subscribe :- WorldSchema
  "Given 'world, a 'new-node-contact-address for the node that is
  subscribing, and a 'networked-node, forward subscription requests
  from 'networked-node."
  [world :- WorldSchema
   new-node-contact-address :- NodeContactAddressSchema
   networked-node :- NodeContactAddressSchema]
  (let [new-node (init-new-subscriber new-node-contact-address networked-node)
        new-messages (handle-new-subscription
                      (:config world)
                      (get-in world [:network networked-node])
                      new-node-contact-address)]
    (-> world
        (add-new-node new-node)
        (add-messages new-messages))))

(defn read-mail
  "Take a 'destination-node and a 'message.

  Process the message for 'destination-node and return a vector
  matching 'CommUpdateSchema.

  If this envelope has been seen too many times by 'destination-node
  (as configured by :message-dup-drop-after in 'config), then ignore
  the message."
  [{:keys [logging message-dup-drop-after] :as config}
   destination-node :- NetworkedNodeSchema
   [message-type message-body envelope-id]]
  {:post [(vector? %) (-> % first map?) (-> % second vector?)]}
  (timbre/log* logging :trace
               :read-mail
               :destination-node destination-node
               :message-type message-type
               :message-body message-body
               :envelope-id envelope-id)
  (let [destination-node (update-in destination-node [:messages-seen envelope-id] #(if % (inc %) 1))]
    (if (< (get-in destination-node [:messages-seen envelope-id])
           message-dup-drop-after)
      (condp = message-type
        :add-upstream (handle-add-upstream logging destination-node message-body)
        :forwarded-subscription (handle-forwarded-subscription logging
                                                               destination-node
                                                               message-body
                                                               envelope-id)
        (println :read-mail "Unknown message type (" message-type "): " message-body))
      (do
        (timbre/log* logging :trace
                     :read-mail-dropping-dup
                     :destination-node destination-node
                     :envelope-id envelope-id)
        [destination-node []]))))

(defn do-comm
  "Take 'world. Process one message. Return new 'world."
  [{:keys [config] :as world}]
  (let [[[_ destination-node-id & message] & message-envelopes] (:message-envelopes world)
        destination-node (get-in world [:network destination-node-id])
        [new-destination-node new-message-envelopes] (read-mail (:logging config)
                                                                destination-node
                                                                message)]
    (-> world
        (assoc :message-envelopes (concat message-envelopes new-message-envelopes))
        (assoc-in [:network destination-node-id] new-destination-node))))

(comment
  [1] "Peer-to-Peer Membership Management for Gossip-Based Protocols"

  (-> new-world
      (add-node (node-contact-address->node "node-id0"))
      (subscribe "node-id1" "node-id0")
      do-comm
      ;; TODO: add more nodes here, test handle-forwarded-subscription, test forward-subscription, etc.
      (dissoc :config)
      clojure.pprint/pprint)

  )

[scamp] Add 'update-self and 'get-node-from-world


(ns elevent-client.pages.events.id.edit
  (:require
    [goog.string :as string]

    [reagent.core :as r :refer [atom]]
    [datascript :as d]
    [validateur.validation :refer [format-of presence-of validation-set]]
    [cljs-time.coerce :refer [to-date from-string]]
    [cljs-time.core :refer [hours now plus]]

    [elevent-client.api :as api]
    [elevent-client.routes :as routes]
    [elevent-client.state :as state]
    [elevent-client.components.action-button :as action-button]
    [elevent-client.components.input :as input]
    [elevent-client.components.date-selector :as date-selector]))

(def validator
  (validation-set
    (presence-of :Name)
    (presence-of :Venue)
    (presence-of :StartDate)
    (presence-of :EndDate)
    (format-of :TicketPrice
               :format      #"^\d*\.\d\d$"
               :allow-nil   true
               :allow-blank true)
    (format-of :StartDate :format #"\d\d\d\d-\d\d-\d\dT\d\d:\d\d")
    (format-of :EndDate   :format #"\d\d\d\d-\d\d-\d\dT\d\d:\d\d")))

(defn page [& [event-id]]
  (let [form (atom {})
        clone-id (atom 0)]
    (when event-id
      (if-let [event (seq (d/entity @api/events-db event-id))]
        (reset! form (let [event (into {} event)]
                       (assoc event
                         :TicketPrice (str (:TicketPrice event)))))
        (add-watch api/events-db
                   :event-edit
                   (fn [_ _ _ db]
                     (reset! form (let [event (into {} (d/entity db event-id))]
                                    (assoc event
                                      :TicketPrice (str (:TicketPrice event)))))
                     (remove-watch api/events-db :event-edit)))))
    (add-watch clone-id :clone
               (fn [_ _ _ id]
                 (when-not (zero? (int id))
                   (let [clone-event (->> id
                                          int
                                          (d/entity @api/events-db)
                                          seq
                                          (into {}))]
                     (reset!
                       form
                       (dissoc
                         (assoc
                           clone-event
                           :TicketPrice
                           (if (> (:TicketPrice clone-event) 0)
                             (string/format "%.2f" (:TicketPrice clone-event))
                             ""))
                         :EventId))))))
    (fn []
      (let [{:keys [Name OrganizationId Venue StartDate EndDate
                    TicketPrice Description]}
            @form

            errors
            (validator @form)

            clonable-events
            (cons ["None" 0]
                  (doall
                    (filter (fn [[event-name event-id]]
                              (get-in @state/session
                                      [:permissions
                                       :EventPermissions
                                       event-id
                                       :EditEvent]))
                            (d/q '[:find ?name ?id
                                   :where [?id :Name ?name]]
                                 @api/events-db))))

            associated-organizations
            (cons ["None" 0]
                  (d/q '[:find ?name ?id
                         :where [?id :Name ?name]]
                       @api/organizations-db))

            create-event
            (fn [form]
              (fn [callback]
                (when (empty? errors)
                  (api/events-endpoint (if event-id :update :create)
                                       form
                                       #(do
                                          (callback)
                                          (js/location.replace
                                            (routes/events-explore)))))))]
        [:div.sixteen.wide.column
         [:div.ui.top.attached.tabular.menu
          [:a.item {:href (routes/events)}
           "Events"]
          [:a.item {:href (routes/events-explore)}
           "Explore"]
          [:a.item {:href (routes/events-owned)}
           "Owned"]
          [:a.active.item {:href (routes/event-add)}
           "Add"]]
         [:div.ui.bottom.attached.segment
          (prn-str @form)
          [:form.ui.form
           [:div.ui.vertical.segment
            [:h2.ui.dividing.header (if event-id "Edit" "Add") " an Event"]
            [:div.two.fields
             [:div.required.field {:class (when (and Name (:Name errors))
                                            :error)}
              [:label "Name"]
              [input/component :text {} (r/wrap Name swap! form assoc :Name)]]
             [:div.field
              [:label "Clone From"]
              [input/component :select {} clonable-events clone-id]]]
            [:div.two.fields
             [:div.required.field
              [:label "Organization"]
              [input/component :select {} associated-organizations
               (r/wrap OrganizationId swap! form assoc :OrganizationId)]]
             [:div.required.field {:class (when (and Venue (:Venue errors))
                                            :error)}
              [:div.required.field
               [:label "Venue"]
               [input/component :text {} (r/wrap Venue swap! form assoc :Venue)]]]]
            (let [start-date (r/wrap StartDate swap! form assoc :StartDate)
                  end-date   (r/wrap EndDate swap! form assoc :EndDate)]
              [:div.two.fields
               [:div.required.field {:class (when (and StartDate
                                                       (:StartDate errors))
                                              :error)}
                [:label "Start Date"]
                [date-selector/component
                 {:date-atom start-date
                  :pikaday-attrs (merge
                                   {:minDate (-> (now)
                                                 (plus (hours 6))
                                                 to-date)}
                                   (when @start-date
                                     {:defaultDate (-> (from-string @start-date)
                                                       (plus (hours 6))
                                                       to-date)
                                      :setDefaultDate true}))}]]
               [:div.required.field {:class (when (and EndDate
                                                       (:EndDate errors))
                                              :error)}
                [:label "End Date"]
                [date-selector/component
                 {:date-atom end-date
                  :min-date-atom start-date
                  :pikaday-attrs (merge
                                   {:minDate (-> (now)
                                                 (plus (hours 6))
                                                 to-date)}
                                   (when @end-date
                                     {:defaultDate (-> (from-string @end-date)
                                                       (plus (hours 6))
                                                       to-date)
                                      :setDefaultDate true}))}]]])
            [:div.field
             [:div.four.wide.field {:class (when (and TicketPrice
                                                      (:TicketPrice errors))
                                             :error)}
              [:label "Ticket Price"]
              [:div.ui.labeled.input
               [:div.ui.label "$"]
               [input/component :text {}
                (r/wrap TicketPrice swap! form assoc :TicketPrice)]]]]
            [:div.field
             [:label "Description"]
             [input/component :textarea {}
              (r/wrap Description swap! form assoc :Description)]]
            [action-button/component
             {:class (str "primary" (when (seq errors) " disabled"))}
             (if event-id "Edit" "Add")
             (create-event @form)]]]]]))))

(routes/register-page routes/event-edit-chan #'page)

(ns elevent-client.pages.events.id.edit
  (:require
    [goog.string :as string]

    [reagent.core :as r :refer [atom]]
    [datascript :as d]
    [validateur.validation :refer [format-of presence-of validation-set]]
    [cljs-time.coerce :refer [to-date from-string]]
    [cljs-time.core :refer [hours now plus]]

    [elevent-client.api :as api]
    [elevent-client.routes :as routes]
    [elevent-client.state :as state]
    [elevent-client.components.action-button :as action-button]
    [elevent-client.components.input :as input]
    [elevent-client.components.date-selector :as date-selector]))

(def validator
  (validation-set
    (presence-of :Name)
    (presence-of :Venue)
    (presence-of :StartDate)
    (presence-of :EndDate)
    (format-of :TicketPrice
               :format      #"^\d*\.\d\d$"
               :allow-nil   true
               :allow-blank true)
    (format-of :StartDate :format #"\d\d\d\d-\d\d-\d\dT\d\d:\d\d")
    (format-of :EndDate   :format #"\d\d\d\d-\d\d-\d\dT\d\d:\d\d")))

(defn page [& [event-id]]
  (let [form (atom {})
        clone-id (atom 0)]
    (when event-id
      (if-let [event (seq (d/entity @api/events-db event-id))]
        (reset! form (let [event (into {} event)]
                       (assoc event
                         :TicketPrice (str (:TicketPrice event)))))
        (add-watch api/events-db
                   :event-edit
                   (fn [_ _ _ db]
                     (reset! form (let [event (into {} (d/entity db event-id))]
                                    (assoc event
                                      :TicketPrice (str (:TicketPrice event)))))
                     (remove-watch api/events-db :event-edit)))))
    (add-watch clone-id :clone
               (fn [_ _ _ id]
                 (when-not (zero? (int id))
                   (let [clone-event (->> id
                                          int
                                          (d/entity @api/events-db)
                                          seq
                                          (into {}))]
                     (reset!
                       form
                       (dissoc
                         (assoc
                           clone-event
                           :TicketPrice
                           (if (> (:TicketPrice clone-event) 0)
                             (string/format "%.2f" (:TicketPrice clone-event))
                             ""))
                         :EventId))))))
    (fn []
      (let [{:keys [Name OrganizationId Venue StartDate EndDate
                    TicketPrice Description]}
            @form

            errors
            (validator @form)

            clonable-events
            (cons ["None" 0]
                  (doall
                    (filter (fn [[event-name event-id]]
                              (get-in @state/session
                                      [:permissions
                                       :EventPermissions
                                       event-id
                                       :EditEvent]))
                            (d/q '[:find ?name ?id
                                   :where [?id :Name ?name]]
                                 @api/events-db))))

            associated-organizations
            (cons ["None" 0]
                  (d/q '[:find ?name ?id
                         :where [?id :Name ?name]]
                       @api/organizations-db))

            create-event
            (fn [form]
              (fn [callback]
                (when (empty? errors)
                  (api/events-endpoint (if event-id :update :create)
                                       form
                                       #(do
                                          (callback)
                                          (js/location.replace
                                            (routes/events-explore)))))))]
        [:div.sixteen.wide.column
         [:div.ui.top.attached.tabular.menu
          [:a.item {:href (routes/events)}
           "Events"]
          [:a.item {:href (routes/events-explore)}
           "Explore"]
          [:a.item {:href (routes/events-owned)}
           "Owned"]
          [:a.item {:href (routes/event-add) :class (when-not event-id :active)}
           "Add"]]
         [:div.ui.bottom.attached.segment
          [:form.ui.form
           [:div.ui.vertical.segment
            [:h2.ui.dividing.header (if event-id "Edit" "Add") " an Event"]
            (let [name-field [:div.required.field
                              {:class (when (and Name (:Name errors)) :error)}
                              [:label "Name"]
                              [input/component
                               :text
                               {}
                               (r/wrap Name swap! form assoc :Name)]]]
              (if event-id
                name-field
                [:div.two.fields
                 name-field
                 [:div.field
                  [:label "Clone From"]
                  [input/component :select {} clonable-events clone-id]]]))
            [:div.two.fields
             [:div.required.field
              [:label "Organization"]
              [input/component :select {} associated-organizations
               (r/wrap OrganizationId swap! form assoc :OrganizationId)]]
             [:div.required.field {:class (when (and Venue (:Venue errors))
                                            :error)}
              [:div.required.field
               [:label "Venue"]
               [input/component :text {} (r/wrap Venue swap! form assoc :Venue)]]]]
            (let [start-date (r/wrap StartDate swap! form assoc :StartDate)
                  end-date   (r/wrap EndDate swap! form assoc :EndDate)]
              [:div.two.fields
               [:div.required.field {:class (when (and StartDate
                                                       (:StartDate errors))
                                              :error)}
                [:label "Start Date"]
                [date-selector/component
                 {:date-atom start-date
                  :pikaday-attrs (merge
                                   {:minDate (-> (now)
                                                 (plus (hours 6))
                                                 to-date)}
                                   (when @start-date
                                     {:defaultDate (-> (from-string @start-date)
                                                       (plus (hours 6))
                                                       to-date)
                                      :setDefaultDate true}))}]]
               [:div.required.field {:class (when (and EndDate
                                                       (:EndDate errors))
                                              :error)}
                [:label "End Date"]
                [date-selector/component
                 {:date-atom end-date
                  :min-date-atom start-date
                  :pikaday-attrs (merge
                                   {:minDate (-> (now)
                                                 (plus (hours 6))
                                                 to-date)}
                                   (when @end-date
                                     {:defaultDate (-> (from-string @end-date)
                                                       (plus (hours 6))
                                                       to-date)
                                      :setDefaultDate true}))}]]])
            [:div.field
             [:div.four.wide.field {:class (when (and TicketPrice
                                                      (:TicketPrice errors))
                                             :error)}
              [:label "Ticket Price"]
              [:div.ui.labeled.input
               [:div.ui.label "$"]
               [input/component :text {}
                (r/wrap TicketPrice swap! form assoc :TicketPrice)]]]]
            [:div.field
             [:label "Description"]
             [input/component :textarea {}
              (r/wrap Description swap! form assoc :Description)]]
            [action-button/component
             {:class (str "primary" (when (seq errors) " disabled"))}
             (if event-id "Edit" "Add")
             (create-event @form)]]]]]))))

(routes/register-page routes/event-edit-chan #'page)

Remove active Add tab and Clone From select


(ns evalback.core
  (:gen-class :implements [org.apache.commons.daemon.Daemon])
  (:require [liberator.core :refer [resource defresource]]
            [ring.middleware.params :refer [wrap-params]]
            [compojure.core :refer [defroutes ANY GET POST]]
            [hiccup.core :as h]
            [hiccup.page :as hp]
            [hiccup.element :as he]
            [clojure.data.json :as json]
            [clojure.core.async :as a :refer [alts!! chan <!! >!! timeout]])
  (:use ring.server.standalone
        [ring.middleware file-info file])
  (:import [org.apache.commons.daemon Daemon DaemonContext]
           de.prob.animator.command.CbcSolveCommand
           (de.prob.animator.domainobjects ClassicalB TLA EvalResult ComputationNotCompletedResult)
           de.prob.unicode.UnicodeTranslator
           de.tla2b.exceptions.TLA2BException
           de.prob.Main
           de.prob.scripting.Api
           (de.be4.classicalb.core.parser.node TIdentifierLiteral AImplicationPredicate)))

(def varname [(TIdentifierLiteral. "_lambda_result_")])

(def instances 2)
(def prob-timeout 3000)
(def request-timeout 6500)
(defonce server (atom nil))
(defonce worker (atom nil))

(defmulti process-result (fn [r _ _ _] (class r)))
(defmethod process-result EvalResult [res cbf introduced resp]
  (let [result (.getValue res)
        bindings (into {} (.getSolutions res))]
    (into resp {:status :ok
                :input cbf
                :introduced introduced
                :result result
                :bindings bindings})))

(defmethod process-result ComputationNotCompletedResult [res cbf _ resp]
  (let [reason (.getReason res)]
    (condp = reason
      "contradiction found" (into resp {:status :ok :result false :input cbf})
      (into resp {:status :error :result reason}))))

(defmulti instantiate (fn [f i] f))

(defmethod instantiate :b [_ input] (ClassicalB. input))
(defmethod instantiate :tla [_ input] (TLA. input))

(defn mk-formula [formalism input]
  (let [cbf (instantiate formalism input)
        pred? (= "#PREDICATE" (.getKind cbf))]
    (if pred?
      [cbf nil]
      (let [
            cbf (instantiate formalism (str  "lambda_result_ = " input))
            ast (.. cbf getAst getPParseUnit getPredicate getLeft (setIdentifier varname))]
        [cbf "_lambda_result_"]))))

(defn top-level-implication? [cbf]
  (let [ast (.getAst cbf)
        pu (.getPParseUnit ast)
        pred (.getPredicate pu)]
    (if (instance? AImplicationPredicate pred)
      "\nYou use an implication at the top level. This is most likely not what you meant. Remember that free variables are existentially quantified.\n\n"
      "")))

(defn run-eval  [ss {:keys [input formalism] :as resp}]
  (try (let [[cbf introduced] (mk-formula formalism input)
             c (CbcSolveCommand. cbf)]
         (.execute ss c)
         (process-result (.getValue c) cbf introduced resp))
       (catch Exception e
         (println e)
         (into resp {:status :error
                     :result (.getMessage e)}))))

(defn solve [request]
  (let [[solver _] (alts!! [@worker (timeout request-timeout)])]
    (if solver
      (let [result (solver request)]
        (>!! @worker solver)
        result)
      (into request {:status :error :result "The system is under heavy load. Please try again later."}))))

(defn unicode [s]
  (UnicodeTranslator/toUnicode s))

(defn html-result [formula {:keys [status result bindings]}]
  (h/html
   [:html
    [:head
     [:title "evalB"]
     (hp/include-css "/style.css")]
    [:body {:class (name status)}
     [:h1 "ProB 2.0 - evalB"]
     [:h2 "Input:"]
     [:p (unicode formula)]
     [:h2 "Result:"]
     [:p (if (= :ok status) (unicode result) result)]
     [:h2 "Solutions"]
     (he/unordered-list (map (fn [[k v]] (str k " = " (unicode v))) bindings))]]))

(defn edn-result [formula res]
  (assoc res :input formula))

(defn json-result [formula res]
  (json/write-str (assoc res :input formula)))

(defn valid-reply [result input introduced bindings]
  (if introduced
    (apply str (get bindings introduced "No solution computed.")
           (if (< 1 (count bindings)) "\n\nSolution: \n" "")
           (for [[k v] bindings] (if-not (= k introduced) (str "  " k "=" v "\n") "")))
    (apply str "Predicate is " (if result "satisfiable" "not satisfiable") ".\n"
           (top-level-implication? input)
           (if (seq bindings) "\nSolution: \n" "")
           (for [[k v] bindings] (str "  " k "=" v "\n")))))

(defn old-json [{:keys [status result input introduced  bindings]}]
  (json/write-str
   (if (= status :error)
     {:output (str "Error: " result)}
     {:output (valid-reply result input introduced bindings)})))

(defn get-api [] (.getInstance (Main/getInjector) Api))

(defroutes app
  (ANY "/version" [] (str (.getVersion (get-api))))

  (POST "/xxx" [formalism input]
        (let [r (solve {:formalism  (keyword formalism)
                        :input input })]
          (old-json r)))

  (ANY "/eval/:formalism/:formula" [formalism formula]
       (resource :available-media-types ["text/html" "application/clojure" "application/json"]
                 :handle-ok
                 (fn [context]
                   (let [r (solve {:formalism  (keyword formalism) :input formula})]
                     (condp =
                         (get-in context [:representation :media-type])
                       "text/html" (html-result formula r)
                       "application/clojure" (edn-result formula r)
                       "application/json" (json-result formula r)))))))

(def handler
  (-> app
      wrap-params))

(defn mk-worker [tn]
  (let [animator (.. (.b_load (get-api) tn) getStateSpace)]
    (fn [request]
      (assoc (let [result-future (future (run-eval animator request))
                   result (deref
                           result-future
                           prob-timeout
                           (into request {:status :error :result "Timeout"}))]
               (future-cancel result-future)
               result)
             :animator-id (.getId animator)))))

(defn create-empty-machine []
  (let [tf (java.io.File/createTempFile "evalb" ".mch" nil)
        tn (.getAbsolutePath tf)
        ]
    (.deleteOnExit tf)
    (spit tf "MACHINE empty \n END")
    tn))

(defn init []
  (reset! worker (chan instances))
  (let [tn (create-empty-machine)]
    (doseq [_ (range instances)]
      (>!! @worker (mk-worker tn)))
    )
  (println :init))

(defn destroy []
  (doseq [_ (range instances)] (<!! @worker))
  (reset! worker nil)
  (println :destroy))

(defn get-handler []
  ;; #'app expands to (var app) so that when we reload our code,
  ;; the server is forced to re-resolve the symbol in the var
  ;; rather than having its own copy. When the root binding
  ;; changes, the server picks it up without having to restart.
  (-> #'app
                                        ; Makes static assets in $PROJECT_DIR/resources/public/ available.
      (wrap-file "resources")
                                        ; Content-Type, Content-Length, and Last Modified headers for files in body
      (wrap-file-info)
      wrap-params))

(defn start-server
  "used for starting the server in development mode from REPL"
  [& [port]]
  (let [port (if port (Integer/parseInt port) 3000)]
    (reset! server
            (serve (get-handler)
                   {:port port
                    :init init
                    :open-browser? false
                    :stacktraces? false
                    :auto-reload? false
                    :destroy destroy
                    :join? true}))))

(defn stop-server []
  (.stop @server)
  (reset! server nil))

(defn -init [this ^DaemonContext context])

(defn -start [this]
  (future (start-server)))

(defn -stop [this]
  (stop-server))

(defn -main [& args]
  (start-server))

(ns evalback.core
  (:gen-class :implements [org.apache.commons.daemon.Daemon])
  (:require [liberator.core :refer [resource defresource]]
            [ring.middleware.params :refer [wrap-params]]
            [compojure.core :refer [defroutes ANY GET POST]]
            [hiccup.core :as h]
            [hiccup.page :as hp]
            [hiccup.element :as he]
            [clojure.data.json :as json]
            [clojure.core.async :as a :refer [alts!! chan <!! >!! timeout]])
  (:use ring.server.standalone
        [ring.middleware file-info file])
  (:import [org.apache.commons.daemon Daemon DaemonContext]
           de.prob.animator.command.CbcSolveCommand
           (de.prob.animator.domainobjects ClassicalB TLA EvalResult ComputationNotCompletedResult)
           de.prob.unicode.UnicodeTranslator
           de.tla2b.exceptions.TLA2BException
           de.prob.Main
           de.prob.scripting.Api
           (de.be4.classicalb.core.parser.node TIdentifierLiteral AImplicationPredicate)))

(def varname [(TIdentifierLiteral. "_lambda_result_")])

(def instances 2)
(def prob-timeout 3000)
(def request-timeout 6500)
(defonce server (atom nil))
(defonce worker (atom nil))

(defmulti process-result (fn [r _ _ _] (class r)))
(defmethod process-result EvalResult [res cbf introduced resp]
  (let [result (.getValue res)
        bindings (into {} (.getSolutions res))]
    (into resp {:status :ok
                :input cbf
                :introduced introduced
                :result result
                :bindings bindings})))

(defmethod process-result ComputationNotCompletedResult [res cbf _ resp]
  (let [reason (.getReason res)]
    (condp = reason
      "contradiction found" (into resp {:status :ok :result false :input cbf})
      (into resp {:status :error :result reason}))))

(defmulti instantiate (fn [f i] f))

(defmethod instantiate :b [_ input] (ClassicalB. input))
(defmethod instantiate :tla [_ input] (TLA. input))

(defn mk-formula [formalism input]
  (let [cbf (instantiate formalism input)
        pred? (= "#PREDICATE" (.getKind cbf))]
    (if pred?
      [cbf nil]
      (let [
            cbf (instantiate formalism (str  "lambda_result_ = " input))
            ast (.. cbf getAst getPParseUnit getPredicate getLeft (setIdentifier varname))]
        [cbf "_lambda_result_"]))))

(defn top-level-implication? [cbf]
  (let [ast (.getAst cbf)
        pu (.getPParseUnit ast)
        pred (.getPredicate pu)]
    (if (instance? AImplicationPredicate pred)
      "\nYou use an implication at the top level. This is most likely not what you meant. Remember that free variables are existentially quantified.\n\n"
      "")))

(defn run-eval  [ss {:keys [input formalism] :as resp}]
  (try (let [[cbf introduced] (mk-formula formalism input)
             c (CbcSolveCommand. cbf)]
         (.execute ss c)
         (process-result (.getValue c) cbf introduced resp))
       (catch Exception e
         (println e)
         (into resp {:status :error
                     :result (.getMessage e)}))))

(defn solve [request]
  (let [[solver _] (alts!! [@worker (timeout request-timeout)])]
    (if solver
      (let [result (solver request)]
        (>!! @worker solver)
        result)
      (into request {:status :error :result "The system is under heavy load. Please try again later."}))))

(defn unicode [s]
  (UnicodeTranslator/toUnicode s))

(defn html-result [formula {:keys [status result bindings]}]
  (h/html
   [:html
    [:head
     [:title "evalB"]
     (hp/include-css "/style.css")]
    [:body {:class (name status)}
     [:h1 "ProB 2.0 - evalB"]
     [:h2 "Input:"]
     [:p (unicode formula)]
     [:h2 "Result:"]
     [:p (if (= :ok status) (unicode result) result)]
     [:h2 "Solutions"]
     (he/unordered-list (map (fn [[k v]] (str k " = " (unicode v))) bindings))]]))

(defn edn-result [formula res]
  (assoc res :input formula))

(defn json-result [formula res]
  (json/write-str (assoc res :input formula)))

(defn valid-reply [result input introduced bindings]
  (if introduced
    (apply str (get bindings introduced "No solution computed.")
           (if (< 1 (count bindings)) "\n\nSolution: \n" "")
           (for [[k v] bindings] (if-not (= k introduced) (str "  " k "=" v "\n") "")))
    (apply str "Predicate is " (if result "satisfiable" "not satisfiable") ".\n"
           (top-level-implication? input)
           (if (seq bindings) "\nSolution: \n" "")
           (for [[k v] bindings] (str "  " k "=" v "\n")))))

(defn old-json [{:keys [status result input introduced  bindings]}]
  (json/write-str
   (if (= status :error)
     {:output (str "Error: " result)}
     {:output (valid-reply result input introduced bindings)})))

(defn get-api [] (.getInstance (Main/getInjector) Api))

(defroutes app
  (ANY "/version" [] (str (.getVersion (get-api))))

  (POST "/xxx" [formalism input]
        (let [r (solve {:formalism  (keyword formalism)
                        :input input })]
          (old-json r)))

  (ANY "/eval/:formalism/:formula" [formalism formula]
       (resource :available-media-types ["text/html" "application/clojure" "application/json"]
                 :handle-ok
                 (fn [context]
                   (let [r (solve {:formalism  (keyword formalism) :input formula})]
                     (condp =
                         (get-in context [:representation :media-type])
                       "text/html" (html-result formula r)
                       "application/clojure" (edn-result formula r)
                       "application/json" (json-result formula r)))))))

(def handler
  (-> app
      wrap-params))

(defn mk-worker [tn]
  (let [animator (.. (.b_load (get-api) tn) getStateSpace)]
    (fn [request]
      (assoc (let [result-future (future (run-eval animator request))
                   result (deref
                           result-future
                           prob-timeout
                           (into request {:status :error :result "Timeout"}))]
               (future-cancel result-future)
               result)
             :animator-id (.getId animator)))))

(defn create-empty-machine []
  (let [tf (java.io.File/createTempFile "evalb" ".mch" nil)
        tn (.getAbsolutePath tf)
        ]
    (.deleteOnExit tf)
    (spit tf "MACHINE empty \n END")
    tn))

(defn init []
  (reset! worker (chan instances))
  (let [tn (create-empty-machine)]
    (doseq [_ (range instances)]
      (>!! @worker (mk-worker tn)))
    )
  (println :init))

(defn destroy []
  (doseq [_ (range instances)] (<!! @worker))
  (reset! worker nil)
  (println :destroy))

(defn get-handler []
  ;; #'app expands to (var app) so that when we reload our code,
  ;; the server is forced to re-resolve the symbol in the var
  ;; rather than having its own copy. When the root binding
  ;; changes, the server picks it up without having to restart.
  (-> #'app
                                        ; Makes static assets in $PROJECT_DIR/resources/public/ available.
      (wrap-file "resources")
                                        ; Content-Type, Content-Length, and Last Modified headers for files in body
      (wrap-file-info)
      wrap-params))

(def port (let [p (System/getProperty "port")]
            (if p (Integer/parseInt p) 9000)))

(defn start-server
  "used for starting the server in development mode from REPL"
  []
  (reset! server
          (serve (get-handler)
                 {:port port
                  :init init
                  :open-browser? false
                  :stacktraces? false
                  :auto-reload? false
                  :destroy destroy
                  :join? true})))

(defn stop-server []
  (.stop @server)
  (reset! server nil))

(defn -init [this ^DaemonContext context])

(defn -start [this]
  (future (start-server)))

(defn -stop [this]
  (stop-server))

(defn -main [& args]
  (start-server))

use -Dport to configure the port number

use -Dport to configure the port number