From 1ccb368ab4041a012b84121acfd18ae9f7a12d8c Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 20 Jun 2018 09:23:02 +0100
Subject: [PATCH] Moved utils into support.

---
 src/adl_support/core.clj       |  52 +++-
 src/adl_support/tags.clj       |  43 ++--
 src/adl_support/utils.clj      | 452 +++++++++++++++++++++++++++++++++
 test/adl_support/core_test.clj |  21 +-
 test/adl_support/tags_test.clj |  50 ++++
 5 files changed, 591 insertions(+), 27 deletions(-)
 create mode 100644 src/adl_support/utils.clj
 create mode 100644 test/adl_support/tags_test.clj

diff --git a/src/adl_support/core.clj b/src/adl_support/core.clj
index 0124a59..0a5df51 100644
--- a/src/adl_support/core.clj
+++ b/src/adl_support/core.clj
@@ -1,16 +1,50 @@
 (ns adl-support.core
-  (:require [clojure.string :refer [split]]))
+  (:require [clojure.java.io :as io]
+            [clojure.string :refer [split]]))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl-support.core: functions used by ADL-generated code.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the MIT-style licence provided; see LICENSE.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; License for more details.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn query-string-to-map
+  "A `query-string` - the query-part of a URL - comprises generally
+  `<name>=<value>&<name>=<value>...`; reduce such a string to a map.
+  If `query-string` is nil or empty return an empty map."
   [query-string]
