From 529dd4532c780973438b0328b6650c34df22a4ba Mon Sep 17 00:00:00 2001 From: Bert Burgemeister Date: Thu, 19 Apr 2012 16:51:16 +0200 Subject: [PATCH] Selection of subset of images: CLI interface --- cli.lisp | 198 ++++++++++++++++++++++++++++++++++++++++++++++++++------- db-tables.lisp | 99 +++++++++++++++++++++++++++-- package.lisp | 5 ++ phoros.asd | 2 +- phoros.lisp | 4 +- 5 files changed, 278 insertions(+), 30 deletions(-) diff --git a/cli.lisp b/cli.lisp index 25cb8a1..d1f6aec 100644 --- a/cli.lisp +++ b/cli.lisp @@ -308,6 +308,23 @@ :type string :documentation "Path to a file containing the body of a PL/pgSQL trigger function. Any ocurrence of the strings ~0@*~A and ~1@*~A will be replaced by the name of the user point table/of the user line table respectively. Omit this option to reset that function to just emit a notice."))) +(defparameter cli:*image-attribute-options* + '(("create-image-attribute" + :type string :action #'cli:create-image-attribute-action + :documentation "(*) Store, for the specified presentation project, a PostgreSQL expression an HTTP client user can use to select some subset of the images available.") + ("delete-image-attribute" + :type string :action #'cli:delete-image-attribute-action + :documentation "(*) Delete from specified presentation project an image restriction identified by its tag.") + ("list-image-attribute" + :type string :optional t :action #'cli:list-image-attribute-action + :documentation "(*) List restricting PostgreSQL expressions for one presentation project if specified, or for all presentation projects if not. If --tag is specified, list only matching expressions.") + ("tag" + :type string + :documentation "Identifying tag for the restriction. Should be both short and descriptive as it is shown as a selectable item on HTTP client.") + ("sql-clause" + :type string + :documentation "Boolean PostgreSQL expression, to be used as an AND clause. Should yield FALSE for images that are to be excluded."))) + (defparameter cli:*aux-view-options* '(("create-aux-view" :type string :action #'cli:create-aux-view-action @@ -366,6 +383,7 @@ cli:*store-images-and-points-options* cli:*start-server-options* cli:*presentation-project-options* + cli:*image-attribute-options* cli:*aux-view-options* cli:*user-points-options* cli:*user-options*)) @@ -556,6 +574,27 @@ given." user lines. The former is associated with a trigger which may be defined to induce writing into the latter.") (show-help-section + cli:*image-attribute-options* + "Define Selectable Attributes For Images." + "HTTP client users can select classes of images defined here. + Attributes are defined as PostgreSQL expressions and may use the + following column names:" + ;; ... which are obtainable like so: + ;; SELECT column_name + ;; FROM information_schema.columns + ;; WHERE table_name = 'dat__aggregate'; + "recorded_device_id, device_stage_of_life_id, generic_device_id, + random, presentation_project_id, directory, measurement_id, + filename, byte_position, point_id, footprint, + footprint_device_stage_of_life_id, trigger_time, coordinates, + longitude, latitude, ellipsoid_height, cartesian_system, east_sd, + north_sd, height_sd, roll, pitch, heading, roll_sd, pitch_sd, + heading_sd, usable, sensor_width_pix, sensor_height_pix, + pix_size, bayer_pattern, color_raiser, mounting_angle, dx, dy, + dz, omega, phi, kappa, c, xh, yh, a1, a2, a3, b1, b2, c1, c2, r0, + b_dx, b_dy, b_dz, b_rotx, b_roty, b_rotz, b_ddx, b_ddy, b_ddz, + b_drotx, b_droty, b_drotz, nx, ny, nz, d.") + (show-help-section cli:*aux-view-options* "Connect A Presentation Project To A Table Of Auxiliary Data" (format nil @@ -755,9 +794,9 @@ given." :from 'sys-acquisition-project :natural :left-join 'sys-measurement) 'common-table-name 'measurement-id))))) - (cli:format-table - *standard-output* " | " content - "Acquisition Project" "ID" "Meas. ID" "Directory" "Cartesian CS"))))) + (cli:format-table *standard-output* content + '("Acquisition Project" "ID" "Meas. ID" + "Directory" "Cartesian CS")))))) (defun cli:store-images-and-points-action (common-table-name) "Put data into the data tables." @@ -1025,6 +1064,88 @@ trigger-time to stdout." measurement-id acquisition-project presentation-project-name database host port))) +(defun cli:create-image-attribute-action (presentation-project-name) + "Store a boolean SQL expression." + (cli:with-options (host port database (user "") (password "") use-ssl + log-dir + tag sql-clause) + (declare (ignore sql-clause)) + (launch-logger log-dir) + (with-connection (list database user password host :port port + :use-ssl (s-sql:from-sql-name use-ssl)) + (muffle-postgresql-warnings) + (multiple-value-bind (old-image-attribute + number-of-selected-images + total-number-of-images) + (apply #'create-image-attribute + presentation-project-name + :allow-other-keys t + (cli:remaining-options)) + (cl-log:log-message + :db-dat + "~:[Stored a fresh~;Updated an~] ~ + image attribute, tagged ~A, for presentation project ~A ~ + in database ~A at ~A:~D~ + ~0@*~@[, replacing the SQL clause previously stored there of ~S~]. ~ + ~6@*The new SQL clause currently selects ~D out of ~D images." + old-image-attribute + tag + presentation-project-name + database host port + number-of-selected-images total-number-of-images))))) + +(defun cli:delete-image-attribute-action (presentation-project-name) + "Remove SQL expression specified by presentation-project-name and tag." + (cli:with-options (host port database (user "") (password "") use-ssl + log-dir + tag) + (launch-logger log-dir) + (with-connection (list database user password host :port port + :use-ssl (s-sql:from-sql-name use-ssl)) + (muffle-postgresql-warnings) + (let ((replaced-sql-clause + (apply #'delete-image-attribute + presentation-project-name + :allow-other-keys t + (cli:remaining-options)))) + (cl-log:log-message + :db-dat + "~:[Tried to delete a nonexistent~;Deleted~] ~ + image attribute tagged ~A from ~ + presentation project ~A in database ~A at ~A:~D. ~ + ~0@*~@[Its SQL clause, now deleted, was ~S~]" + replaced-sql-clause tag presentation-project-name + database host port))))) + +(defun cli:list-image-attribute-action (&optional presentation-project-name) + "List boolean SQL expressions." + (cli:with-options (host port database (user "") (password "") use-ssl + tag) + (with-connection (list database user password host :port port + :use-ssl (s-sql:from-sql-name use-ssl)) + (let* ((presentation-project-name + (if (stringp presentation-project-name) + presentation-project-name + 'presentation-project-name)) + (restriction-id (or tag 'restriction-id)) + (content + (query + (:order-by + (:select 'presentation-project-name + 'sys-selectable-restriction.presentation-project-id + 'restriction-id + 'sql-clause + :from 'sys-selectable-restriction + :natural :left-join 'sys-presentation-project + :where (:and (:= presentation-project-name + 'presentation-project-name) + (:= restriction-id + 'restriction-id))) + 'presentation-project-name 'restriction-id)))) + (cli:format-table *standard-output* content + '("Presentation Project" "ID" "Tag" "SQL-clause") + :column-widths '(nil nil nil 60)))))) + (defun cli:redefine-trigger-function-action (presentation-project-name) "Recreate an SQL trigger function that is fired on changes to the user point table, and fire it once." @@ -1257,9 +1378,9 @@ projects." 'sys-presentation-project.presentation-project-id) (:= 'sys-user.user-id 'sys-user-role.user-id))) 'user-name))))) - (cli:format-table - *standard-output* " | " content - "User" "ID" "Password" "Full Name" "Presentation Project" "ID" "Role"))))) + (cli:format-table *standard-output* content + '("User" "ID" "Password" "Full Name" + "Presentation Project" "ID" "Role")))))) (defun cli:list-presentation-project-action (&optional presentation-project) "List content of presentation projects." @@ -1310,32 +1431,63 @@ projects." 'sys-acquisition-project.acquisition-project-id))) 'presentation-project-name 'sys-presentation.measurement-id))))) - (cli:format-table - *standard-output* " | " content - "Presentation Project" "ID" "Meas. ID" "Acquisition Project" "ID"))))) - -(defun cli:format-table (destination column-separator content - &rest column-headers) + (cli:format-table *standard-output* content + '("Presentation Project" "ID" "Meas. ID" + "Acquisition Project" "ID")))))) + +(defun cli:format-table (destination content column-headers &key + (column-separator " | ") + (header-separator #\-) + (column-widths (mapcar (constantly nil) + column-headers))) "Print content (a list of lists) to destination." - (let* ((rows - (append (list column-headers) (list ()) content)) + (let* ((rows (append (list column-headers) + (list (mapcar (constantly "") column-headers)) + content)) (number-of-rows (length column-headers)) (widths (loop - for column from 0 below number-of-rows collect - (loop - for row in rows - maximize (length (format nil "~A" (nth column row))))))) + for column from 0 below number-of-rows + collect (or (nth column column-widths) + (loop + for row in rows + maximize (length (format nil "~A" (nth column row)))))))) (setf (second rows) (loop for width in widths collect - (make-string width :initial-element #\-))) + (make-string width :initial-element header-separator))) + (setf rows + (loop + for row in rows + for i from 0 + nconc (cli:split-last-row (list row) widths))) (loop for row in rows do - (format destination "~&~{~VA~1,#^~A~}~%" - (loop - for width in widths and field in row - collect width collect field collect column-separator))))) + (format destination "~&~{~VA~1,#^~A~}~%" + (loop + for width in widths and field in row + collect width collect field collect column-separator))))) + +(defun cli:split-last-row (rows column-widths) + "If necessary, split fields of the last element of rows whose width +exceeds the respective column-width over multiple rows." + (let ((last-row (mapcar #'(lambda (x) (format nil "~A" x)) + (car (last rows))))) + (if (notany #'(lambda (field width) (> (length field) width)) + last-row + column-widths) + rows + (loop + for field in last-row + for column-width in column-widths + collect (subseq field 0 (min column-width (length field))) + into penultimate-row + collect (subseq field (min column-width (length field))) + into lowest-row + finally (return (nconc (butlast rows) + (list penultimate-row) + (cli:split-last-row (list lowest-row) + column-widths))))))) (defun cli:server-action (&rest rest) "Start the HTTP server." diff --git a/db-tables.lisp b/db-tables.lisp index 7b9eb40..6c1930a 100644 --- a/db-tables.lisp +++ b/db-tables.lisp @@ -149,21 +149,25 @@ :add :constraint "presentation-project-id-unique" :unique 'presentation-project-id)) -(defclass sys-selectable-restrictions () +(defclass sys-selectable-restriction () ((restriction-id :col-type text + :initarg :restriction-id :documentation "Short descriptive string; to be used for selection of restriction on client.") (presentation-project-id :col-type integer + :initarg :presentation-project-id :documentation "Presentation Project that is allowed to use the sql-clause.") (sql-clause :col-type text + :initarg :sql-clause + :reader sql-clause :documentation "SQL clause suitable as an AND clause in aggregate view.")) (:metaclass dao-class) - (:keys restriction-id presentation-project-id) + (:keys presentation-project-id restriction-id) (:documentation "User-selectable SQL AND clauses usable in the WHERE clause of aggregate view.")) -(deftable sys-selectable-restrictions +(deftable sys-selectable-restriction (!dao-def) (!foreign 'sys-presentation-project 'presentation-project-id :on-delete :cascade :on-update :cascade)) @@ -570,6 +574,15 @@ connected to match." Phoros, or use Phoros version ~2:*~D.x.x." (phoros-db-major-version) (phoros-version :major t))) +(defun presentation-project-id-from-name (presentation-project-name) + "Get from current database the presentation-project-id associated +with presentation-project-name. Signal error if there isn't any." + (let ((presentation-project (get-dao 'sys-presentation-project presentation-project-name))) + (assert presentation-project () + "There is no presentation project called ~A." + presentation-project-name) + (presentation-project-id presentation-project))) + (defun create-sys-tables () "Create in current database a set of sys-* tables, i.e. tables that are used by all projects. The database should probably be empty." @@ -577,7 +590,7 @@ are used by all projects. The database should probably be empty." (create-table 'sys-user) (create-table 'sys-acquisition-project) (create-table 'sys-presentation-project) - (create-table 'sys-selectable-restrictions) + (create-table 'sys-selectable-restriction) (create-table 'sys-user-role) (create-table 'sys-measurement) (create-table 'sys-presentation) @@ -1396,6 +1409,84 @@ wasn't any." (execute (:drop-table :if-exists (user-line-table-name project-name)))))) +(defun* create-image-attribute (presentation-project-name + &mandatory-key tag sql-clause) + "Store a boolean SQL expression into current database. Return SQL +expression previously stored for presentation-project-name and tag if +any; return nil otherwise. Second return value is the number of +images covered by the SQL expression, and third return value is the +total number of images in presentation project." + (assert-phoros-db-major-version) + (let* ((presentation-project-id + (presentation-project-id-from-name presentation-project-name)) + (old-selectable-restriction + (get-dao 'sys-selectable-restriction presentation-project-id tag)) + (common-table-names + (common-table-names presentation-project-id)) + (selected-restrictions-conjunction + (sql-where-conjunction (list sql-clause))) + (counting-selected-query + (sql-compile + `(:select + (:sum count) + :from + (:as (:union + ,@(loop + for common-table-name in common-table-names + for aggregate-view-name + = (aggregate-view-name common-table-name) + collect + `(:select + (:as (:count '*) 'count) + :from + ',aggregate-view-name + :where + (:and (:= 'presentation-project-id + ,presentation-project-id) + (:raw ,selected-restrictions-conjunction))))) + 'count)))) + (counting-total-query + (sql-compile + `(:select + (:sum count) + :from + (:as (:union + ,@(loop + for common-table-name in common-table-names + for aggregate-view-name + = (aggregate-view-name common-table-name) + collect + `(:select + (:as (:count '*) 'count) + :from + ',aggregate-view-name + :where + (:= 'presentation-project-id + ,presentation-project-id)))) + 'count)))) + (number-of-selected-images (query counting-selected-query :single!)) + (total-number-of-images (query counting-total-query :single!))) + (save-dao (make-instance 'sys-selectable-restriction + :presentation-project-id presentation-project-id + :restriction-id tag :sql-clause sql-clause)) + (values + (when old-selectable-restriction (sql-clause old-selectable-restriction)) + number-of-selected-images + total-number-of-images))) + +(defun* delete-image-attribute (presentation-project-name &mandatory-key tag) + "Delete SQL expression stored with tag under +presentation-project-name from current database. Return the SQL +expression deleted if there was any; return nil otherwise." + (assert-phoros-db-major-version) + (let ((selectable-restriction + (get-dao 'sys-selectable-restriction + (presentation-project-id-from-name presentation-project-name) + tag))) + (when selectable-restriction + (delete-dao selectable-restriction) + (sql-clause selectable-restriction)))) + (defun* create-user (name &key presentation-projects &mandatory-key diff --git a/package.lisp b/package.lisp index b0242d1..e055609 100644 --- a/package.lisp +++ b/package.lisp @@ -58,6 +58,7 @@ :*store-images-and-points-options* :*start-server-options* :*presentation-project-options* + :*image-attribute-options* :*aux-view-options* :*user-points-options* :*user-options* @@ -92,6 +93,9 @@ :create-presentation-project-action :delete-presentation-project-action :add-to-presentation-project-action + :create-image-attribute-action + :delete-image-attribute-action + :list-image-attribute-action :remove-from-presentation-project-action :redefine-trigger-function-action :create-aux-view-action @@ -102,4 +106,5 @@ :list-user-action :list-presentation-project-action :format-table + :split-last-row :server-action)) diff --git a/phoros.asd b/phoros.asd index 364f9b1..a41b110 100644 --- a/phoros.asd +++ b/phoros.asd @@ -21,7 +21,7 @@ interface. http://phoros.boundp.org" ;; There should be a corresponding git tag which marks the point this ;; version number becomes official. - "12.8.4" + "13.0.0" :licence ;goes with --licence output "Copyright (C) 2010, 2011, 2012 Bert Burgemeister diff --git a/phoros.lisp b/phoros.lisp index 37604aa..0595c44 100644 --- a/phoros.lisp +++ b/phoros.lisp @@ -426,7 +426,7 @@ current session." (json:encode-json-to-string (query (:select 'restriction-id - :from 'sys-selectable-restrictions + :from 'sys-selectable-restriction :where (:= 'presentation-project-id (hunchentoot:session-value 'presentation-project-id))) @@ -439,7 +439,7 @@ selected-restriction-ids." (query (sql-compile `(:select 'sql-clause - :from 'sys-selectable-restrictions + :from 'sys-selectable-restriction :where (:and (:= 'presentation-project-id ,presentation-project-id) (:or -- 2.11.4.GIT