SL/Helper/UserPreferences.pm

   1 package SL::Helper::UserPreferences;
   2
   3 use strict;
   4 use parent qw(Rose::Object);
   5 use version;
   6
   7 use SL::DBUtils qw(selectall_hashref_query selectfirst_hashref_query do_query selectall_ids);
   8
   9 use Rose::Object::MakeMethods::Generic (
  10  'scalar --get_set_init' => [ qw(login namespace upgrade_callbacks current_version auto_store_back) ],
  11 );
  12
  13 sub store {
  14   my ($self, $key, $value) = @_;
  15
  16   my $tuple = $self->get_tuple($key);
  17
  18   if ($tuple) {
  19     $tuple->{value}  = $value;
  20     $self->_update($tuple);
  21   } else {
  22     my $query = 'INSERT INTO user_preferences (login, namespace, version, key, value) VALUES (?, ?, ?, ?, ?)';
  23     do_query($::form, $::form->get_standard_dbh, $query, $self->login, $self->namespace, $self->current_version, $key, $value);
  24   }
  25 }
  26
  27 sub get {
  28   my ($self, $key) = @_;
  29
  30   my $tuple = $self->get_tuple($key);
  31
  32   $tuple ? $tuple->{value} : undef;
  33 }
  34
  35 sub get_tuple {
  36   my ($self, $key) = @_;
  37
  38   my $tuple = selectfirst_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
  39     SELECT * FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
  40
  41   if ($tuple && $tuple->{version} < $self->current_version) {
  42     $self->_upgrade($tuple);
  43   }
  44
  45   if ($tuple && $tuple->{version} > $self->current_version) {
  46     die "Future version $tuple->{version} for user preference @{ $self->namespace }/$key. Expected @{ $self->current_version } or less.";
  47   }
  48
  49   return $tuple;
  50 }
  51
  52 sub get_all {
  53   my ($self) = @_;
  54
  55   my $data = selectall_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
  56     SELECT * FROM user_preferences WHERE login = ? AND namespace = ?
  57
  58   for my $tuple (@$data) {
  59     if ($tuple->{version} < $self->current_version) {
  60       $self->_upgrade($tuple);
  61     }
  62
  63     if ($tuple->{version} > $self->current_version) {
  64       die "Future version $tuple->{version} for user preference @{ $self->namespace }/$tuple->{key}. Expected @{ $self->current_version } or less.";
  65     }
  66   }
  67
  68   return $data;
  69 }
  70
  71 sub get_keys {
  72   my ($self) = @_;
  73
  74   my @keys = selectall_ids($::form, $::form->get_standard_dbh, <<"", 0, $self->login, $self->namespace);
  75     SELECT key FROM user_preferences WHERE login = ? AND namespace = ?
  76
  77   return @keys;
  78 }
  79
  80 sub delete {
  81   my ($self, $key) = @_;
  82
  83   die 'delete without  key is not allowed, use delete_all instead' unless $key;
  84
  85   my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
  86     DELETE FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
  87
  88 }
  89
  90 sub delete_all {
  91   my ($self, $key) = @_;
  92
  93   my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
  94     DELETE FROM user_preferences WHERE login = ? AND namespace = ?
  95
  96 }
  97
  98 ### internal stuff
  99
 100 sub _upgrade {
 101   my ($self, $tuple) = @_;
 102
 103   for my $to_version (sort { $a <=> $b } grep { $_ > $tuple->{version} } keys %{ $self->upgrade_callbacks }) {
 104     $tuple->{value}   = $self->upgrade_callbacks->{$to_version}->($tuple->{value});
 105     $tuple->{version} = $to_version;
 106   }
 107
 108   if ($self->auto_store_back) {
 109     $self->_update($tuple);
 110   }
 111 }
 112
 113 sub _update {
 114   my ($self, $tuple) = @_;
 115
 116   my $query = 'UPDATE user_preferences SET version = ?, value = ? WHERE id = ?';
 117   do_query($::form, $::form->get_standard_dbh, $query, $tuple->{version}, $tuple->{value}, $tuple->{id});
 118 }
 119
 120 ### defaults stuff
 121
 122 sub init_login             { SL::DB::Manager::Employee->current->login    }
 123 sub init_namespace         { ref $_[0]                                    }
 124 sub init_upgrade_callbacks { +{}                                          }
 125 sub init_current_version   { version->parse((ref $_[0])->VERSION)->numify }
 126 sub init_auto_store_back   { 1                                            }
 127
 128 1;
 129
 130 __END__
 131
 132 =encoding utf-8
 133
 134 =head1 NAME
 135
 136 SL::Helper::UserPreferences - user based preferences store
 137
 138 =head1 SYNOPSIS
 139
 140   use SL::Helper::UserPreferences;
 141   my $user_pref = SL::Helper::UserPreferences->new(
 142     login             => $login,        # defaults to current user
 143     namespace         => $namespace,    # defaults to current package
 144     upgrade_callbacks => $upgrade_callbacks,
 145     current_version   => $version,      # defaults to __PACKAGE__->VERSION->numify
 146     auto_store_back   => 0,             # default 1
 147   );
 148
 149   $user_pref->store($key, $value);
 150   my $val    = $user_pref->get($key);
 151   my $tuple  = $user_pref->get_tuple($key);
 152   my $tuples = $user_pref->get_all;
 153   my $keys   = $user_pref->get_keys;
 154   $user_pref->delete($key);
 155   $user_pref->delete_all;
 156
 157 =head1 DESCRIPTION
 158
 159 This module provides a generic storage for information that needs to be stored
 160 between sessions per user and per client and between versions of the program.
 161
 162 The storage can be accessed as a generic key/value dictionary, but also
 163 requires a namespace to avoid clashes and a version of the information.
 164 Additionally you must provide means to upgrade or invalidate stored information
 165 that is out of date, i.e. after a program upgrade.
 166
 167 =head1 FUNCTIONS
 168
 169 =over 4
 170
 171 =item C<new PARAMS>
 172
 173 Creates a new instance. Available C<PARAMS>:
 174
 175 =over 4
 176
 177 =item C<login>
 178
 179 The user for this storage. Defaults to current user login.
 180
 181 =item C<namespace>
 182
 183 A unique namespace. Defaults to the calling package.
 184
 185 =item C<upgrade_callbacks>
 186
 187 A hashref with version numbers as keys and subs as values. These subs are
 188 expected to take a value and return an upgraded value for the version of their
 189 key.
 190
 191 No default. Mandatory.
 192
 193 =item C<current_version>
 194
 195 The version object that is considered current for stored information. Defaults
 196 to the version of the calling package. MUST be a number, and not a version
 197 object, so that versions can be used as hash keys in the ugrade_callbacks.
 198
 199 =item C<auto_store_back>
 200
 201 An otional flag indicating whether values from the database that were upgraded to a
 202 newer version should be stored back automatically. Defaults to
 203 C<$::lx_office_conf{debug}{auto_store_back_upgraded_user_preferences}> which in
 204 turn defaults to true.
 205
 206 =back
 207
 208 =item C<store KEY VALUE>
 209
 210 Stores a key-value tuple. If there exists already a value for this key, it will
 211 be overwritten.
 212
 213 =item C<get KEY>
 214
 215 Retrieves a value.
 216
 217 Returns the value. If no such value exists returns undef instead.
 218
 219 This is for easy of use, and does no distinction between non-existing values
 220 and valid undefined values. Use C<get_tuple> if you need this.
 221
 222 =item C<get_tuple KEY>
 223
 224 Retrieves a key-value tuple.
 225
 226 Returns a hashref with C<key> and C<value> entries. If no such value
 227 exists returns undef instead.
 228
 229 =item C<get_all>
 230
 231 Retrieve all key-value tuples in this namespace and user.
 232
 233 Returns an arrayref of hashrefs.
 234
 235 =item C<get_keys>
 236
 237 Retrieve all keys for this namespace. Note: Unless you store vast amount of
 238 data, it's most likely easier to just C<get_all>.
 239
 240 Returns an arrayref of keys.
 241
 242 =item C<delete KEY>
 243
 244 Deletes a tuple.
 245
 246 =item C<delete_all>
 247
 248 Delete all tuples for this namespace and user.
 249
 250 =back
 251
 252 =head1 VERSIONING
 253
 254 Every entry in the user prefs must have a version to be compatible in case of
 255 code upgrades.
 256
 257 Code reading user prefs must check if the version is the expected one, and must
 258 have upgrade code to upgrade out of date preferences to the current version.
 259
 260 Code SHOULD write the upgraded version back to the store at the earliest time
 261 to keep preferences up to date. This should be able to be disabled to have
 262 developer versions not overwrite preferences with unsupported versions.
 263
 264 Example:
 265
 266 Initial code dealing with prefs:
 267
 268   our $VERSION = v1;
 269
 270   $user_prefs->store("selected tab", $::form->{selected_tab});
 271
 272 And the someone edits the code and removes the tab "Webdav". To ensure
 273 favorites with webdav selected are upgraded:
 274
 275   our $VERSION = v2;
 276
 277   my $upgrade_callbacks = {
 278     2 => sub { $_[0] eq 'WebDav' ? 'MasterData' : $_[0]; },
 279   };
 280
 281   my $val = $user_prefs->get("selected tab");
 282
 283 =head1 LACK OF TYPING
 284
 285 This controller will not attempt to preserve types. All data will be
 286 stringified. If your code needs to preserve numbers, you MUST encode the data
 287 to JSON or YAML before storing.
 288
 289 =head1 PLANNED BEST PRACTICE
 290
 291 To be able to decouple controllers and the schema upgrading required for this,
 292 there should be exactly one module responsible for managing user preferences for
 293 each namespace. You should find the corresponding preferences owners in the
 294 class namespace C<SL::Helper::UserPreferences>.
 295
 296 For example the namespace C<PartsSearchFavorites> should only be managed by
 297 C<SL::Helper::UserPreferences::PartsSearchFavorites>. This way, it's possible
 298 to keep the upgrades in one place, and to migrate upgrades out of there into
 299 database upgrades during major releases. They also don't clutter up
 300 controllers.
 301
 302 It is planned to strip all modules located there of their upgrade for a release
 303 and do automatic database upgrades.
 304
 305 To avoid version clashes when developing customer branches, please only use
 306 stable version bumps in the unstable branch, and use dev versions in customer
 307 branches.
 308
 309 =head1 BEHAVIOUR
 310
 311 =over 4
 312
 313 =item *
 314
 315 If a (namepace, key) tuple exists, a store will overwrite the last version
 316
 317 =item *
 318
 319 If the value retrieved from the database is newer than the code version, an
 320 error must be thrown.
 321
 322 =item *
 323
 324 get will check the version against the current version and apply all upgrade
 325 steps.
 326
 327 =item *
 328
 329 If the final step is not the current version, behaviour is undefined
 330
 331 =item *
 332
 333 get_all will always return scalar context.
 334
 335 =back
 336
 337 =head1 TODO AND SPECIAL CASES
 338
 339 * not defined whether it should be possible to retrieve the version of a tuple
 340
 341 * it's not specified how to return invalidation from upgrade, nor how to handle
 342   that
 343
 344 * it's not specified whether admin is a user. for now it dies.
 345
 346 * We're missing user agnostic methods for database upgrades
 347
 348 =head1 BUGS
 349
 350 None yet :)
 351
 352 =head1 AUTHOR
 353
 354 Sven Schöling <s.schoeling@linet-services.de>
 355
 356 =cut