UserPreferences: erste version

diff --git a/SL/Helper/UserPreferences.pm b/SL/Helper/UserPreferences.pm
new file mode 100644 (file)
index 0000000..1fea9e7
--- /dev/null
+++ b/SL/Helper/UserPreferences.pm
@@ -0,0 +1,356 @@
+package SL::Helper::UserPreferences;
+
+use strict;
+use parent qw(Rose::Object);
+use version;
+
+use SL::DBUtils qw(selectall_hashref_query selectfirst_hashref_query do_query selectall_ids);
+
+use Rose::Object::MakeMethods::Generic (
+ 'scalar --get_set_init' => [ qw(login namespace upgrade_callbacks current_version auto_store_back) ],
+);
+
+sub store {
+  my ($self, $key, $value) = @_;
+
+  my $tuple = $self->get_tuple($key);
+
+  if ($tuple) {
+    $tuple->{value}  = $value;
+    $self->_update($tuple);
+  } else {
+    my $query = 'INSERT INTO user_preferences (login, namespace, version, key, value) VALUES (?, ?, ?, ?, ?)';
+    do_query($::form, $::form->get_standard_dbh, $query, $self->login, $self->namespace, $self->current_version, $key, $value);
+  }
+}
+
+sub get {
+  my ($self, $key) = @_;
+
+  my $tuple = $self->get_tuple($key);
+
+  $tuple ? $tuple->{value} : undef;
+}
+
+sub get_tuple {
+  my ($self, $key) = @_;
+
+  my $tuple = selectfirst_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
+    SELECT * FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
+
+  if ($tuple && $tuple->{version} < $self->current_version) {
+    $self->_upgrade($tuple);
+  }
+
+  if ($tuple && $tuple->{version} > $self->current_version) {
+    die "Future version $tuple->{version} for user preference @{ $self->namespace }/$key. Expected @{ $self->current_version } or less.";
+  }
+
+  return $tuple;
+}
+
+sub get_all {
+  my ($self) = @_;
+
+  my $data = selectall_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
+    SELECT * FROM user_preferences WHERE login = ? AND namespace = ?
+
+  for my $tuple (@$data) {
+    if ($tuple->{version} < $self->current_version) {
+      $self->_upgrade($tuple);
+    }
+
+    if ($tuple->{version} > $self->current_version) {
+      die "Future version $tuple->{version} for user preference @{ $self->namespace }/$tuple->{key}. Expected @{ $self->current_version } or less.";
+    }
+  }
+
+  return $data;
+}
+
+sub get_keys {
+  my ($self) = @_;
+
+  my @keys = selectall_ids($::form, $::form->get_standard_dbh, <<"", 0, $self->login, $self->namespace);
+    SELECT key FROM user_preferences WHERE login = ? AND namespace = ?
+
+  return @keys;
+}
+
+sub delete {
+  my ($self, $key) = @_;
+
+  die 'delete without  key is not allowed, use delete_all instead' unless $key;
+
+  my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
+    DELETE FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
+
+}
+
+sub delete_all {
+  my ($self, $key) = @_;
+
+  my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
+    DELETE FROM user_preferences WHERE login = ? AND namespace = ?
+
+}
+
+### internal stuff
+
+sub _upgrade {
+  my ($self, $tuple) = @_;
+
+  for my $to_version (sort { $a <=> $b } grep { $_ > $tuple->{version} } keys %{ $self->upgrade_callbacks }) {
+    $tuple->{value}   = $self->upgrade_callbacks->{$to_version}->($tuple->{value});
+    $tuple->{version} = $to_version;
+  }
+
+  if ($self->auto_store_back) {
+    $self->_update($tuple);
+  }
+}
+
+sub _update {
+  my ($self, $tuple) = @_;
+
+  my $query = 'UPDATE user_preferences SET version = ?, value = ? WHERE id = ?';
+  do_query($::form, $::form->get_standard_dbh, $query, $tuple->{version}, $tuple->{value}, $tuple->{id});
+}
+
+### defaults stuff
+
+sub init_login             { SL::DB::Manager::Employee->current->login    }
+sub init_namespace         { ref $_[0]                                    }
+sub init_upgrade_callbacks { +{}                                          }
+sub init_current_version   { version->parse((ref $_[0])->VERSION)->numify }
+sub init_auto_store_back   { 1                                            }
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+SL::Helper::UserPreferences - user based preferences store
+
+=head1 SYNOPSIS
+
+  use SL::Helper::UserPreferences;
+  my $user_pref = SL::Helper::UserPreferences->new(
+    login             => $login,        # defaults to current user
+    namespace         => $namespace,    # defaults to current package
+    upgrade_callbacks => $upgrade_callbacks,
+    current_version   => $version,      # defaults to __PACKAGE__->VERSION->numify
+    auto_store_back   => 0,             # default 1
+  );
+
+  $user_pref->store($key, $value);
+  my $val    = $user_pref->get($key);
+  my $tuple  = $user_pref->get_tuple($key);
+  my $tuples = $user_pref->get_all;
+  my $keys   = $user_pref->get_keys;
+  $user_pref->delete($key);
+  $user_pref->delete_all;
+
+=head1 DESCRIPTION
+
+This module provides a generic storage for information that needs to be stored
+between sessions per user and per client and between versions of the program.
+
+The storage can be accessed as a generic key/value dictionary, but also
+requires a namespace to avoid clashes and a version of the information.
+Additionally you must provide means to upgrade or invalidate stored information
+that is out of date, i.e. after a program upgrade.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<new PARAMS>
+
+Creates a new instance. Available C<PARAMS>:
+
+=over 4
+
+=item C<login>
+
+The user for this storage. Defaults to current user login.
+
+=item C<namespace>
+
+A unique namespace. Defaults to the calling package.
+
+=item C<upgrade_callbacks>
+
+A hashref with version numbers as keys and subs as values. These subs are
+expected to take a value and return an upgraded value for the version of their
+key.
+
+No default. Mandatory.
+
+=item C<current_version>
+
+The version object that is considered current for stored information. Defaults
+to the version of the calling package. MUST be a number, and not a version
+object, so that versions can be used as hash keys in the ugrade_callbacks.
+
+=item C<auto_store_back>
+
+An otional flag indicating whether values from the database that were upgraded to a
+newer version should be stored back automatically. Defaults to
+C<$::lx_office_conf{debug}{auto_store_back_upgraded_user_preferences}> which in
+turn defaults to true.
+
+=back
+
+=item C<store KEY VALUE>
+
+Stores a key-value tuple. If there exists already a value for this key, it will
+be overwritten.
+
+=item C<get KEY>
+
+Retrieves a value.
+
+Returns the value. If no such value exists returns undef instead.
+
+This is for easy of use, and does no distinction between non-existing values
+and valid undefined values. Use C<get_tuple> if you need this.
+
+=item C<get_tuple KEY>
+
+Retrieves a key-value tuple.
+
+Returns a hashref with C<key> and C<value> entries. If no such value
+exists returns undef instead.
+
+=item C<get_all>
+
+Retrieve all key-value tuples in this namespace and user.
+
+Returns an arrayref of hashrefs.
+
+=item C<get_keys>
+
+Retrieve all keys for this namespace. Note: Unless you store vast amount of
+data, it's most likely easier to just C<get_all>.
+
+Returns an arrayref of keys.
+
+=item C<delete KEY>
+
+Deletes a tuple.
+
+=item C<delete_all>
+
+Delete all tuples for this namespace and user.
+
+=back
+
+=head1 VERSIONING
+
+Every entry in the user prefs must have a version to be compatible in case of
+code upgrades.
+
+Code reading user prefs must check if the version is the expected one, and must
+have upgrade code to upgrade out of date preferences to the current version.
+
+Code SHOULD write the upgraded version back to the store at the earliest time
+to keep preferences up to date. This should be able to be disabled to have
+developer versions not overwrite preferences with unsupported versions.
+
+Example:
+
+Initial code dealing with prefs:
+
+  our $VERSION = v1;
+
+  $user_prefs->store("selected tab", $::form->{selected_tab});
+
+And the someone edits the code and removes the tab "Webdav". To ensure
+favorites with webdav selected are upgraded:
+
+  our $VERSION = v2;
+
+  my $upgrade_callbacks = {
+    2 => sub { $_[0] eq 'WebDav' ? 'MasterData' : $_[0]; },
+  };
+
+  my $val = $user_prefs->get("selected tab");
+
+=head1 LACK OF TYPING
+
+This controller will not attempt to preserve types. All data will be
+stringified. If your code needs to preserve numbers, you MUST encode the data
+to JSON or YAML before storing.
+
+=head1 PLANNED BEST PRACTICE
+
+To be able to decouple controllers and the schema upgrading required for this,
+there should be exactly one module responsible for managing user preferences for
+each namespace. You should find the corresponding preferences owners in the
+class namespace C<SL::Helper::UserPreferences>.
+
+For example the namespace C<PartsSearchFavorites> should only be managed by
+C<SL::Helper::UserPreferences::PartsSearchFavorites>. This way, it's possible
+to keep the upgrades in one place, and to migrate upgrades out of there into
+database upgrades during major releases. They also don't clutter up
+controllers.
+
+It is planned to strip all modules located there of their upgrade for a release
+and do automatic database upgrades.
+
+To avoid version clashes when developing customer branches, please only use
+stable version bumps in the unstable branch, and use dev versions in customer
+branches.
+
+=head1 BEHAVIOUR
+
+=over 4
+
+=item *
+
+If a (namepace, key) tuple exists, a store will overwrite the last version
+
+=item *
+
+If the value retrieved from the database is newer than the code version, an
+error must be thrown.
+
+=item *
+
+get will check the version against the current version and apply all upgrade
+steps.
+
+=item *
+
+If the final step is not the current version, behaviour is undefined
+
+=item *
+
+get_all will always return scalar context.
+
+=back
+
+=head1 TODO AND SPECIAL CASES
+
+* not defined whether it should be possible to retrieve the version of a tuple
+
+* it's not specified how to return invalidation from upgrade, nor how to handle
+  that
+
+* it's not specified whether admin is a user. for now it dies.
+
+* We're missing user agnostic methods for database upgrades
+
+=head1 BUGS
+
+None yet :)
+
+=head1 AUTHOR
+
+Sven Schöling <s.schoeling@linet-services.de>
+
+=cut

