Moved utils into support.

This commit is contained in:
Simon Brooke 2018-06-20 09:23:02 +01:00
parent e43f3087d6
commit 1ccb368ab4
5 changed files with 591 additions and 27 deletions

View file

@ -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]
(if
(empty? query-string)
{}
(reduce
merge
(map
#(let [pair (split % #"=")
value (try
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))

View file

@ -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))

452
src/adl_support/utils.clj Normal file
View file

@ -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))))

View file

@ -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"))
))

View file

@ -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"))
))