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