;; Copyright © 2014-2017, JUXT LTD.

(ns yada.security
  (:require
   [clojure.data.codec.base64 :as base64]
   [clojure.string :as str]
   [clojure.tools.logging :refer :all]
   [yada.authorization :as authorization]
   [yada.syntax :as syn]
   [clojure.tools.logging :as log]
   [manifold.deferred :as d])
  (:import
   (yada.context Context)))

;; Deprecated
(defmulti verify
  "Multimethod that allows new schemes to be added."
  (fn [ctx {:keys [scheme]}] scheme) :default ::default)

;; Deprecated
(defmethod verify "Basic" [ctx {:keys [verify]}]

  (let [auth (get-in ctx [:request :headers "authorization"])
        cred (and auth (apply str (map char (base64/decode (.getBytes ^String (last (re-find #"^Basic (.*)$" auth)))))))]
    (when cred
      (let [[user password] (str/split (str cred) #":" 2)]
        (verify [user password])))))

;; Deprecated
;; A nil scheme is simply one that does not use any of the built-in
;; algorithms for IANA registered auth-schemes at
;; http://www.iana.org/assignments/http-authschemes. The verify
;; entry must therefore take the full context and do all the work to
;; verify the user from it.
(defmethod verify nil
  [ctx {:keys [verify]}]
  (when verify
    (verify ctx)))

;; Deprecated
(defmethod verify ::default
  [ctx {:keys [scheme]}]
  ;; Scheme is not recognised by this server, we must return nil (to
  ;; move to the next scheme). This is technically a server issue but
  ;; we recover and add a warning in the logs.
  (warnf "No installed support for the following scheme: %s" scheme)
  nil)

(defmulti issue-challenge
  "Multimethod that allows new schemes to be added."
  (fn [ctx {:keys [scheme]}] scheme) :default ::default)

(defmethod issue-challenge ::default
  [ctx {:keys [scheme]}]
  nil)

(defn issue-challenge-with-custom [ctx auth-scheme]
  (if-let [f (:challenge auth-scheme)]
    (f ctx)
    (issue-challenge ctx auth-scheme)))

(defmulti preprocess-authorization-header
  "Pre-process the parsed authorization value according to the
  auth-scheme's semantics. Return nil if anything wrong with the
  (claimed) credentials."
  (fn [ctx {:keys [scheme] :as auth-scheme} credentials] scheme) :default ::default)

(defmethod preprocess-authorization-header ::default
  [ctx {:keys [scheme] :as auth-scheme} credentials]
  ;; Return the identity of credentials
  credentials)

(defn cors-preflight?
  "Is the method OPTIONS and does the resource accept requests from
  other origins? This is important because we can't block pre-flight
  requests– the CORS spec. doesn't allow us to."
  [ctx]
  (and (= (:method ctx) :options)
       (some-> ctx :resource :access-control :allow-origin)))

(defmacro when-not-cors-preflight [ctx & body]
  `(if (cors-preflight? ~ctx)
     ~ctx
     ~@body))

(defn call-fn-maybe [x ctx]
  (when x
    (if (fn? x) (x ctx) x)))

(defn add-challenges [ctx]
  (let [auth-schemes (get-in ctx [:resource :authentication-schemes])
        challenges (keep
                    (fn [auth-scheme]
                      (issue-challenge-with-custom ctx auth-scheme))
                    auth-schemes)]
    (cond-> ctx
      (not-empty challenges)
      (update-in [:response :headers "www-authenticate"]
                 (fnil conj [])
                 (syn/format-challenges challenges)))))

(defprotocol AuthenticateResult
  (interpret-authenticate-result [result ctx auth-scheme]
    "Process the result to a call to an authenticate function. This
    assists in allowing some authenticate functions to return a
    context, where necessary, while allowing others to return
    nil (indicating authentication failure) "))

(defn assoc-authentication
  "Associate the given credentials with the request context. Custom
  authenticator functions that wish to return the ctx explicitly,
  should call this function to associate credentials that they have
  established."
  [ctx creds]
  (assoc ctx :authentication creds))

(defn assoc-auth-scheme
  "When an authentication has established credentials, it is useful that
  the authentication scheme places itself into the request context,
  along with any parameters, for other interceptors to see."
  [ctx auth-scheme]
  (assoc ctx :authentication-scheme auth-scheme))

(extend-protocol AuthenticateResult
  nil
  (interpret-authenticate-result [_ ctx auth-scheme]
    ;; Return the original context
    ctx)

  Context
  (interpret-authenticate-result [new-ctx ctx auth-scheme]
    ;; The dev knows that they're doing, respect that. Assume
    ;; credentials have already been associated with the request
    ;; context.
    (-> new-ctx
        (assoc-auth-scheme auth-scheme)))

  ;; TODO: Allow for an authenticate function to provide partial
  ;; credentials and a new challenge, as per RFC 7235 section 2.1.

  Object
  (interpret-authenticate-result [creds ctx auth-scheme]
    (-> ctx
        (assoc-auth-scheme auth-scheme)
        (assoc-authentication creds))))

(defn authenticate [ctx]
  (when-not-cors-preflight ctx
    (let [auth-schemes (call-fn-maybe (get-in ctx [:resource :authentication-schemes]) ctx)
          realms (get-in ctx [:resource :access-control :realms])]

      (cond
        auth-schemes

        ;; If there's an authorization header, find the first scheme
        ;; that matches.

        ;; From RFC 7235 section 2.1:
        ;;
        ;; > "Upon receipt of a request for a protected resource that
        ;; > omits credentials, contains invalid credentials (e.g., a
        ;; > bad password) or partial credentials (e.g., when the
        ;; > authentication scheme requires more than one round trip),
        ;; > an origin server SHOULD send a 401 (Unauthorized)
        ;; > response that contains a WWW-Authenticate header field
        ;; > with at least one (possibly new) challenge applicable to
        ;; > the requested resource."

        ;; The above indicates that the authenticate function MAY
        ;; return a new challenge.

        (if-let [authorization (get-in ctx [:request :headers "authorization"])]

          ;; Find the authentication-scheme for which this authorization refers, if any
          (let [claimed-credentials (syn/parse-credentials authorization)]

            (if-let [auth-scheme
                     (if
                         ;; This is unexpected but we should handle it anyway
                         (not= (::syn/type claimed-credentials) ::syn/credentials)
                         (do
                           ;; Log this and return nil
                           (log/infof "Bad authorization header value received: %s" authorization)
                           nil)

                         (some
                          (fn [candidate]
                            (when (= (::syn/auth-scheme claimed-credentials) (str/lower-case (:scheme candidate)))
                              candidate))
                          auth-schemes))]

              ;; Auth-scheme found. First, we allow the scheme to pre-process the credentials
              (let [claimed-credentials (preprocess-authorization-header ctx auth-scheme claimed-credentials)
                    ;; We call the authenticate function with 3 args:
                    ;; ctx, credentials (pre-processed) and the
                    ;; auth-scheme data (to provide access to any
                    ;; extra parameters)
                    res ((:authenticate auth-scheme) ctx claimed-credentials auth-scheme)]

                ;; Allow authenticate functions to return deferred
                ;; values
                (d/chain
                 res
                 (fn [res]
                   (let [ctx (interpret-authenticate-result res ctx auth-scheme)]
                     (cond-> ctx
                       ;; If there are no credentials as a result
                       ;; then add the challenges
                       (nil? (:authentication ctx)) add-challenges)))))

              ;; No auth-scheme found.
              (do
                (log/infof "Authorization credentials do not match any of the authentication-scheme challenges")
                (add-challenges ctx))))

          (add-challenges ctx)
          ;; No authorization attempted. Nothing to do here except set www-authenticate headers (challenges)
          ;; For all schemes, ask the scheme to create a 'challenge'
          )

        ;; Deprecated but included for backwards compatibility
        realms
        ;; Note that a response can have multiple challenges, one for each realm.
        (reduce
         (fn [ctx [realm {:keys [authentication-schemes]}]]
           ;; Currently we take the credentials of the first scheme that
           ;; returns them.  We also encourage scheme provides to return
           ;; truthy (e.g. {}) if the credentials have been specified (the
           ;; correct request header or cookie has been used) but are
           ;; invalid. This is to distinguish between (i) authentication
           ;; credentials being supplied and valid, (ii) supplied and
           ;; invalid, (iii) not supplied.
           ;;
           ;; The upshot of this is that invalid basic auth creds are
           ;; accepted (on the first attempt), so if the user makes a
           ;; mistake typing them in, no re-attempts are allowed. It is
           ;; hard for yada to provide re-attempts to a human, because it
           ;; is designed to support other types of user-agent, where
           ;; re-attempt counting would not be desirable.
           ;;
           ;; The compromise is that basic auth has a single attempt and
           ;; we must find some better way of allowing humans to 'log out'
           ;; of basic auth via browser JS. If re-attempts are desirable,
           ;; then it is recommended to use a more sophisticated auth
           ;; scheme rather than Basic, which is really only for quick
           ;; prototypes and examples. I think this is a valid overall
           ;; compromise between the various trade-offs here.

           ;; In the future we may have a better design that can support
           ;; conjunctions and disjunctions across auth-schemes, in much
           ;; the same way we do for the built-in role-based
           ;; authorization.
           (let [authentication-schemes (call-fn-maybe authentication-schemes ctx)
                 credentials (some (partial verify ctx) authentication-schemes)]

             (if credentials
               (assoc-in ctx [:authentication realm] credentials)
               (let [vs (filter some?
                                (for [{:keys [scheme]} authentication-schemes]
                                  (when (string? scheme)
                                    (format "%s realm=\"%s\"" scheme realm))))]
                 (if (not-empty vs)
                   (update-in ctx [:response :headers "www-authenticate"]
                              (fnil conj [])
                              (str/join ", " vs))
                   ctx)))))

         ctx realms)
        :else ctx))))

(defprotocol AuthorizationResult
  (interpret-authorize-result [result ctx]
    "Process the result to a call to an authorize function. This
    assists in allowing some authorize functions to return a
    context, where necessary, while allowing others to return
    nil (indicating authorization failure)"))

(extend-protocol AuthorizationResult
  nil
  (interpret-authorize-result [_ ctx]
    ;; Return the original context, with no authorization added
    ctx)

  Context
  (interpret-authorize-result [new-ctx ctx]
    ;; The dev knows that they're doing, respect that. Assume
    ;; authorization has already been associated with the request
    ;; context.
    new-ctx)

  Object
  (interpret-authorize-result [authorization ctx]
    (assoc ctx :authorization authorization)))

(defn default-authorize
  "The default authorize succeeds if there are no authentication schemes
  declared, or if there are any credentials established. This is
  considered the path of least surprise. Protected resources are
  protected in the absence of credentials rather than requiring an
  explicit :authorize function."
  [ctx creds _]
  (if (get-in ctx [:resource :authentication-schemes])
    creds
    true))

(defn authorize
  "Given a verified user in the context, and the resource properties
  in :properties, check that the user is authorized to do what they
  are about to do. At this point the user is already verified and
  roles determined, if it is possible to do so (RBAC), and the
  resource's properties (attributes) have been loaded to make ABAC
  schemes also possible."
  [ctx]
  (when-not-cors-preflight ctx

    (let [authorization (call-fn-maybe (get-in ctx [:resource :authorization]) ctx)
          realms (get-in ctx [:resource :access-control :realms])]

      (cond
        (not realms)
        ;; New branch
        (let [f (or (:authorize authorization) default-authorize)]
          (d/chain
           (f ctx (:authentication ctx) authorization)
           (fn [res]
             (interpret-authorize-result res ctx))
           (fn [ctx]
             (if (:authorization ctx)
               ctx
               (if (:authentication ctx)
                 (throw
                  (ex-info "Forbidden"
                           {:status 403 ; or 404 to keep the resource hidden
                            ;; But allow www-authenticate header in error
                            :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])}))
                 (throw
                  (ex-info "No authorization provided"
                           {:status 401 ; or 404 to keep the resource hidden
                            ;; But allow www-authenticate header in error
                            :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])})))))))

        ;; This is the 'old' branch that is now deprecated and
        ;; sticking around to provide backwards compatibility.
        realms
        (reduce
         (fn [ctx [realm realm-val]]
           (if-let [authorization (:authorization realm-val)]
             (let [credentials (get-in ctx [:authentication realm])]
               (let [validation
                     (authorization/validate ctx credentials authorization)]
                 (if (or (nil? validation) (false? validation))
                   (if credentials
                     (throw
                      (ex-info "Forbidden"
                               {:status 403 ; or 404 to keep the resource hidden
                                ;; But allow WWW-Authenticate header in error
                                :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])}))
                     (throw
                      (ex-info "No authorization provided"
                               {:status 401 ; or 404 to keep the resource hidden
                                ;; But allow WWW-Authenticate header in error
                                :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])})))
                   validation)))
             ctx))
         ctx (get-in ctx [:resource :access-control :realms]))

        :else
        ctx))))

(defn to-header [v]
  (if (coll? v)
    (apply str (interpose ", " v))
    (str v)))

(defn access-control-headers [ctx]
  (if-let [origin (get-in ctx [:request :headers "origin"])]
    (let [access-control (get-in ctx [:resource :access-control])
          ;; We can only report one origin, so let's work that out
          allow-origin (let [s (call-fn-maybe (:allow-origin access-control) ctx)]
                         (cond
                           (= s "*") "*"
                           (string? s) s
                           ;; Allow function to return a set
                           (ifn? s) (or (s origin)
                                        (s "*"))))]

      (cond-> ctx
        allow-origin
        (assoc-in [:response :headers "access-control-allow-origin"] allow-origin)

        (contains? access-control :allow-credentials)
        (assoc-in [:response :headers "access-control-allow-credentials"]
                  (to-header (:allow-credentials access-control)))

        (:expose-headers access-control)
        (assoc-in [:response :headers "access-control-expose-headers"]
                  (to-header (call-fn-maybe (:expose-headers access-control) ctx)))

        (:max-age access-control)
        (assoc-in [:response :headers "access-control-max-age"]
                  (to-header (call-fn-maybe (:max-age access-control) ctx)))

        (:allow-methods access-control)
        (assoc-in [:response :headers "access-control-allow-methods"]
                  (to-header (map (comp str/upper-case name) (call-fn-maybe (:allow-methods access-control) ctx))))

        (:allow-headers access-control)
        (assoc-in [:response :headers "access-control-allow-headers"]
                  (to-header (call-fn-maybe (:allow-headers access-control) ctx)))))

    ;; Otherwise
    ctx))

(defn security-headers [ctx]
  (let [scheme (-> ctx :request :scheme)
        https? (= scheme :https)]

    (cond-> ctx
      https? (assoc-in [:response :headers "strict-transport-security"]
                       (format
                         "max-age=%s; includeSubdomains"
                         (get-in ctx [:strict-transport-security :max-age] 31536000)))
      (or https? (contains? (:resource ctx) :content-security-policy))
      (assoc-in [:response :headers "content-security-policy"]
                (get-in ctx [:resource :content-security-policy]
                        "default-src https: data: 'unsafe-inline' 'unsafe-eval'"))
      true (assoc-in [:response :headers "x-frame-options"]
                     (get-in ctx [:resource :x-frame-options] "SAMEORIGIN"))
      true (assoc-in [:response :headers "x-xss-protection"]
                     (get-in ctx [:resource :xss-protection] "1; mode=block"))
      true (assoc-in [:response :headers "x-content-type-options"]
                     "nosniff"))))

;; Copyright © 2014-2017, JUXT LTD.

(ns yada.security
  (:require
   [clojure.data.codec.base64 :as base64]
   [clojure.string :as str]
   [clojure.tools.logging :refer :all]
   [yada.authorization :as authorization]
   [yada.syntax :as syn]
   yada.context
   [clojure.tools.logging :as log]
   [manifold.deferred :as d])
  (:import
   (yada.context Context)))

;; Deprecated
(defmulti verify
  "Multimethod that allows new schemes to be added."
  (fn [ctx {:keys [scheme]}] scheme) :default ::default)

;; Deprecated
(defmethod verify "Basic" [ctx {:keys [verify]}]

  (let [auth (get-in ctx [:request :headers "authorization"])
        cred (and auth (apply str (map char (base64/decode (.getBytes ^String (last (re-find #"^Basic (.*)$" auth)))))))]
    (when cred
      (let [[user password] (str/split (str cred) #":" 2)]
        (verify [user password])))))

;; Deprecated
;; A nil scheme is simply one that does not use any of the built-in
;; algorithms for IANA registered auth-schemes at
;; http://www.iana.org/assignments/http-authschemes. The verify
;; entry must therefore take the full context and do all the work to
;; verify the user from it.
(defmethod verify nil
  [ctx {:keys [verify]}]
  (when verify
    (verify ctx)))

;; Deprecated
(defmethod verify ::default
  [ctx {:keys [scheme]}]
  ;; Scheme is not recognised by this server, we must return nil (to
  ;; move to the next scheme). This is technically a server issue but
  ;; we recover and add a warning in the logs.
  (warnf "No installed support for the following scheme: %s" scheme)
  nil)

(defmulti issue-challenge
  "Multimethod that allows new schemes to be added."
  (fn [ctx {:keys [scheme]}] scheme) :default ::default)

(defmethod issue-challenge ::default
  [ctx {:keys [scheme]}]
  nil)

(defn issue-challenge-with-custom [ctx auth-scheme]
  (if-let [f (:challenge auth-scheme)]
    (f ctx)
    (issue-challenge ctx auth-scheme)))

(defmulti preprocess-authorization-header
  "Pre-process the parsed authorization value according to the
  auth-scheme's semantics. Return nil if anything wrong with the
  (claimed) credentials."
  (fn [ctx {:keys [scheme] :as auth-scheme} credentials] scheme) :default ::default)

(defmethod preprocess-authorization-header ::default
  [ctx {:keys [scheme] :as auth-scheme} credentials]
  ;; Return the identity of credentials
  credentials)

(defn cors-preflight?
  "Is the method OPTIONS and does the resource accept requests from
  other origins? This is important because we can't block pre-flight
  requests– the CORS spec. doesn't allow us to."
  [ctx]
  (and (= (:method ctx) :options)
       (some-> ctx :resource :access-control :allow-origin)))

(defmacro when-not-cors-preflight [ctx & body]
  `(if (cors-preflight? ~ctx)
     ~ctx
     ~@body))

(defn call-fn-maybe [x ctx]
  (when x
    (if (fn? x) (x ctx) x)))

(defn add-challenges [ctx]
  (let [auth-schemes (get-in ctx [:resource :authentication-schemes])
        challenges (keep
                    (fn [auth-scheme]
                      (issue-challenge-with-custom ctx auth-scheme))
                    auth-schemes)]
    (cond-> ctx
      (not-empty challenges)
      (update-in [:response :headers "www-authenticate"]
                 (fnil conj [])
                 (syn/format-challenges challenges)))))

(defprotocol AuthenticateResult
  (interpret-authenticate-result [result ctx auth-scheme]
    "Process the result to a call to an authenticate function. This
    assists in allowing some authenticate functions to return a
    context, where necessary, while allowing others to return
    nil (indicating authentication failure) "))

(defn assoc-authentication
  "Associate the given credentials with the request context. Custom
  authenticator functions that wish to return the ctx explicitly,
  should call this function to associate credentials that they have
  established."
  [ctx creds]
  (assoc ctx :authentication creds))

(defn assoc-auth-scheme
  "When an authentication has established credentials, it is useful that
  the authentication scheme places itself into the request context,
  along with any parameters, for other interceptors to see."
  [ctx auth-scheme]
  (assoc ctx :authentication-scheme auth-scheme))

(extend-protocol AuthenticateResult
  nil
  (interpret-authenticate-result [_ ctx auth-scheme]
    ;; Return the original context
    ctx)

  Context
  (interpret-authenticate-result [new-ctx ctx auth-scheme]
    ;; The dev knows that they're doing, respect that. Assume
    ;; credentials have already been associated with the request
    ;; context.
    (-> new-ctx
        (assoc-auth-scheme auth-scheme)))

  ;; TODO: Allow for an authenticate function to provide partial
  ;; credentials and a new challenge, as per RFC 7235 section 2.1.

  Object
  (interpret-authenticate-result [creds ctx auth-scheme]
    (-> ctx
        (assoc-auth-scheme auth-scheme)
        (assoc-authentication creds))))

(defn authenticate [ctx]
  (when-not-cors-preflight ctx
    (let [auth-schemes (call-fn-maybe (get-in ctx [:resource :authentication-schemes]) ctx)
          realms (get-in ctx [:resource :access-control :realms])]

      (cond
        auth-schemes

        ;; If there's an authorization header, find the first scheme
        ;; that matches.

        ;; From RFC 7235 section 2.1:
        ;;
        ;; > "Upon receipt of a request for a protected resource that
        ;; > omits credentials, contains invalid credentials (e.g., a
        ;; > bad password) or partial credentials (e.g., when the
        ;; > authentication scheme requires more than one round trip),
        ;; > an origin server SHOULD send a 401 (Unauthorized)
        ;; > response that contains a WWW-Authenticate header field
        ;; > with at least one (possibly new) challenge applicable to
        ;; > the requested resource."

        ;; The above indicates that the authenticate function MAY
        ;; return a new challenge.

        (if-let [authorization (get-in ctx [:request :headers "authorization"])]

          ;; Find the authentication-scheme for which this authorization refers, if any
          (let [claimed-credentials (syn/parse-credentials authorization)]

            (if-let [auth-scheme
                     (if
                         ;; This is unexpected but we should handle it anyway
                         (not= (::syn/type claimed-credentials) ::syn/credentials)
                         (do
                           ;; Log this and return nil
                           (log/infof "Bad authorization header value received: %s" authorization)
                           nil)

                         (some
                          (fn [candidate]
                            (when (= (::syn/auth-scheme claimed-credentials) (str/lower-case (:scheme candidate)))
                              candidate))
                          auth-schemes))]

              ;; Auth-scheme found. First, we allow the scheme to pre-process the credentials
              (let [claimed-credentials (preprocess-authorization-header ctx auth-scheme claimed-credentials)
                    ;; We call the authenticate function with 3 args:
                    ;; ctx, credentials (pre-processed) and the
                    ;; auth-scheme data (to provide access to any
                    ;; extra parameters)
                    res ((:authenticate auth-scheme) ctx claimed-credentials auth-scheme)]

                ;; Allow authenticate functions to return deferred
                ;; values
                (d/chain
                 res
                 (fn [res]
                   (let [ctx (interpret-authenticate-result res ctx auth-scheme)]
                     (cond-> ctx
                       ;; If there are no credentials as a result
                       ;; then add the challenges
                       (nil? (:authentication ctx)) add-challenges)))))

              ;; No auth-scheme found.
              (do
                (log/infof "Authorization credentials do not match any of the authentication-scheme challenges")
                (add-challenges ctx))))

          (add-challenges ctx)
          ;; No authorization attempted. Nothing to do here except set www-authenticate headers (challenges)
          ;; For all schemes, ask the scheme to create a 'challenge'
          )

        ;; Deprecated but included for backwards compatibility
        realms
        ;; Note that a response can have multiple challenges, one for each realm.
        (reduce
         (fn [ctx [realm {:keys [authentication-schemes]}]]
           ;; Currently we take the credentials of the first scheme that
           ;; returns them.  We also encourage scheme provides to return
           ;; truthy (e.g. {}) if the credentials have been specified (the
           ;; correct request header or cookie has been used) but are
           ;; invalid. This is to distinguish between (i) authentication
           ;; credentials being supplied and valid, (ii) supplied and
           ;; invalid, (iii) not supplied.
           ;;
           ;; The upshot of this is that invalid basic auth creds are
           ;; accepted (on the first attempt), so if the user makes a
           ;; mistake typing them in, no re-attempts are allowed. It is
           ;; hard for yada to provide re-attempts to a human, because it
           ;; is designed to support other types of user-agent, where
           ;; re-attempt counting would not be desirable.
           ;;
           ;; The compromise is that basic auth has a single attempt and
           ;; we must find some better way of allowing humans to 'log out'
           ;; of basic auth via browser JS. If re-attempts are desirable,
           ;; then it is recommended to use a more sophisticated auth
           ;; scheme rather than Basic, which is really only for quick
           ;; prototypes and examples. I think this is a valid overall
           ;; compromise between the various trade-offs here.

           ;; In the future we may have a better design that can support
           ;; conjunctions and disjunctions across auth-schemes, in much
           ;; the same way we do for the built-in role-based
           ;; authorization.
           (let [authentication-schemes (call-fn-maybe authentication-schemes ctx)
                 credentials (some (partial verify ctx) authentication-schemes)]

             (if credentials
               (assoc-in ctx [:authentication realm] credentials)
               (let [vs (filter some?
                                (for [{:keys [scheme]} authentication-schemes]
                                  (when (string? scheme)
                                    (format "%s realm=\"%s\"" scheme realm))))]
                 (if (not-empty vs)
                   (update-in ctx [:response :headers "www-authenticate"]
                              (fnil conj [])
                              (str/join ", " vs))
                   ctx)))))

         ctx realms)
        :else ctx))))

(defprotocol AuthorizationResult
  (interpret-authorize-result [result ctx]
    "Process the result to a call to an authorize function. This
    assists in allowing some authorize functions to return a
    context, where necessary, while allowing others to return
    nil (indicating authorization failure)"))

(extend-protocol AuthorizationResult
  nil
  (interpret-authorize-result [_ ctx]
    ;; Return the original context, with no authorization added
    ctx)

  Context
  (interpret-authorize-result [new-ctx ctx]
    ;; The dev knows that they're doing, respect that. Assume
    ;; authorization has already been associated with the request
    ;; context.
    new-ctx)

  Object
  (interpret-authorize-result [authorization ctx]
    (assoc ctx :authorization authorization)))

(defn default-authorize
  "The default authorize succeeds if there are no authentication schemes
  declared, or if there are any credentials established. This is
  considered the path of least surprise. Protected resources are
  protected in the absence of credentials rather than requiring an
  explicit :authorize function."
  [ctx creds _]
  (if (get-in ctx [:resource :authentication-schemes])
    creds
    true))

(defn authorize
  "Given a verified user in the context, and the resource properties
  in :properties, check that the user is authorized to do what they
  are about to do. At this point the user is already verified and
  roles determined, if it is possible to do so (RBAC), and the
  resource's properties (attributes) have been loaded to make ABAC
  schemes also possible."
  [ctx]
  (when-not-cors-preflight ctx

    (let [authorization (call-fn-maybe (get-in ctx [:resource :authorization]) ctx)
          realms (get-in ctx [:resource :access-control :realms])]

      (cond
        (not realms)
        ;; New branch
        (let [f (or (:authorize authorization) default-authorize)]
          (d/chain
           (f ctx (:authentication ctx) authorization)
           (fn [res]
             (interpret-authorize-result res ctx))
           (fn [ctx]
             (if (:authorization ctx)
               ctx
               (if (:authentication ctx)
                 (throw
                  (ex-info "Forbidden"
                           {:status 403 ; or 404 to keep the resource hidden
                            ;; But allow www-authenticate header in error
                            :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])}))
                 (throw
                  (ex-info "No authorization provided"
                           {:status 401 ; or 404 to keep the resource hidden
                            ;; But allow www-authenticate header in error
                            :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])})))))))

        ;; This is the 'old' branch that is now deprecated and
        ;; sticking around to provide backwards compatibility.
        realms
        (reduce
         (fn [ctx [realm realm-val]]
           (if-let [authorization (:authorization realm-val)]
             (let [credentials (get-in ctx [:authentication realm])]
               (let [validation
                     (authorization/validate ctx credentials authorization)]
                 (if (or (nil? validation) (false? validation))
                   (if credentials
                     (throw
                      (ex-info "Forbidden"
                               {:status 403 ; or 404 to keep the resource hidden
                                ;; But allow WWW-Authenticate header in error
                                :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])}))
                     (throw
                      (ex-info "No authorization provided"
                               {:status 401 ; or 404 to keep the resource hidden
                                ;; But allow WWW-Authenticate header in error
                                :headers (select-keys (-> ctx :response :headers) ["www-authenticate"])})))
                   validation)))
             ctx))
         ctx (get-in ctx [:resource :access-control :realms]))

        :else
        ctx))))

(defn to-header [v]
  (if (coll? v)
    (apply str (interpose ", " v))
    (str v)))

(defn access-control-headers [ctx]
  (if-let [origin (get-in ctx [:request :headers "origin"])]
    (let [access-control (get-in ctx [:resource :access-control])
          ;; We can only report one origin, so let's work that out
          allow-origin (let [s (call-fn-maybe (:allow-origin access-control) ctx)]
                         (cond
                           (= s "*") "*"
                           (string? s) s
                           ;; Allow function to return a set
                           (ifn? s) (or (s origin)
                                        (s "*"))))]

      (cond-> ctx
        allow-origin
        (assoc-in [:response :headers "access-control-allow-origin"] allow-origin)

        (contains? access-control :allow-credentials)
        (assoc-in [:response :headers "access-control-allow-credentials"]
                  (to-header (:allow-credentials access-control)))

        (:expose-headers access-control)
        (assoc-in [:response :headers "access-control-expose-headers"]
                  (to-header (call-fn-maybe (:expose-headers access-control) ctx)))

        (:max-age access-control)
        (assoc-in [:response :headers "access-control-max-age"]
                  (to-header (call-fn-maybe (:max-age access-control) ctx)))

        (:allow-methods access-control)
        (assoc-in [:response :headers "access-control-allow-methods"]
                  (to-header (map (comp str/upper-case name) (call-fn-maybe (:allow-methods access-control) ctx))))

        (:allow-headers access-control)
        (assoc-in [:response :headers "access-control-allow-headers"]
                  (to-header (call-fn-maybe (:allow-headers access-control) ctx)))))

    ;; Otherwise
    ctx))

(defn security-headers [ctx]
  (let [scheme (-> ctx :request :scheme)
        https? (= scheme :https)]

    (cond-> ctx
      https? (assoc-in [:response :headers "strict-transport-security"]
                       (format
                         "max-age=%s; includeSubdomains"
                         (get-in ctx [:strict-transport-security :max-age] 31536000)))
      (or https? (contains? (:resource ctx) :content-security-policy))
      (assoc-in [:response :headers "content-security-policy"]
                (get-in ctx [:resource :content-security-policy]
                        "default-src https: data: 'unsafe-inline' 'unsafe-eval'"))
      true (assoc-in [:response :headers "x-frame-options"]
                     (get-in ctx [:resource :x-frame-options] "SAMEORIGIN"))
      true (assoc-in [:response :headers "x-xss-protection"]
                     (get-in ctx [:resource :xss-protection] "1; mode=block"))
      true (assoc-in [:response :headers "x-content-type-options"]
                     "nosniff"))))

Fix use of yada.context without require (#269)

Exception without this patch:

❯ lein run -m clojure.main -e "(require 'yada.security)"
Exception in thread "main" java.lang.ClassNotFoundException: yada.context.Context, compiling:(yada/security.clj:1:1)


(ns hello-world)

(defn hello [] ;; <- arglist goes here
  ;; your code goes here
)

(ns hello-world)

(defn hello []
  "Goodbye, Mars!")

Simplify the `hello-world` exercise's stub. The goal of this is to make things easier for students to get started and to introduce as little syntax as possible.


(ns cfpb.qu.handler-test
  (:require [midje.sweet :refer :all]
            [ring.mock.request :refer :all]
            [cfpb.qu.handler :refer [app]]))

(fact "the index URL redirects to /data"
      (app (request :get "/"))
      => (contains {:status 302
                    :headers {"Location" "/data"}}))

(facts "about /data"
       (prerequisite (#'cfpb.qu.data/get-datasets) => [])

       (fact "it returns successfully"
             (app (request :get "/data"))
             => (contains {:status 200
                           :headers {"Content-Type" "text/html;charset=UTF-8"}})

             (app (request :get "/data.xml"))
             => (contains {:status 200
                           :headers {"Content-Type" "application/xml;charset=UTF-8"}})))

(facts "about /data/dataset"
       (fact "it returns successfully when the dataset exists"
             (prerequisite (#'cfpb.qu.data/get-metadata "good-dataset") => {})

             (app (request :get "/data/good-dataset"))
             => (contains {:status 200
                           :headers {"Content-Type" "text/html;charset=UTF-8"}})

             (app (request :get "/data/good-dataset.xml"))
             => (contains {:status 200
                           :headers {"Content-Type" "application/xml;charset=UTF-8"}}))

       (fact "it returns a 404 when the dataset does not exist"
             (prerequisite (#'cfpb.qu.data/get-metadata "bad-dataset") => nil)

             (app (request :get "/data/bad-dataset"))
             => (contains {:status 404})))

(facts "about /data/dataset/slice"
       (fact "it returns successfully when the dataset and slice exist"
             (prerequisite (#'cfpb.qu.data/get-metadata "good-dataset") => {:slices {:whoa {}}}
                           (#'cfpb.qu.query/execute "good-dataset" anything anything)
                           => {:total 0 :size 0 :data []})

             (app (request :get "/data/good-dataset/whoa"))
             => (contains {:status 200
                           :headers {"Content-Type" "text/html;charset=UTF-8"}})

             (app (request :get "/data/good-dataset/whoa.xml"))
             => (contains {:status 200
                           :headers {"Content-Type" "application/xml;charset=UTF-8"}}))

       (fact "it returns a 404 when the slice does not exist"
             (prerequisite (#'cfpb.qu.data/get-metadata "good-dataset") => {:slices {}})

             (app (request :get "/data/good-dataset/what"))
             => (contains {:status 404})))

Add tests for /data/dataset/slice

Add tests for /data/dataset/slice


(ns desdemona.query-test
  (:require
   [desdemona.query :as q]
   [clojure.test :refer [deftest is are testing]]))

(deftest infix-parser-tests
  (is (= [:expr [:ipv4-address "10" "0" "0" "1"]]
         (#'q/infix-parser "10.0.0.1"))
      "ipv4 addresses")
  (is (= [:expr [:fn-call
                 [:identifier "ip"]
                 [:identifier "x"]]]
         (#'q/infix-parser "ip(x)"))
      "simple fn calls")
  (is (= [:expr [:eq
                 [:identifier "a"]
                 [:identifier "b"]]]
         (#'q/infix-parser "a = b"))
      "equality between identifiers")
  (is (= [:expr [:eq
                 [:fn-call
                  [:identifier "ip"]
                  [:identifier "x"]]
                 [:ipv4-address "10" "0" "0" "1"]]]
         (#'q/infix-parser "ip(x) = 10.0.0.1"))
      "equality between fn call and IP address literal")
  (is (= [:expr [:eq
                 [:fn-call
                  [:identifier "ip"]
                  [:identifier "x"]]
                 [:fn-call
                  [:identifier "ip"]
                  [:identifier "y"]]]]
         (#'q/infix-parser "ip(x) = ip(y)"))
      "equality between two fn calls")
  (is (= [:expr [:eq
                 [:fn-call
                  [:identifier "ip"]
                  [:identifier "x"]]
                 [:fn-call
                  [:identifier "ip"]
                  [:identifier "y"]]
                 [:ipv4-address "10" "0" "0" "1"]]]
         (#'q/infix-parser "ip(x) = ip(y)"))
      "equality between two fn calls & literal"))

(deftest infix->dsl-tests
  (is (= '(= (:ip x) "10.0.0.1")
         (q/infix->dsl "ip(x) = 10.0.0.1"))))

(deftest free-sym-tests
  (is (not (#'q/free-sym? 's))
      "sym not marked as free")
  (is (not (#'q/free-sym? 1))
      "not a symbol")
  (is (#'q/free-sym? (#'q/free-sym 's))
      "sym explicitly marked as free"))

(deftest find-free-vars-tests
  (are [expected query] (= expected (#'q/find-free-vars query))
    #{}
    '()

    #{'x}
    (#'q/dsl->logic '(= (:ip x) "10.0.0.1"))

    #{'y}
    (#'q/dsl->logic '(= (:ip y) "10.0.0.1"))

    #{'x}
    (#'q/dsl->logic '(= "10.0.0.1" (:ip x)))

    #{'x}
    (#'q/dsl->logic '(= (:type x) "egress"))

    #{'x}
    (#'q/dsl->logic '(and (= (:ip x) "10.0.0.1")
                          (= (:type x) "egress")))

    #{'x 'y}
    (#'q/dsl->logic '(= (:ip x) (:ip y)))))

(defmacro with-fake-gensym
  [& body]
  `(let [gensym-count# (atom 0)
         fake-gensym# (fn [& args#]
                        (->> (swap! gensym-count# inc)
                             (str "fake-gensym-")
                             (symbol)))]
     (with-redefs [clojure.core/gensym fake-gensym#]
       ~@body)))

(deftest dsl->logic-tests
  (is (thrown? IllegalArgumentException
               (#'q/dsl->logic '(BOGUS BOGUS BOGUS))))
  (is (= '(clojure.core.logic/featurec x {:ip "10.0.0.1"})
         (#'q/dsl->logic '(= (:ip x) "10.0.0.1"))
         (#'q/dsl->logic '(= "10.0.0.1" (:ip x)))))
  (testing "logic variable is not hard coded to 'x"
    (is (= '(clojure.core.logic/featurec y {:ip "10.0.0.1"})
           (#'q/dsl->logic '(= (:ip y) "10.0.0.1"))
           (#'q/dsl->logic '(= "10.0.0.1" (:ip y))))))
  (testing "logical conjunction"
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})
              (clojure.core.logic/featurec x {:type "egress"})])
           (#'q/dsl->logic '(and (= (:ip x) "10.0.0.1")
                                 (= (:type x) "egress"))))))
  (testing "logical disjunction"
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})]
             [(clojure.core.logic/featurec x {:type "egress"})])
           (#'q/dsl->logic '(or (= (:ip x) "10.0.0.1")
                                (= (:type x) "egress")))))
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:type "egress"})]
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})])
           (#'q/dsl->logic '(or (= (:type x) "egress")
                                (= (:ip x) "10.0.0.1"))))))
  (testing "multiple literals"
    (is (thrown? IllegalArgumentException
                 (#'q/dsl->logic '(= (:ip x) "10.0.0.1" "10.0.0.1")))
        "repeated but consistent literal")
    (is (thrown? IllegalArgumentException
                 (#'q/dsl->logic '(= (:ip x) "1.1.1.1" "8.8.8.8")))
        "repeated inconsistent literal"))
  (testing "multiple terms unified with a literal"
    (is (= '(clojure.core.logic/all
             (clojure.core.logic/featurec x {:ip "10.0.0.1"})
             (clojure.core.logic/featurec y {:ip "10.0.0.1"}))
           (#'q/dsl->logic '(= (:ip x) (:ip y) "10.0.0.1"))
           (#'q/dsl->logic '(= (:ip x) "10.0.0.1" (:ip y)))
           (#'q/dsl->logic '(= "10.0.0.1" (:ip x) (:ip y))))))
  (testing "linking events"
    (with-fake-gensym
      (is (= '(clojure.core.logic/fresh [fake-gensym-1]
                (clojure.core.logic/featurec x {:ip fake-gensym-1})
                (clojure.core.logic/featurec y {:ip fake-gensym-1}))
             (#'q/dsl->logic '(= (:ip x) (:ip y))))))))

(def events
  [{:ip "10.0.0.1"}
   {:ip "10.0.0.2"
    :type "egress"}
   {:ip "10.0.0.2"
    :type "ingress"}])

(deftest run-dsl-query-tests
  (are [query results] (= results (q/run-dsl-query query events))
    '(= (:ip x) "10.0.0.1")
    [[{:ip "10.0.0.1"}]]

    '(= (:ip y) "10.0.0.1")
    [[{:ip "10.0.0.1"}]]

    '(= (:ip x) "BOGUS")
    []

    '(= "10.0.0.1" (:ip x))
    [[{:ip "10.0.0.1"}]]

    '(= "BOGUS" (:ip x))
    [])
  (testing "explicit maximum number of results"
    (let [results [[{:ip "10.0.0.1"}]]
          query '(= (:ip x) "10.0.0.1")]
      (are [n-results] (= results (q/run-dsl-query n-results query events))
        1
        10)))
  (testing "conjunction"
    (are [query results] (= results (q/run-dsl-query query events))
      '(and (= (:ip x) "10.0.0.1")
            (= (:type x) "egress"))
      []

      '(and (= (:ip x) "10.0.0.2")
            (= (:type x) "egress"))
      [[{:ip "10.0.0.2"
         :type "egress"}]]

      '(and (= (:type x) "egress")
            (= (:ip x) "10.0.0.2"))
      [[{:ip "10.0.0.2"
         :type "egress"}]]))
  (testing "disjunction"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(or (= (:ip x) "1.2.3.4")
           (= (:type x) "bogus"))
      []

      '(or (= (:ip x) "10.0.0.1")
           (= (:type x) "egress"))
      [[{:ip "10.0.0.1"}]
       [{:ip "10.0.0.2"
         :type "egress"}]]

      '(or (= (:ip x) "10.0.0.1")
           (= (:type x) "ingress"))
      [[{:ip "10.0.0.1"}]
       [{:ip "10.0.0.2"
         :type "ingress"}]]

      '(or (= (:ip x) "10.0.0.2")
           (= (:type x) "egress"))
      [[{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; type clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "ingress"}]]

      '(or (= (:type x) "egress")
           (= (:ip x) "10.0.0.2"))
      [[{:ip "10.0.0.2"    ;; type clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "ingress"}]]))
  (testing "multi-arity featurec with literal"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(= (:ip x) (:ip y) "1.2.3.4")
      []

      '(= (:ip x) (:ip y) "10.0.0.1")
      [[{:ip "10.0.0.1"}
        {:ip "10.0.0.1"}]]))
  (testing "multi-arity features without literal"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(= (:ip x) (:ip y))
      [[{:ip "10.0.0.1"}
        {:ip "10.0.0.1"}]
       [{:ip "10.0.0.2" :type "egress"}
        {:ip "10.0.0.2" :type "egress"}]
       [{:ip "10.0.0.2" :type "egress"}
        {:ip "10.0.0.2" :type "ingress"}]
       [{:ip "10.0.0.2" :type "ingress"}
        {:ip "10.0.0.2" :type "egress"}]
       [{:ip "10.0.0.2" :type "ingress"}
        {:ip "10.0.0.2" :type "ingress"}]])))

(deftest run-logic-query-tests
  (are [query results] (= results (#'q/run-logic-query query events))
    'l/fail
    []

    (list clojure.core.logic/featurec
          (#'q/free-sym 'x)
          {:ip "10.0.0.1"})
    [[{:ip "10.0.0.1"}]]

    (list clojure.core.logic/featurec
          (#'q/free-sym 'y)
          {:ip "10.0.0.1"})
    [[{:ip "10.0.0.1"}]])

  (testing "explicit maximum number of results"
    (let [results [[{:ip "10.0.0.1"}]]
          query (list clojure.core.logic/featurec
                      (#'q/free-sym 'x)
                      {:ip "10.0.0.1"})]
      (are [n-results] (= results (#'q/run-logic-query n-results query events))
        1
        10))))

(ns desdemona.query-test
  (:require
   [desdemona.query :as q]
   [clojure.test :refer [deftest is are testing]]))

(defn ^:private fn-call
  "Expected parse tree for a function call."
  [f arg]
  [:fn-call [:identifier f] [:identifier arg]])

(deftest infix-parser-tests
  (is (= [:expr [:ipv4-address "10" "0" "0" "1"]]
         (#'q/infix-parser "10.0.0.1"))
      "ipv4 addresses")
  (is (= [:expr (fn-call "ip" "x")]
         (#'q/infix-parser "ip(x)"))
      "simple fn calls")
  (is (= [:expr [:eq
                 [:identifier "a"]
                 [:identifier "b"]]]
         (#'q/infix-parser "a = b"))
      "equality between identifiers")
  (is (= [:expr [:eq
                 (fn-call "ip" "x")
                 [:ipv4-address "10" "0" "0" "1"]]]
         (#'q/infix-parser "ip(x) = 10.0.0.1"))
      "equality between fn call and IP address literal")
  (is (= [:expr [:eq
                 (fn-call "ip" "x")
                 (fn-call "ip" "y")]]
         (#'q/infix-parser "ip(x) = ip(y)"))
      "equality between two fn calls")
  (is (= [:expr [:eq
                 (fn-call "ip" "x")
                 (fn-call "ip" "y")
                 [:ipv4-address "10" "0" "0" "1"]]]
         (#'q/infix-parser "ip(x) = ip(y)"))
      "equality between two fn calls & literal"))

(deftest infix->dsl-tests
  (is (= '(= (:ip x) "10.0.0.1")
         (q/infix->dsl "ip(x) = 10.0.0.1"))))

(deftest free-sym-tests
  (is (not (#'q/free-sym? 's))
      "sym not marked as free")
  (is (not (#'q/free-sym? 1))
      "not a symbol")
  (is (#'q/free-sym? (#'q/free-sym 's))
      "sym explicitly marked as free"))

(deftest find-free-vars-tests
  (are [expected query] (= expected (#'q/find-free-vars query))
    #{}
    '()

    #{'x}
    (#'q/dsl->logic '(= (:ip x) "10.0.0.1"))

    #{'y}
    (#'q/dsl->logic '(= (:ip y) "10.0.0.1"))

    #{'x}
    (#'q/dsl->logic '(= "10.0.0.1" (:ip x)))

    #{'x}
    (#'q/dsl->logic '(= (:type x) "egress"))

    #{'x}
    (#'q/dsl->logic '(and (= (:ip x) "10.0.0.1")
                          (= (:type x) "egress")))

    #{'x 'y}
    (#'q/dsl->logic '(= (:ip x) (:ip y)))))

(defmacro with-fake-gensym
  [& body]
  `(let [gensym-count# (atom 0)
         fake-gensym# (fn [& args#]
                        (->> (swap! gensym-count# inc)
                             (str "fake-gensym-")
                             (symbol)))]
     (with-redefs [clojure.core/gensym fake-gensym#]
       ~@body)))

(deftest dsl->logic-tests
  (is (thrown? IllegalArgumentException
               (#'q/dsl->logic '(BOGUS BOGUS BOGUS))))
  (is (= '(clojure.core.logic/featurec x {:ip "10.0.0.1"})
         (#'q/dsl->logic '(= (:ip x) "10.0.0.1"))
         (#'q/dsl->logic '(= "10.0.0.1" (:ip x)))))
  (testing "logic variable is not hard coded to 'x"
    (is (= '(clojure.core.logic/featurec y {:ip "10.0.0.1"})
           (#'q/dsl->logic '(= (:ip y) "10.0.0.1"))
           (#'q/dsl->logic '(= "10.0.0.1" (:ip y))))))
  (testing "logical conjunction"
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})
              (clojure.core.logic/featurec x {:type "egress"})])
           (#'q/dsl->logic '(and (= (:ip x) "10.0.0.1")
                                 (= (:type x) "egress"))))))
  (testing "logical disjunction"
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})]
             [(clojure.core.logic/featurec x {:type "egress"})])
           (#'q/dsl->logic '(or (= (:ip x) "10.0.0.1")
                                (= (:type x) "egress")))))
    (is (= '(clojure.core.logic/conde
             [(clojure.core.logic/featurec x {:type "egress"})]
             [(clojure.core.logic/featurec x {:ip "10.0.0.1"})])
           (#'q/dsl->logic '(or (= (:type x) "egress")
                                (= (:ip x) "10.0.0.1"))))))
  (testing "multiple literals"
    (is (thrown? IllegalArgumentException
                 (#'q/dsl->logic '(= (:ip x) "10.0.0.1" "10.0.0.1")))
        "repeated but consistent literal")
    (is (thrown? IllegalArgumentException
                 (#'q/dsl->logic '(= (:ip x) "1.1.1.1" "8.8.8.8")))
        "repeated inconsistent literal"))
  (testing "multiple terms unified with a literal"
    (is (= '(clojure.core.logic/all
             (clojure.core.logic/featurec x {:ip "10.0.0.1"})
             (clojure.core.logic/featurec y {:ip "10.0.0.1"}))
           (#'q/dsl->logic '(= (:ip x) (:ip y) "10.0.0.1"))
           (#'q/dsl->logic '(= (:ip x) "10.0.0.1" (:ip y)))
           (#'q/dsl->logic '(= "10.0.0.1" (:ip x) (:ip y))))))
  (testing "linking events"
    (with-fake-gensym
      (is (= '(clojure.core.logic/fresh [fake-gensym-1]
                (clojure.core.logic/featurec x {:ip fake-gensym-1})
                (clojure.core.logic/featurec y {:ip fake-gensym-1}))
             (#'q/dsl->logic '(= (:ip x) (:ip y))))))))

(def events
  [{:ip "10.0.0.1"}
   {:ip "10.0.0.2"
    :type "egress"}
   {:ip "10.0.0.2"
    :type "ingress"}])

(deftest run-dsl-query-tests
  (are [query results] (= results (q/run-dsl-query query events))
    '(= (:ip x) "10.0.0.1")
    [[{:ip "10.0.0.1"}]]

    '(= (:ip y) "10.0.0.1")
    [[{:ip "10.0.0.1"}]]

    '(= (:ip x) "BOGUS")
    []

    '(= "10.0.0.1" (:ip x))
    [[{:ip "10.0.0.1"}]]

    '(= "BOGUS" (:ip x))
    [])
  (testing "explicit maximum number of results"
    (let [results [[{:ip "10.0.0.1"}]]
          query '(= (:ip x) "10.0.0.1")]
      (are [n-results] (= results (q/run-dsl-query n-results query events))
        1
        10)))
  (testing "conjunction"
    (are [query results] (= results (q/run-dsl-query query events))
      '(and (= (:ip x) "10.0.0.1")
            (= (:type x) "egress"))
      []

      '(and (= (:ip x) "10.0.0.2")
            (= (:type x) "egress"))
      [[{:ip "10.0.0.2"
         :type "egress"}]]

      '(and (= (:type x) "egress")
            (= (:ip x) "10.0.0.2"))
      [[{:ip "10.0.0.2"
         :type "egress"}]]))
  (testing "disjunction"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(or (= (:ip x) "1.2.3.4")
           (= (:type x) "bogus"))
      []

      '(or (= (:ip x) "10.0.0.1")
           (= (:type x) "egress"))
      [[{:ip "10.0.0.1"}]
       [{:ip "10.0.0.2"
         :type "egress"}]]

      '(or (= (:ip x) "10.0.0.1")
           (= (:type x) "ingress"))
      [[{:ip "10.0.0.1"}]
       [{:ip "10.0.0.2"
         :type "ingress"}]]

      '(or (= (:ip x) "10.0.0.2")
           (= (:type x) "egress"))
      [[{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; type clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "ingress"}]]

      '(or (= (:type x) "egress")
           (= (:ip x) "10.0.0.2"))
      [[{:ip "10.0.0.2"    ;; type clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "egress"}]
       [{:ip "10.0.0.2"    ;; ip clause succeeded
         :type "ingress"}]]))
  (testing "multi-arity featurec with literal"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(= (:ip x) (:ip y) "1.2.3.4")
      []

      '(= (:ip x) (:ip y) "10.0.0.1")
      [[{:ip "10.0.0.1"}
        {:ip "10.0.0.1"}]]))
  (testing "multi-arity features without literal"
    (are [query results] (= results (q/run-dsl-query 10 query events))
      '(= (:ip x) (:ip y))
      [[{:ip "10.0.0.1"}
        {:ip "10.0.0.1"}]
       [{:ip "10.0.0.2" :type "egress"}
        {:ip "10.0.0.2" :type "egress"}]
       [{:ip "10.0.0.2" :type "egress"}
        {:ip "10.0.0.2" :type "ingress"}]
       [{:ip "10.0.0.2" :type "ingress"}
        {:ip "10.0.0.2" :type "egress"}]
       [{:ip "10.0.0.2" :type "ingress"}
        {:ip "10.0.0.2" :type "ingress"}]])))

(deftest run-logic-query-tests
  (are [query results] (= results (#'q/run-logic-query query events))
    'l/fail
    []

    (list clojure.core.logic/featurec
          (#'q/free-sym 'x)
          {:ip "10.0.0.1"})
    [[{:ip "10.0.0.1"}]]

    (list clojure.core.logic/featurec
          (#'q/free-sym 'y)
          {:ip "10.0.0.1"})
    [[{:ip "10.0.0.1"}]])

  (testing "explicit maximum number of results"
    (let [results [[{:ip "10.0.0.1"}]]
          query (list clojure.core.logic/featurec
                      (#'q/free-sym 'x)
                      {:ip "10.0.0.1"})]
      (are [n-results] (= results (#'q/run-logic-query n-results query events))
        1
        10))))

Refactor tests

Refactor tests


(ns todomvc.app
  (:require-macros [cljs.core.async.macros :refer [go alt!]])
  (:require [cljs.core.async :refer [put! >! <! chan]]
            [om.core :as om]
            [om.dom :as dom :include-macros true]
            [todomvc.utils :refer [pluralize now guid store]]
            [todomvc.item :as item]))

(enable-console-print!)

(def ENTER_KEY 13)

(def app-state (atom {:showing :all :todos []}))

;; =============================================================================
;; Main and Footer Components

(declare toggle-all)

(defn main [todos opts]
  (dom/component
    (dom/section #js {:id "main"}
      (dom/input #js {:id "toggle-all" :type "checkbox"
                      :onChange #(toggle-all % todos)})
      (dom/ul #js {:id "todo-list"}
        (into-array
          (map #(om/render item/todo-item todos
                  {:path [%] :opts opts :key :id
                   :fn (fn [todo]
                         (if (= (:id todo) (:editing opts))
                           (assoc todo :editing true)
                           todo))})
            (range (count todos))))))))

(defn footer [{:keys [showing todos] :as app} opts]
  (let [{:keys [count completed comm]} opts
        clear-button (when (pos? completed)
                       (dom/button
                         #js {:id "clear-completed"
                              :onClick #(put! comm [:clear (now)])}
                         (str "Clear completed " completed)))
        sel (-> (zipmap [:all :active :completed] (repeat ""))
                (assoc showing "selected"))]
    (dom/component
      (dom/footer #js {:id "footer"}
        (dom/span #js {:id "todo-count"}
          (dom/strong nil count)
          (str " " (pluralize count "item") " left"))
        (dom/ul #js {:id "filters"}
          (dom/li nil
            (dom/a #js {:href "#/" :className (sel :all)} "All"))
          (dom/li nil
            (dom/a #js {:href "#/active" :className (sel :active)} "Active"))
          (dom/li nil
            (dom/a #js {:href "#/completed" :className (sel :completed)} "Completed")))
        clear-button))))

;; =============================================================================
;; Todos

(defn toggle-all [e todos]
  (let [checked (.. e -target -checked)]
    (om/replace! todos
      (into [] (map #(assoc % :completed checked) todos)))))

(defn handle-new-todo-keydown [e app owner]
  (when (identical? (.-which e) ENTER_KEY)
    (let [new-field (dom/get-node owner "newField")]
      (om/update! app [:todos] conj
        {:id (guid) :title (.-value new-field) :completed false})
      (set! (.-value new-field) ""))
    false))

(defn toggle-todo [todo]
  (om/replace! todo (update-in todo [:completed] #(not %))))

(defn destroy-todo [app {:keys [id]}]
  (om/replace! app [:todos]
    (into [] (filter #(= (:id %) id) (:todos app)))))

(defn edit-todo [app todo]
  (om/replace! app [:editing] (:id todo)))

(defn save-todo [todo text]
  (om/replace! todo (update-in todo [:title] text)))

(defn cancel-action [app]
  (om/replace! app [:editing] nil))

(defn clear-completed [app]
  (om/replace! app [:todos] (into [] (remove :completed (:todos app)))))

(defn handle-event [app [type val :as e]]
  (case type
    :toggle  (toggle-todo val)
    :destroy (destroy-todo app val)
    :edit    (edit-todo app val)
    :save    (let [[todo text] val]
               (save-todo todo text))
    :clear   (clear-completed app)
    :cancel  (cancel-action app)
    nil))

(defn todo-app [{:keys [todos] :as app}]
  (reify
    dom/IWillMount
    (-will-mount [_ owner]
      (let [comm (chan)]
        (dom/set-state! owner :comm comm)
        (go (while true
              (handle-event app (<! comm))))))
    dom/IDidUpdate
    (-did-update [_ _ _ _ _]
      (store "todos" app))
    dom/IRender
    (-render [_ owner]
      (let [active    (count (remove :completed todos))
            completed (- (count todos) active)
            comm      (dom/get-state owner :comm)]
        (dom/div nil
          (dom/header #js {:id "header"}
            (dom/h1 nil "todos")
            (dom/input
              #js {:ref "newField" :id "new-todo"
                   :placeholder "What needs to be done?"
                   :onKeyDown #(handle-new-todo-keydown % app owner)})
            (om/render main app
              {:path [:todos] :opts {:comm comm :editing (:editing app)}})
            (om/render footer app
              {:path [] :opts {:count active :completed completed :comm comm}})))))))

(om/root app-state todo-app (.getElementById js/document "todoapp"))

(dom/render
  (dom/div nil
    (dom/p nil "Double-click to edit a todo")
    (dom/p nil
      (dom/a #js {:href "http://github.com/swannodette"}))
    (dom/p nil
      #js ["Part of"
           (dom/a #js {:href "http://todomvc.com"} "TodoMVC")]))
  (.getElementById js/document "info"))

(ns todomvc.app
  (:require-macros [cljs.core.async.macros :refer [go alt!]])
  (:require [cljs.core.async :refer [put! >! <! chan]]
            [om.core :as om]
            [om.dom :as dom :include-macros true]
            [todomvc.utils :refer [pluralize now guid store]]
            [todomvc.item :as item]))

(enable-console-print!)

(def ENTER_KEY 13)

(def app-state (atom {:showing :all :todos []}))

;; =============================================================================
;; Main and Footer Components

(declare toggle-all)

(defn main [todos opts]
  (dom/component
    (dom/section #js {:id "main"}
      (dom/input #js {:id "toggle-all" :type "checkbox"
                      :onChange #(toggle-all % todos)})
      (dom/ul #js {:id "todo-list"}
        (into-array
          (map #(om/render item/todo-item todos
                  {:path [%] :opts opts :key :id
                   :fn (fn [todo]
                         (if (= (:id todo) (:editing opts))
                           (assoc todo :editing true)
                           todo))})
            (range (count todos))))))))

(defn footer [{:keys [showing todos] :as app} opts]
  (let [{:keys [count completed comm]} opts
        clear-button (when (pos? completed)
                       (dom/button
                         #js {:id "clear-completed"
                              :onClick #(put! comm [:clear (now)])}
                         (str "Clear completed " completed)))
        sel (-> (zipmap [:all :active :completed] (repeat ""))
                (assoc showing "selected"))]
    (dom/component
      (dom/footer #js {:id "footer"}
        (dom/span #js {:id "todo-count"}
          (dom/strong nil count)
          (str " " (pluralize count "item") " left"))
        (dom/ul #js {:id "filters"}
          (dom/li nil
            (dom/a #js {:href "#/" :className (sel :all)} "All"))
          (dom/li nil
            (dom/a #js {:href "#/active" :className (sel :active)} "Active"))
          (dom/li nil
            (dom/a #js {:href "#/completed" :className (sel :completed)} "Completed")))
        clear-button))))

;; =============================================================================
;; Todos

(defn toggle-all [e todos]
  (let [checked (.. e -target -checked)]
    (om/replace! todos
      (into [] (map #(assoc % :completed checked) todos)))))

(defn handle-new-todo-keydown [e app owner]
  (when (identical? (.-which e) ENTER_KEY)
    (let [new-field (dom/get-node owner "newField")]
      (om/update! app [:todos] conj
        {:id (guid) :title (.-value new-field) :completed false})
      (set! (.-value new-field) ""))
    false))

(defn toggle-todo [todo]
  (om/replace! todo (update-in todo [:completed] #(not %))))

(defn destroy-todo [app {:keys [id]}]
  (om/replace! app [:todos]
    (into [] (filter #(= (:id %) id) (:todos app)))))

(defn edit-todo [app todo]
  (om/replace! app [:editing] (:id todo)))

(defn save-todo [todo text]
  (om/replace! todo (update-in todo [:title] text)))

(defn cancel-action [app]
  (om/replace! app [:editing] nil))

(defn clear-completed [app]
  (om/replace! app [:todos] (into [] (remove :completed (:todos app)))))

(defn handle-event [app [type val :as e]]
  (case type
    :toggle  (toggle-todo val)
    :destroy (destroy-todo app val)
    :edit    (edit-todo app val)
    :save    (let [[todo text] val]
               (save-todo todo text))
    :clear   (clear-completed app)
    :cancel  (cancel-action app)
    nil))

(defn todo-app [{:keys [todos] :as app}]
  (reify
    dom/IWillMount
    (-will-mount [_ owner]
      (let [comm (chan)]
        (dom/set-state! owner [:comm] comm)
        (go (while true
              (handle-event app (<! comm))))))
    dom/IDidUpdate
    (-did-update [_ _ _ _ _]
      (store "todos" app))
    dom/IRender
    (-render [_ owner]
      (let [active    (count (remove :completed todos))
            completed (- (count todos) active)
            comm      (dom/get-state owner [:comm])]
        (dom/div nil
          (dom/header #js {:id "header"}
            (dom/h1 nil "todos")
            (dom/input
              #js {:ref "newField" :id "new-todo"
                   :placeholder "What needs to be done?"
                   :onKeyDown #(handle-new-todo-keydown % app owner)})
            (om/render main app
              {:path [:todos] :opts {:comm comm :editing (:editing app)}})
            (om/render footer app
              {:path [] :opts {:count active :completed completed :comm comm}})))))))

(om/root app-state todo-app (.getElementById js/document "todoapp"))

(dom/render
  (dom/div nil
    (dom/p nil "Double-click to edit a todo")
    (dom/p nil
      (dom/a #js {:href "http://github.com/swannodette"}))
    (dom/p nil
      #js ["Part of"
           (dom/a #js {:href "http://todomvc.com"} "TodoMVC")]))
  (.getElementById js/document "info"))

update to new api

update to new api


(defproject geom-demos "0.1.0-SNAPSHOT"
  :description  "thi.ng/geom demos"
  :url          "https://github.com/thi-ng/demos"
  :license      {:name "Apache Software License"
                 :url "http://www.apache.org/licenses/LICENSE-2.0"}
  :dependencies [[org.clojure/clojure "1.7.0-alpha5"]
                 [org.clojure/clojurescript "0.0-3117"]
                 [thi.ng/geom "0.0.777"]
                 [thi.ng/domus "0.1.0"]]

  :plugins [[lein-cljsbuild "1.0.5"]]

  :clean-targets ^{:protect false} ["resources/public/js"]

  :cljsbuild    {:builds [{:id "dev"
                           :source-paths ["src"]
                           :compiler {:output-to "resources/public/js/app.js"
                                      :optimizations :whitespace
                                      :pretty-print true}}
                          {:id "prod"
                           :source-paths ["src"]
                           :compiler {:output-to "resources/public/js/app.js"
                                      :optimizations :advanced
                                      ;;:pseudo-names true
                                      ;;:pretty-print true
                                      :pretty-print false
                                      }}]
                 :test-commands {"unit-tests" ["phantomjs" :runner "resources/public/js/app.js"]}})

(defproject geom-demos "0.1.0-SNAPSHOT"
  :description  "thi.ng/geom demos"
  :url          "https://github.com/thi-ng/demos"
  :license      {:name "Apache Software License"
                 :url "http://www.apache.org/licenses/LICENSE-2.0"}
  :dependencies [[org.clojure/clojure "1.7.0"]
                 [org.clojure/clojurescript "1.7.145"]
                 [thi.ng/geom "0.0.881"]
                 [thi.ng/domus "0.1.0"]]

  :plugins [[lein-cljsbuild "1.1.0"]]

  :clean-targets ^{:protect false} ["resources/public/js"]

  :cljsbuild    {:builds [{:id "dev"
                           :source-paths ["src"]
                           :compiler {:output-to "resources/public/js/app.js"
                                      :optimizations :whitespace
                                      :pretty-print true}}
                          {:id "prod"
                           :source-paths ["src"]
                           :compiler {:output-to "resources/public/js/app.js"
                                      :optimizations :advanced
                                      ;;:pseudo-names true
                                      ;;:pretty-print true
                                      :pretty-print false
                                      }}]
                 :test-commands {"unit-tests" ["phantomjs" :runner "resources/public/js/app.js"]}})

update deps

update deps


(ns pc.svg
  (:require [clojure.string :as str]
            [pc.layers :as layers]))

(defn points->path [points]
  (str "M" (str/join " " (map (fn [p] (str (:rx p) " " (:ry p))) points))))

(defn layer->svg-rect [layer {:keys [invert-colors?]}]
  (let [layer (layers/normalized-abs-coords layer)]
    {:x             (:layer/start-x layer)
     :y             (:layer/start-y layer)
     :width         (- (or (:layer/current-x layer)
                           (:layer/end-x layer)) (:layer/start-x layer))
     :height        (- (or (:layer/current-y layer)
                           (:layer/end-y layer)) (:layer/start-y layer))
     :fill          "none"
     :key           (:layer/id layer)
     :stroke        (if invert-colors? "#ccc" "black")
     :strokeWidth   2
     :rx            (:layer/rx layer)
     :ry            (:layer/ry layer)     }))

(defn layer->svg-text [layer {:keys [invert-colors?]}]
  {:x (:layer/start-x layer)
   :y (:layer/start-y layer)
   :fill (if invert-colors? "#ccc" "black")
   :strokeWidth 0
   :font-family (:layer/font-family layer "Helvetica")
   :font-size   (:layer/font-size layer 20)})

(defn layer->svg-line [layer {:keys [invert-colors?]}]
  {:x1          (:layer/start-x layer)
   :y1          (:layer/start-y layer)
   :x2          (:layer/end-x layer)
   :y2          (:layer/end-y layer)
   :stroke (if invert-colors? "#ccc" "black")
   :strokeWidth 2})

(defn layer->svg-path [layer {:keys [invert-colors?]}]
  {:d (:layer/path layer)
   :stroke (if invert-colors? "#ccc" "black")
   :fill "none"
   :strokeWidth 2})

(ns pc.svg
  (:require [clojure.string :as str]
            [pc.layers :as layers]))

(defn points->path [points]
  (str "M" (str/join " " (map (fn [p] (str (:rx p) " " (:ry p))) points))))

(defn layer->svg-rect [layer {:keys [invert-colors?]}]
  (let [layer (layers/normalized-abs-coords layer)]
    {:x             (:layer/start-x layer)
     :y             (:layer/start-y layer)
     :width         (- (or (:layer/current-x layer)
                           (:layer/end-x layer)) (:layer/start-x layer))
     :height        (- (or (:layer/current-y layer)
                           (:layer/end-y layer)) (:layer/start-y layer))
     :fill          "none"
     :key           (:layer/id layer)
     :stroke        (if invert-colors? "#ccc" "black")
     :stroke-width   2
     :rx            (:layer/rx layer)
     :ry            (:layer/ry layer)     }))

(defn layer->svg-text [layer {:keys [invert-colors?]}]
  {:x (:layer/start-x layer)
   :y (:layer/start-y layer)
   :fill (if invert-colors? "#ccc" "black")
   :stroke-width 0
   :font-family (:layer/font-family layer "Helvetica")
   :font-size   (:layer/font-size layer 20)})

(defn layer->svg-line [layer {:keys [invert-colors?]}]
  {:x1          (:layer/start-x layer)
   :y1          (:layer/start-y layer)
   :x2          (:layer/end-x layer)
   :y2          (:layer/end-y layer)
   :stroke (if invert-colors? "#ccc" "black")
   :stroke-width 2})

(defn layer->svg-path [layer {:keys [invert-colors?]}]
  {:d (:layer/path layer)
   :stroke (if invert-colors? "#ccc" "black")
   :fill "none"
   :stroke-width 2})

fix stroke-width

fix stroke-width


(ns mosaic.core
  (require [mosaic.image :as img])
  (import java.lang.Math)
  (import java.awt.image.BufferedImage))

(defn- grid
  "Divide region 0,0,x,y into grid squares of size n.
   Partial grids squares are omitted. Optional parameter
   s sets the step size to allow for overlapping squares."
  ([n x y] (grid n x y n))
  ([n x y s]
     (for
	 [a (range 0 (- x n -1) s)
	  b (range 0 (- y n -1) s)]
       [a,b,n,n])))

(defn- gen-tiles
  "Generate tiles of size n from image b.
   Returns a list of BufferedImages."
  ([n ^BufferedImage b] (gen-tiles n b n))
  ([n ^BufferedImage b s]
     (map img/sub-image
	  (grid n (.getWidth b) (.getHeight b) s)
	  (repeat b))))

(defn- gen-tiles-coll
  "Generate tiles of size n from images coll."
  ([n coll] (gen-tiles-coll n coll n))
  ([n coll s]
     (flatten (map gen-tiles (repeat n) coll))))

(defn- delta [seq-a seq-b]
  "Calculate the difference between sequences a and b.
   This is like a k-d manhattan distance."
  (reduce + (map #(Math/abs %) (map - seq-a seq-b))))

(defn- sample-tiles [n tiles]
  "Get average RGB in regions n-by-n for tiles.
   Output format: {:tile :sample}"
  (for [t tiles] {:tile t
		  :samples (img/get-samples (img/rescale n n t))}))

(defn- best-match [n samples ^BufferedImage b]
  "Find the best matching tile to image b."
  (let [s (img/get-samples (img/rescale n n b))]
    (reduce #(if (< (delta s (:samples %1))
		    (delta s (:samples %2)))
	       %1 %2)
	    (first samples)
	    (rest samples))))

(defn- gen-canvas [n w ^BufferedImage b]
  "Rescale and crop image b to evenly fit tiles of
   size n, with w tiles across."
  (let [x (* n w)]
    (img/image-floor n (img/rescale-fixed-ratio x b))))

(defn mosaic [tiles ; collection of tile sources
	      ^BufferedImage target ; image to mosaic
	      n  ; tile size
	      ns ; tile step size
	      w  ; width in tiles
	      s] ; sample size (actual sample regions are s^2)
  (let [canvas (gen-canvas n w target)
	tiles (sample-tiles s (gen-tiles-coll n tiles ns))]
    ; Replace each tile in canvas with the best match from tiles coll.
    (dorun (map #(img/insert!
		  (:tile (best-match n tiles (img/sub-image % canvas)))
		  canvas (first %) (second %))
		(grid n (.getWidth canvas) (.getHeight canvas))))
    canvas))

(ns mosaic.core
  (require [mosaic.image :as img])
  (import java.lang.Math)
  (import java.awt.image.BufferedImage))

(defn- grid
  "Divide region 0,0,x,y into grid squares of size n.
   Partial grids squares are omitted. Optional parameter
   s sets the step size to allow for overlapping squares."
  ([n x y] (grid n x y n))
  ([n x y s]
     (for
	 [a (range 0 (- x n -1) s)
	  b (range 0 (- y n -1) s)]
       [a,b,n,n])))

(defn- gen-tiles
  "Generate tiles of size n from image b.
   Returns a list of coordinate, image pairs
   rather than subimages for space efficiency."
  ([n ^BufferedImage b] (gen-tiles n b n))
  ([n ^BufferedImage b s]
     (map #(hash-map :coord %1 :image %2)
	  (grid n (.getWidth b) (.getHeight b) s)
	  (repeat b))))

(defn- gen-tiles-coll
  "Generate tiles of size n from images coll."
  ([n coll] (gen-tiles-coll n coll n))
  ([n coll s]
     (flatten (map gen-tiles (repeat n) coll))))

(defn- delta [seq-a seq-b]
  "Calculate the difference between sequences a and b.
   This is like a k-d manhattan distance."
  (reduce + (map #(Math/abs %) (map - seq-a seq-b))))

(defn- sample-tiles [n tiles]
  "Get average RGB in regions n-by-n for tiles.
   Output format: {:tile :samples}"
  (for [t tiles]
    (let [i (img/sub-image (:coord t) (:image t))
	  s (img/get-samples (img/rescale n n i))]
      {:tile t :samples s} )))

(defn- best-match [n samples ^BufferedImage b]
  "Find the best matching tile to image b.
   Applies sub-image to the resulting tile
   to return a BufferedImage."
  (let [s (img/get-samples (img/rescale n n b))
	t (reduce #(if (< (delta s (:samples %1))
			  (delta s (:samples %2)))
		     %1 %2)
		  (first samples)
		  (rest samples))
	i (:tile t)]
    (img/sub-image (:coord i) (:image i))))

(defn- gen-canvas [n w ^BufferedImage b]
  "Rescale and crop image b to evenly fit tiles of
   size n, with w tiles across."
  (let [x (* n w)]
    (img/image-floor n (img/rescale-fixed-ratio x b))))

(defn mosaic [tiles ; collection of tile sources
	      ^BufferedImage target ; image to mosaic
	      n  ; tile size
	      ns ; tile step size
	      w  ; width in tiles
	      s] ; sample size (actual sample regions are s^2)
  (let [canvas (gen-canvas n w target)
	tiles (sample-tiles s (gen-tiles-coll n tiles ns))]
    ; Replace each tile in canvas with the best match from tiles coll.
    (dorun (map #(img/insert!
		  (best-match n tiles (img/sub-image % canvas))
		  canvas (first %) (second %))
		(grid n (.getWidth canvas) (.getHeight canvas))))
    canvas))

Store tiles as coordinates and image refs rather than the actual sub-image to prevent space explosion when step-size is much smaller than tile-size


(ns com.puppetlabs.puppetdb.query.event-counts
  (:require [com.puppetlabs.puppetdb.query.events :as events]
            [clojure.string :as string])
  (:use [com.puppetlabs.jdbc :only [valid-jdbc-query? dashes->underscores]]
        [com.puppetlabs.puppetdb.query :only [compile-term execute-query]]
        [com.puppetlabs.utils :only [contains-some]]
        [clojure.core.match :only [match]]))

(defn- compile-event-count-equality
  "Compile an = predicate for event-count query.  The `path` represents
  the field to query against, and `value` is the value of the field."
  [& [path value :as args]]
  {:post [(map? %)
          (string? (:where %))]}
  (when-not (= (count args) 2)
    (throw (IllegalArgumentException. (format "= requires exactly two arguments, but %d were supplied" (count args)))))
  (let [db-field (dashes->underscores path)]
    (match [db-field]
      [(field :when #{"successes" "failures" "noops" "skips"})]
      {:where (format "%s = ?" field)
       :params [value]}

      :else (throw (IllegalArgumentException. (str path " is not a queryable object for event counts"))))))

(defn- compile-event-count-inequality
  "Compile an inequality for an event-counts query (> < >= <=).  The `path`
  represents the field to query against, and the `value` is the value of the field."
  [& [op path value :as args]]
  {:post [(map? %)
          (string? (:where %))]}
  (when-not (= (count args) 3)
    (throw (IllegalArgumentException. (format "%s requires exactly two arguments, but %d were supplied" op (dec (count args))))))
  (match [path]
    [(field :when #{"successes" "failures" "noops" "skips"})]
    {:where (format "%s %s ?" field op)
     :params [value]}

    :else (throw (IllegalArgumentException. (format "%s operator does not support object '%s' for event counts" op path)))))

(defn- event-count-ops
  "Maps resource event count operators to the functions implementing them.
  Returns nil if the operator is unknown."
  [op]
  (let [op (string/lower-case op)]
    (cond
      (= "=" op) compile-event-count-equality
      (#{">" "<" ">=" "<="} op) (partial compile-event-count-inequality op))))

(defn- get-group-by
  "Given the value to summarize by, return the appropriate database field to be used in the SQL query.
  Supported values are `certname`, `containing-class`, and `resource` (default), otherwise an
  IllegalArgumentException is thrown."
  [summarize-by]
  {:pre  [(string? summarize-by)]
   :post [(string? %)]}
  (condp = summarize-by
    "certname" "certname"
    "containing-class" "containing_class"
    "resource" "resource_type, resource_title"
    (throw (IllegalArgumentException. (format "Unsupported value for 'summarize-by': '%s'" summarize-by)))))

(defn- get-counts-filter-where-clause
  "Given a `counts-filter` query, return the appropriate SQL where clause and parameters.
  Returns a noop map if the `counts-filter` is nil."
  [counts-filter]
  {:pre  [((some-fn nil? sequential?) counts-filter)]
   :post [(map? %)]}
  (if counts-filter
    (compile-term event-count-ops counts-filter)
    {:where nil :params []}))

(defn- get-count-by-sql
  "Given the events `sql`, a value to `count-by`, and a value to `group-by`,
  return the appropriate SQL string that counts and groups the `sql` results.
  Supported `count-by` values are `resource` (default) and `certname`, otherwise
  an IllegalArgumentException is thrown."
  [sql count-by group-by]
  {:pre  [(string? sql)
          (string? count-by)
          (string? group-by)]
   :post [(string? %)]}
  (condp = count-by
    "resource"  sql
    "certname"  (let [field-string (if (= group-by "certname") "" (str ", " group-by))]
                  (format "SELECT DISTINCT certname, status%s FROM (%s) distinct_events" field-string sql))
    (throw (IllegalArgumentException. (format "Unsupported value for 'count-by': '%s'" count-by)))))

(defn- get-event-count-sql
  "Given the `event-sql` and value to `group-by`, return a SQL string that
  will sum the results of `event-sql` grouped by the provided value."
  [event-sql group-by]
  {:pre  [(string? event-sql)
          (string? group-by)]
   :post [(string? %)]}
  (format "SELECT %s,
              SUM(CASE WHEN status = 'failure' THEN 1 ELSE 0 END) AS failures,
              SUM(CASE WHEN status = 'success' THEN 1 ELSE 0 END) AS successes,
              SUM(CASE WHEN status = 'noop' THEN 1 ELSE 0 END) AS noops,
              SUM(CASE WHEN status = 'skipped' THEN 1 ELSE 0 END) AS skips
            FROM (%s) events
            GROUP BY %s"
          group-by
          event-sql
          group-by))

(defn- get-filtered-sql
  "Given a `sql` string and optional `where` clause, return the appropriate filtered
  SQL string.  If the `where` clause is nil, `sql` is returned."
  [sql where]
  {:pre  [(string? sql)
          ((some-fn nil? string?) where)]
   :post [(string? %)]}
  (if where
    (format "SELECT * FROM (%s) count_results WHERE %s" sql where)
    sql))

(defn- munge-subject
  "Helper function to transform the event count subject data from the raw format that we get back from the
  database into the more structured format that the API specifies."
  [summarize-by result]
  {:pre [(contains? #{"certname" "resource" "containing-class"} summarize-by)
         (map? result)
         (or
           (contains? result :certname)
           (every? #(contains? result %) [:resource_type :resource_title])
           (contains? result :containing_class))]
   :post [(map? %)
          (not (contains-some % [:certname :resource_type :resource_title :containing_class]))
          (map? (:subject %))
          (= summarize-by (:subject-type %))]}
  (condp = summarize-by
    "certname"          (-> result
                          (assoc :subject-type "certname")
                          (assoc :subject {:title (:certname result)})
                          (dissoc :certname))

    "resource"          (-> result
                          (assoc :subject-type "resource")
                          (assoc :subject {:type (:resource_type result) :title (:resource_title result)})
                          (dissoc :resource_type :resource_title))

    "containing-class"  (-> result
                          (assoc :subject-type "containing-class")
                          (assoc :subject {:title (:containing_class result)})
                          (dissoc :containing_class))))

(defn- munge-subjects
  "Helper function to transform the event count subject data from the raw format that we get back from the
  database into the more structured format that the API specifies."
  [summarize-by results]
  {:pre [(vector? results)]
   :post [(vector? %)]}
  (mapv (partial munge-subject summarize-by) results))

(defn query->sql
  "Convert an event-counts `query` and a value to `summarize-by` into a SQL string.
  A second `counts-filter` query may be provided to further reduce the results, and
  the value to `count-by` may also be specified (defaults to `resource`)."
  ([query summarize-by]
    (query->sql query summarize-by {}))
  ([query summarize-by {:keys [counts-filter count-by]}]
    {:pre  [(sequential? query)
            (string? summarize-by)
            ((some-fn nil? sequential?) counts-filter)
            ((some-fn nil? string?) count-by)]
     :post [(valid-jdbc-query? %)]}
    (let [count-by                        (or count-by "resource")
          group-by                        (get-group-by summarize-by)
          {counts-filter-where  :where
           counts-filter-params :params}  (get-counts-filter-where-clause counts-filter)
          [event-sql & event-params]      (events/query->sql query)
          count-by-sql                    (get-count-by-sql event-sql count-by group-by)
          event-count-sql                 (get-event-count-sql count-by-sql group-by)
          filtered-sql                    (get-filtered-sql event-count-sql counts-filter-where)]
      (apply vector filtered-sql (concat event-params counts-filter-params)))))

(defn query-event-counts
  "Given a SQL query and its parameters, return a vector of matching results."
  ([sql-and-params summarize-by]
    (query-event-counts {} summarize-by sql-and-params))
  ([paging-options summarize-by [sql & params]]
   {:pre  [(string? sql)]
    :post [(map? %)
           (vector? (:result %))]}
    (-> (execute-query (apply vector sql params) paging-options)
      (update-in [:result] (partial munge-subjects summarize-by)))))

(ns com.puppetlabs.puppetdb.query.event-counts
  (:require [com.puppetlabs.puppetdb.query.events :as events]
            [clojure.string :as string])
  (:use [com.puppetlabs.jdbc :only [valid-jdbc-query? dashes->underscores underscores->dashes]]
        [com.puppetlabs.puppetdb.query :only [compile-term execute-query]]
        [com.puppetlabs.puppetdb.query.paging :only [validate-order-by!]]
        [com.puppetlabs.utils :only [contains-some]]
        [clojure.core.match :only [match]]))

(defn- compile-event-count-equality
  "Compile an = predicate for event-count query.  The `path` represents
  the field to query against, and `value` is the value of the field."
  [& [path value :as args]]
  {:post [(map? %)
          (string? (:where %))]}
  (when-not (= (count args) 2)
    (throw (IllegalArgumentException. (format "= requires exactly two arguments, but %d were supplied" (count args)))))
  (let [db-field (dashes->underscores path)]
    (match [db-field]
      [(field :when #{"successes" "failures" "noops" "skips"})]
      {:where (format "%s = ?" field)
       :params [value]}

      :else (throw (IllegalArgumentException. (str path " is not a queryable object for event counts"))))))

(defn- compile-event-count-inequality
  "Compile an inequality for an event-counts query (> < >= <=).  The `path`
  represents the field to query against, and the `value` is the value of the field."
  [& [op path value :as args]]
  {:post [(map? %)
          (string? (:where %))]}
  (when-not (= (count args) 3)
    (throw (IllegalArgumentException. (format "%s requires exactly two arguments, but %d were supplied" op (dec (count args))))))
  (match [path]
    [(field :when #{"successes" "failures" "noops" "skips"})]
    {:where (format "%s %s ?" field op)
     :params [value]}

    :else (throw (IllegalArgumentException. (format "%s operator does not support object '%s' for event counts" op path)))))

(defn- event-count-ops
  "Maps resource event count operators to the functions implementing them.
  Returns nil if the operator is unknown."
  [op]
  (let [op (string/lower-case op)]
    (cond
      (= "=" op) compile-event-count-equality
      (#{">" "<" ">=" "<="} op) (partial compile-event-count-inequality op))))

(defn- get-group-by
  "Given the value to summarize by, return the appropriate database field to be used in the SQL query.
  Supported values are `certname`, `containing-class`, and `resource` (default), otherwise an
  IllegalArgumentException is thrown."
  [summarize-by]
  {:pre  [(string? summarize-by)]
   :post [(vector? %)]}
  (condp = summarize-by
    "certname" ["certname"]
    "containing-class" ["containing_class"]
    "resource" ["resource_type" "resource_title"]
    (throw (IllegalArgumentException. (format "Unsupported value for 'summarize-by': '%s'" summarize-by)))))

(defn- get-counts-filter-where-clause
  "Given a `counts-filter` query, return the appropriate SQL where clause and parameters.
  Returns a noop map if the `counts-filter` is nil."
  [counts-filter]
  {:pre  [((some-fn nil? sequential?) counts-filter)]
   :post [(map? %)]}
  (if counts-filter
    (compile-term event-count-ops counts-filter)
    {:where nil :params []}))

(defn- get-count-by-sql
  "Given the events `sql`, a value to `count-by`, and a value to `group-by`,
  return the appropriate SQL string that counts and groups the `sql` results.
  Supported `count-by` values are `resource` (default) and `certname`, otherwise
  an IllegalArgumentException is thrown."
  [sql count-by group-by]
  {:pre  [(string? sql)
          (string? count-by)
          (vector? group-by)]
   :post [(string? %)]}
  (condp = count-by
    "resource"  sql
    "certname"  (let [field-string (if (= group-by ["certname"]) "" (str ", " (string/join ", " group-by)))]
                  (format "SELECT DISTINCT certname, status%s FROM (%s) distinct_events" field-string sql))
    (throw (IllegalArgumentException. (format "Unsupported value for 'count-by': '%s'" count-by)))))

(defn- event-counts-columns
  [group-by]
  {:pre [(vector? group-by)]}
  (concat
    ["failures" "successes" "noops" "skips"]
    (map underscores->dashes group-by)))

(defn- get-event-count-sql
  "Given the `event-sql` and value to `group-by`, return a SQL string that
  will sum the results of `event-sql` grouped by the provided value."
  [event-sql group-by]
  {:pre  [(string? event-sql)
          (vector? group-by)]
   :post [(string? %)]}
  (format "SELECT %s,
              SUM(CASE WHEN status = 'failure' THEN 1 ELSE 0 END) AS failures,
              SUM(CASE WHEN status = 'success' THEN 1 ELSE 0 END) AS successes,
              SUM(CASE WHEN status = 'noop' THEN 1 ELSE 0 END) AS noops,
              SUM(CASE WHEN status = 'skipped' THEN 1 ELSE 0 END) AS skips
            FROM (%s) events
            GROUP BY %s"
          (string/join ", " group-by)
          event-sql
          (string/join ", " group-by)))

(defn- get-filtered-sql
  "Given a `sql` string and optional `where` clause, return the appropriate filtered
  SQL string.  If the `where` clause is nil, `sql` is returned."
  [sql where]
  {:pre  [(string? sql)
          ((some-fn nil? string?) where)]
   :post [(string? %)]}
  (if where
    (format "SELECT * FROM (%s) count_results WHERE %s" sql where)
    sql))

(defn- munge-subject
  "Helper function to transform the event count subject data from the raw format that we get back from the
  database into the more structured format that the API specifies."
  [summarize-by result]
  {:pre [(contains? #{"certname" "resource" "containing-class"} summarize-by)
         (map? result)
         (or
           (contains? result :certname)
           (every? #(contains? result %) [:resource_type :resource_title])
           (contains? result :containing_class))]
   :post [(map? %)
          (not (contains-some % [:certname :resource_type :resource_title :containing_class]))
          (map? (:subject %))
          (= summarize-by (:subject-type %))]}
  (condp = summarize-by
    "certname"          (-> result
                          (assoc :subject-type "certname")
                          (assoc :subject {:title (:certname result)})
                          (dissoc :certname))

    "resource"          (-> result
                          (assoc :subject-type "resource")
                          (assoc :subject {:type (:resource_type result) :title (:resource_title result)})
                          (dissoc :resource_type :resource_title))

    "containing-class"  (-> result
                          (assoc :subject-type "containing-class")
                          (assoc :subject {:title (:containing_class result)})
                          (dissoc :containing_class))))

(defn- munge-subjects
  "Helper function to transform the event count subject data from the raw format that we get back from the
  database into the more structured format that the API specifies."
  [summarize-by results]
  {:pre [(vector? results)]
   :post [(vector? %)]}
  (mapv (partial munge-subject summarize-by) results))

(defn query->sql
  "Convert an event-counts `query` and a value to `summarize-by` into a SQL string.
  A second `counts-filter` query may be provided to further reduce the results, and
  the value to `count-by` may also be specified (defaults to `resource`)."
  ([query summarize-by]
    (query->sql query summarize-by {}))
  ([query summarize-by {:keys [counts-filter count-by]}]
    {:pre  [(sequential? query)
            (string? summarize-by)
            ((some-fn nil? sequential?) counts-filter)
            ((some-fn nil? string?) count-by)]
     :post [(valid-jdbc-query? %)]}
    (let [count-by                        (or count-by "resource")
          group-by                        (get-group-by summarize-by)
          {counts-filter-where  :where
           counts-filter-params :params}  (get-counts-filter-where-clause counts-filter)
          [event-sql & event-params]      (events/query->sql query)
          count-by-sql                    (get-count-by-sql event-sql count-by group-by)
          event-count-sql                 (get-event-count-sql count-by-sql group-by)
          filtered-sql                    (get-filtered-sql event-count-sql counts-filter-where)]
      (apply vector filtered-sql (concat event-params counts-filter-params)))))

(defn query-event-counts
  "Given a SQL query and its parameters, return a vector of matching results."
  ([sql-and-params summarize-by]
    (query-event-counts {} summarize-by sql-and-params))
  ([paging-options summarize-by [sql & params]]
   {:pre  [(string? sql)]
    :post [(map? %)
           (vector? (:result %))]}
    (let [group-by (get-group-by summarize-by)]
      (validate-order-by! (event-counts-columns group-by) paging-options))
    (-> (execute-query (apply vector sql params) paging-options)
      (update-in [:result] (partial munge-subjects summarize-by)))))

Add explicit validation of order-by fields in event-counts

Prior to this commit, we weren't validating the order-by
fields for the event-counts endpoint.  This meant that if
you specified a bad field name, it was getting passed
all the way down to the SQL layer and failing there,
so you'd get a 500 rather than a 400 with a clear error
message.

This adds in the validation and ensures we get the 400.