diff --git a/sql/Pg-upgrade2/user_preferences.sql b/sql/Pg-upgrade2/user_preferences.sql
new file mode 100644 (file)
index 0000000..d20beea
--- /dev/null
+++ b/sql/Pg-upgrade2/user_preferences.sql
@@ -0,0 +1,14 @@
+-- @tag: user_preferences
+-- @description: Benutzereinstellungen
+-- @depends: release_3_4_1
+-- @encoding: utf-8
+
+CREATE TABLE user_preferences (
+  id         SERIAL PRIMARY KEY,
+  login      TEXT NOT NULL,
+  namespace  TEXT NOT NULL,
+  version    NUMERIC(15,5),
+  key        TEXT NOT NULL,
+  value      TEXT,
+  UNIQUE (login, namespace, version, key)
+);

diff --git a/t/helper/user_preferencess.t b/t/helper/user_preferencess.t
new file mode 100644 (file)
index 0000000..8e68ff2
--- /dev/null
+++ b/t/helper/user_preferencess.t
@@ -0,0 +1,71 @@
+use Test::More;
+use Test::Exception;
+use Test::Deep qw(bag cmp_deeply);
+
+use strict;
+use lib 't';
+
+use Support::TestSetup;
+use_ok 'SL::Helper::UserPreferences';
+
+Support::TestSetup::login();
+
+my $prefs;
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1 ];
+
+
+$prefs->store('test1', "val");
+$prefs->store('test2', "val2");
+
+cmp_deeply [ $prefs->get_keys ], bag('test1', 'test2'), 'get_keys works';
+
+is $prefs->get('test1'), 'val', 'get works';
+is $prefs->get_tuple('test2')->{value}, 'val2', 'get tuple works';
+is $prefs->get_all->[1]{value}, 'val2', 'get all works';
+is scalar @{ $prefs->get_all }, 2, 'get all works 2';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [
+  current_version => 2,
+  upgrade_callbacks => {
+    2 => sub { my ($val) = @_; $val . ' in space!'; }
+  }
+];
+
+is $prefs->get('test1'), 'val in space!', 'upgrading works';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
+is $prefs->get('test1'), 'val in space!', 'auto store back works';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1, namespace => 'namespace2' ];
+is $prefs->get('test1'), undef, 'other namespace does not find prior data';
+
+$prefs->store('test1', "namespace2 test");
+is $prefs->get('test1'), 'namespace2 test', 'other namespace finds data with same key';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
+is $prefs->get('test1'), 'val in space!', 'original namepsace is not affected';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1, login => 'demo2' ];
+$prefs->store('test1', "login test");
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
+is $prefs->get('test1'), 'val in space!', 'original login is not affected';
+
+$prefs->store('test1', 'new value');
+is scalar @{ $prefs->get_all }, 2, 'storing an existing value overwrites';
+
+my @array = $prefs->get_all;
+is scalar @array, 1, 'get_all in list context returns 1 element';
+isa_ok $array[0], 'ARRAY', 'get_all in list context returns 1 arrayref';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1 ];
+dies_ok { $prefs->get('test1') } 'reading newer version dies';
+
+$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
+$prefs->delete('test1');
+is $prefs->get('test1'), undef, 'deleting works';
+
+$prefs->delete_all;
+is $prefs->get('test2'), undef, 'delete_all works';
+
+done_testing;