-  (reduce
-   merge
-   (map
-    #(let [pair (split % #"=")
-           value (try
+  (if
+    (empty? query-string)
+    {}
+    (reduce
+      merge
+      (map
+        #(let [pair (split % #"=")
+               v (try
                    (read-string (nth pair 1))
                    (catch Exception _
-                     (nth pair 1)))]
-       (hash-map (keyword (first pair) (nth pair 1))))
-    (split query-string #"\&"))))
+                     (nth pair 1)))
+               value (if (number? v) v (str v))]
+           (hash-map (keyword (first pair)) value))
+        (split query-string #"\&")))))
+
+(defn
+  raw-resolve-template
+  [n]
+  (if
+    (.exists (io/as-file (str "resources/templates/" n)))
+    n
+    (str "auto/" n)))
+
+(def resolve-template (memoize raw-resolve-template))
+
diff --git a/src/adl_support/tags.clj b/src/adl_support/tags.clj
index 64524df..b1c76a3 100644
--- a/src/adl_support/tags.clj
+++ b/src/adl_support/tags.clj
@@ -1,14 +1,5 @@
 (ns adl-support.tags
-    (:require selmer.node
-            [selmer.filter-parser :refer [split-filter-val
-                                          safe-filter
-                                          compile-filter-body
-                                          fix-accessor
-                                          get-accessor]]
-            [selmer.filters :refer [filters]]
-            [selmer.util :refer :all]
-            [json-html.core :refer [edn->html]])
-  (:import [selmer.node INode TextNode FunctionNode]))
+    (:require [selmer.parser :as p]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -26,9 +17,31 @@
 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defn if-member-of-permitted
+  "If at least one of these `args` matches some group name in the `:user-roles`
+  of this `context`, return this `success`, else this `failure`."
+  [args context success failure]
+  (if
+    (and
+      (seq? args)
+      (set? (:user-roles context))
+      (some (:user-roles context) args))
+    success
+    failure))
+
+(defn add-tags []
+  "Add custom tags required by ADL-generated code to the parser's tags."
+  (p/add-tag! :ifmemberof
+              (fn [args context content]
+                (if-member-of-permitted args context
+                                        (get-in content [:ifmemberof :content]) (get-in content [:else :content])))
+              :else
+              (fn [args context content]
+                "")
+            :endifmemberof))
+
+(add-tags)
+
+(if-member-of-permitted '("public" "canvassers") {:user-roles #{"canvassers"}} "caramba" false)
+
 
-(defn if-writable-handler [params tag-content render rdr]
-  "If the current element is writable by the current user, emit the content of
-  the if clause; else emit the content of the else clause."
-  (let [{if-tags :ifwritable else-tags :else} (tag-content rdr :ifwritable :else :endifwritable)]
-    params))
diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj
new file mode 100644
index 0000000..1c3c61f
--- /dev/null
+++ b/src/adl_support/utils.clj
@@ -0,0 +1,452 @@
+(ns ^{:doc "Application Description Language support library - utility functions."
+      :author "Simon Brooke"}
+  adl-support.utils
+  (:require [clojure.string :as s]
+            [clojure.pprint :as p]
+            [clojure.xml :as x]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl-support.utils: utility functions.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the MIT-style licence provided; see LICENSE.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; License for more details.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(def ^:dynamic  *locale*
+  "The locale for which files will be generated."
+  "en-GB")
+
+(def ^:dynamic *output-path*
+  "The path to which generated files will be written."
+  "generated/")
+
+(def ^:dynamic *verbosity*
+  "The verbosity of output from the generator."
+  0)
+
+
+(defn element?
+  "True if `o` is a Clojure representation of an XML element."
+  [o]
+  (and (map? o) (:tag o) (:attrs o)))
+
+
+(defn wrap-lines
+  "Wrap lines in this `text` to this `width`; return a list of lines."
+  ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
+  [width text]
+  (s/split-lines
+   (p/cl-format
+    nil
+    (str "~{~<~%~1," width ":;~A~> ~}")
+    (clojure.string/split text #" "))))
+
+
+(defn emit-header
+  "Emit this `content` as a sequence of wrapped lines each prefixed with
+  `prefix`, and the whole delimited by rules."
+  [prefix & content]
+  (let [comment-rule (apply str (repeat 70 (last prefix)))
+        p (str "\n" prefix "\t") ]
+    (str
+     prefix
+     comment-rule
+     p
+     (s/join
+      p
+      (flatten
+       (interpose
+        ""
+         (map
+          #(wrap-lines 70 (str %))
+          (flatten content)))))
+     "\n"
+     prefix
+     comment-rule)))
+
+
+(defn sort-by-name
+  [elements]
+  (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
+
+
+(defn link-table-name
+  "Canonical name of a link table between entity `e1` and entity `e2`."
+  [e1 e2]
+  (s/join
+    "_"
+    (cons
+      "ln"
+      (sort
+        (list
+          (:name (:attrs e1)) (:name (:attrs e2)))))))
+
+
+(defn children
+  "Return the children of this `element`; if `predicate` is passed, return only those
+  children satisfying the predicate."
+  ([element]
+   (if
+     (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
+     (:content element)))
+  ([element predicate]
+   (filter
+     predicate
+     (children element))))
+
+
+(defn child
+  "Return the first child of this `element` satisfying this `predicate`."
+  [element predicate]
+  (first (children element predicate)))
+
+
+(defn attributes
+  "Return the attributes of this `element`; if `predicate` is passed, return only those
+  attributes satisfying the predicate."
+  ([element]
+   (if
+     (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
+     (:attrs element)))
+  ([element predicate]
+   (filter
+     predicate
+     (attributes element))))
+
+
+(defn children-with-tag
+  "Return all children of this `element` which have this `tag`;
+  if `element` is `nil`, return `nil`. If `predicate` is supplied,
+  return only those children with the specified `tag` which satisfy
+  the `predicate`."
+  ([element tag]
+  (if
+    element
+    (children element #(= (:tag %) tag))))
+  ([element tag predicate]
+   (filter
+     predicate
+     (children-with-tag element tag))))
+
+
+(defn child-with-tag
+  "Return the first child of this `element` which has this `tag`;
+  if `element` is `nil`, return `nil`. If `predicate` is supplied,
+  return only the first child with the specified `tag` which satisfies
+  the `predicate`."
+  ([element tag]
+   (first (children-with-tag element tag)))
+  ([element tag predicate]
+   (first (children-with-tag element tag predicate))))
+
+
+
+(defn typedef
+  "If this `property` is of type `defined`, return its type definition from
+  this `application`, else nil."
+  [property application]
+  (if
+    (= (:type (:attrs property)) "defined")
+    (child
+     application
+     #(and
+       (= (:tag %) :typedef)
+       (= (:name (:attrs %)) (:typedef (:attrs property)))))))
+
+
+(defn permission-groups
+  "Return a list of names of groups to which this `predicate` is true of
+  some permission taken from these `permissions`, else nil."
+  [permissions predicate]
+  (let [groups (remove
+                 nil?
+                 (map
+                   #(if
+                      (apply predicate (list %))
+                      (:group (:attrs %)))
+                   permissions))]
+    (if groups groups)))
+
+
+(defn formal-primary-key?
+  "Does this `prop-or-name` appear to be a property (or the name of a property)
+  which is a formal primary key of this entity?"
+  [prop-or-name entity]
+  (if
+    (map? prop-or-name)
+    (formal-primary-key? (:name (:attrs prop-or-name)) entity)
+    (let [primary-key (first (children entity #(= (:tag %) :key)))
+          property (first
+                     (children
+                       primary-key
+                       #(and
+                          (= (:tag %) :property)
+                          (= (:name (:attrs %)) prop-or-name))))]
+      (= (:distinct (:attrs property)) "system"))))
+
+
+(defn entity?
+  "Return true if `x` is an ADL entity."
+  [x]
+  (= (:tag x) :entity))
+
+
+(defn property?
+  "True if `o` is a property."
+  [o]
+  (= (:tag o) :property))
+
+
+(defn entity-for-property
+  "If this `property` references an entity, return that entity from this `application`"
+  [property application]
+  (if
+    (and (property? property) (:entity (:attrs property)))
+    (child
+      application
+      #(and
+         (entity? %)
+         (= (:name (:attrs %))(:entity (:attrs property)))))))
+
+
+(defn visible-to
+  "Return a list of names of groups to which are granted read access,
+  given these `permissions`, else nil."
+  [permissions]
+  (permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %)))))
+
+
+(defn writable-by
+  "Return a list of names of groups to which are granted write access,
+  given these `permissions`, else nil.
+  TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the
+  current value is nil."
+  [permissions]
+  (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %)))))
+
+
+(defn singularise
+  "Attempt to construct an idiomatic English-language singular of this string."
+  [string]
+  (cond
+    (.endsWith string "ss") string
+    (.endsWith string "ise") string
+    true
+    (s/replace
+      (s/replace
+        (s/replace
+          (s/replace string #"_" "-")
+          #"s$" "")
+        #"se$" "s")
+      #"ie$" "y")))
+
+
+(defn capitalise
+  "Return a string like `s` but with each token capitalised."
+  [s]
+  (s/join
+    " "
+    (map
+      #(apply str (cons (Character/toUpperCase (first %)) (rest %)))
+      (s/split s #"[ \t\r\n]+"))))
+
+
+(defn pretty-name
+  [entity]
+  (capitalise (singularise (:name (:attrs entity)))))
+
+
+(defn safe-name
+  "Return a safe name for the object `o`, given the specified `convention`.
+  `o` is expected to be either a string or an entity."
+  ([o]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)))
+     (s/replace (str o) #"[^a-zA-Z0-9-]" "")))
+  ([o convention]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)) convention)
+     (let [string (str o)]
+       (case convention
+         (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
+         :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+         :java (let
+                 [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+                 (apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
+         (safe-name string))))))
+
+
+(defmacro properties
+  "Return all the properties of this `entity`."
+  [entity]
+  `(children-with-tag ~entity :property))
+
+
+(defn descendants-with-tag
+  "Return all descendants of this `element`, recursively, which have this `tag`."
+  [element tag]
+  (flatten
+    (remove
+      empty?
+      (cons
+        (children element #(= (:tag %) tag))
+        (map
+          #(descendants-with-tag % tag)
+          (children element))))))
+
+
+(defn find-permissions
+  "Return appropriate the permissions of the first of these `elements` which
+  has permissions."
+  [& elements]
+  (first
+    (remove
+      empty?
+      (map
+        #(children-with-tag % :permission)
+        elements))))
+
+
+(defn insertable?
+  "Return `true` it the value of this `property` may be set from user-supplied data."
+  [property]
+  (and
+    (= (:tag property) :property)
+    (not (#{"link"} (:type (:attrs property))))
+    (not (= (:distinct (:attrs property)) "system"))))
+
+
+(defmacro all-properties
+  "Return all properties of this `entity` (including key properties)."
+  [entity]
+  `(descendants-with-tag ~entity :property))
+
+
+(defn user-distinct-properties
+  "Return the properties of this `entity` which are user distinct"
+  [entity]
+  (filter #(#{"user" "all"} (:distinct (:attrs %))) (all-properties entity)))
+
+
+(defmacro insertable-properties
+  "Return all the properties of this `entity` (including key properties) into
+  which user-supplied data can be inserted"
+  [entity]
+  `(filter
+     insertable?
+     (all-properties ~entity)))
+
+
+(defmacro key-properties
+  [entity]
+  `(children-with-tag (first (children-with-tag ~entity :key)) :property))
+
+
+(defmacro insertable-key-properties
+  [entity]
+  `(filter insertable? (key-properties entity)))
+
+
+(defn link-table?
+  "Return true if this `entity` represents a link table."
+  [entity]
+  (let [properties (all-properties entity)
+        links (filter #(-> % :attrs :entity) properties)]
+    (= (count properties) (count links))))
+
+
+(defn key-names [entity]
+  (set
+    (remove
+      nil?
+      (map
+        #(:name (:attrs %))
+        (key-properties entity)))))
+
+
+(defn base-type
+  [property application]
+  (cond
+    (:typedef (:attrs property))
+    (:type
+      (:attrs
+        (child
+          application
+          #(and
+             (= (:tag %) :typedef)
+             (= (:name (:attrs %)) (:typedef (:attrs property)))))))
+    (:entity (:attrs property))
+    (:type
+      (:attrs
+        (first
+          (key-properties
+            (child
+              application
+              #(and
+                 (= (:tag %) :entity)
+                 (= (:name (:attrs %)) (:entity (:attrs property)))))))))
+    true
+    (:type (:attrs property))))
+
+
+(defn is-quotable-type?
+  "True if the value for this field should be quoted."
+  [property application]
+  (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application)))
+
+
+(defn has-primary-key? [entity]
+  (> (count (key-names entity)) 0))
+
+
+(defn has-non-key-properties? [entity]
+  (>
+    (count (all-properties entity))
+    (count (key-properties entity))))
+
+
+(defn distinct-properties
+  [entity]
+  (filter
+    #(#{"system" "all"} (:distinct (:attrs %)))
+    (properties entity)))
+
+(defn path-part
+  "Return the URL path part for this `form` of this `entity` within this `application`.
+  Note that `form` may be a Clojure XML representation of a `form`, `list` or `page`
+  ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the
+  first child of the `entity` of the specified type will be used."
+  [form entity application]
+  (cond
+    (and (map? form) (#{:list :form :page} (:tag form)))
+  (s/join
+    "-"
+    (flatten
+      (list
+        (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
+    (keyword? form)
+    (path-part (first (children-with-tag entity form)) entity application)))
+
+
+(defn editor-name
+  "Return the path-part of the editor form for this `entity`. Note:
+  assumes the editor form is the first form listed for the entity."
+  [entity application]
+  (path-part :form entity application))
+
+
+(defn type-for-defined
+  [property application]
+  (:type (:attrs (typedef property application))))
diff --git a/test/adl_support/core_test.clj b/test/adl_support/core_test.clj
index d38730a..3f5f040 100644
--- a/test/adl_support/core_test.clj
+++ b/test/adl_support/core_test.clj
@@ -2,6 +2,21 @@
   (:require [clojure.test :refer :all]
             [adl-support.core :refer :all]))
 
-(deftest a-test
-  (testing "FIXME, I fail."
-    (is (= 0 1))))
+(deftest query-string-to-map-tests
+  (testing "conversion of query strings to maps"
+    (let [expected {}
+          actual (query-string-to-map nil)]
+      (is (= expected actual) "Nil arg"))
+    (let [expected {}
+          actual (query-string-to-map "")]
+      (is (= expected actual) "Empty string arg"))
+    (let [expected {:id 1}
+          actual (query-string-to-map "id=1")]
+      (is (= expected actual) "One integer value"))
+    (let [expected {:name "simon"}
+          actual (query-string-to-map "name=simon")]
+      (is (= expected actual) "One string value."))
+    (let [expected {:name "simon" :id 1}
+          actual (query-string-to-map "id=1&name=simon")]
+      (is (= expected actual) "One string value, one integer. Order of pairs might be reversed, and that's OK"))
+    ))
diff --git a/test/adl_support/tags_test.clj b/test/adl_support/tags_test.clj
new file mode 100644
index 0000000..578deed
--- /dev/null
+++ b/test/adl_support/tags_test.clj
@@ -0,0 +1,50 @@
+(ns adl-support.tags-test
+  (:require [clojure.test :refer :all]
+            [adl-support.tags :refer :all]
+            [selmer.parser :as parser]))
+
+(add-tags)
+
+(deftest if-member-of-tests
+  (testing "testing the if-member-of tag"
+    (let [expected "boo"
+          actual (if-member-of-permitted nil nil "caramba" "boo")]
+      (is (= expected actual) "Nil args, nil "))
+    (let [expected "boo"
+          actual (if-member-of-permitted nil {:user-roles #{"admin"}} "caramba" "boo")]
+      (is (= expected actual) "Nil args, one user-group"))
+    (let [expected "boo"
+          actual (if-member-of-permitted '("public") {:user-roles #{"admin"}} "caramba" "boo")]
+      (is (= expected actual) "One arg, one non-matching user-group"))
+    (let [expected "caramba"
+          actual (if-member-of-permitted '("admin") {:user-roles #{"admin"}} "caramba" "boo")]
+      (is (= expected actual) "One arg, one matching user-group"))
+    (let [expected "boo"
+          actual (if-member-of-permitted '("public") {:user-roles #{"admin" "canvassers"}} "caramba" "boo")]
+      (is (= expected actual) "One arg, two non-matching user-roles"))
+    (let [expected "caramba"
+          actual (if-member-of-permitted '("admin") {:user-roles #{"admin" "canvassers"}} "caramba" "boo")]
+      (is (= expected actual) "One arg, two user-roles, first one matching"))
+    (let [expected "caramba"
+          actual (if-member-of-permitted '("admin") {:user-roles #{"canvassers" "admin"}} "caramba" "boo")]
+      (is (= expected actual) "One arg, two user-roles, second one matching"))
+    (let [expected "caramba"
+          actual (if-member-of-permitted '("admin" "public") {:user-roles #{"admin"}} "caramba" "boo")]
+      (is (= expected actual) "Two args, one user-group, first arg matches"))
+    (let [expected "caramba"
+          actual (if-member-of-permitted '("public" "admin") {:user-roles #{"admin"}} "caramba" "boo")]
+      (is (= expected actual) "Two args, one user-group, second arg matches"))
+    (let [expected "not-permitted"
+          actual (parser/render
+                   "{% ifmemberof public canvassers %}permitted{% else %}not-permitted{% endifmemberof %}"
+                   {:user-roles #{"admin"}})]
+      (is (= expected actual) "Two args, one non-matching user-group"))
+    (let [expected "permitted"
+          actual (parser/render
+                   "{% ifmemberof public canvassers %}permitted{% else %}not-permitted{% endifmemberof %}"
+                   {:user-roles #{"canvassers"}})]
+      (is (= expected actual) "Two args, one matching user-group"))
+    ))
+
+
+