File Coverage

lib/CallBackery/Config.pm
Criterion Covered Total %
statement 79 240 32.9
branch 8 58 13.7
condition 3 18 16.6
subroutine 16 28 57.1
pod 10 15 66.6
total 116 359 32.3


line stmt bran cond sub pod time code
1             # $Id: Config.pm 539 2013-12-09 22:28:11Z oetiker $
2             package CallBackery::Config;
3              
4             =head1 NAME
5              
6             CallBackery::Config - get parse configuration file for CallBackery
7              
8             =head1 SYNOPSIS
9              
10             use Nq::Config;
11             my $cfg = CallBackery::Config->new(file=>$file);
12             my $hash_ref = $cfg->cfgHash();
13             my $pod = $cfg->pod();
14              
15             =head1 DESCRIPTION
16              
17             CallBackery gets much of its configuration from this config file.
18              
19             =cut
20              
21 1     1   7 use Mojo::Base -base,-async_await, -signatures;
  1         2  
  1         8  
22 1     1   285 use CallBackery::Exception qw(mkerror);
  1         2  
  1         49  
23 1     1   5 use CallBackery::Translate qw(trm);
  1         1  
  1         50  
24 1     1   569 use Config::Grammar::Dynamic;
  1         8222  
  1         31  
25 1     1   7 use Carp;
  1         2  
  1         60  
26 1     1   586 use autodie;
  1         15808  
  1         5  
27 1     1   6982 use File::Spec;
  1         2  
  1         37  
28 1     1   576 use Locale::PO;
  1         4430  
  1         38  
29 1     1   9 use Mojo::Loader qw(load_class);
  1         2  
  1         58  
30 1     1   6 use Mojo::JSON qw(true false);
  1         24  
  1         51  
31 1     1   6 use Mojo::Exception;
  1         3  
  1         5561  
32              
33             =head2 file
34              
35             the name of the config file
36              
37             =cut
38              
39             has file => sub { croak "the file parameter is mandatory" };
40              
41             has secretFile => sub ($self) {
42             my $secretFile = $self->file.'.secret';
43             if (not -f $secretFile){
44             open my $rand, '>', $secretFile;
45             chmod 0600,$secretFile;
46             print $rand sprintf('%x%x',int(rand()*1e14),int(rand()*1e14));
47             close $rand;
48             chmod 0400,$secretFile;
49             }
50             return $secretFile;
51             };
52              
53             has app => sub { croak "the app parameter is mandatory" };
54              
55             has log => sub {
56             shift->app->log;
57             };
58              
59             =head2 cfgHash
60              
61             a hash containing the data from the config file
62              
63             =cut
64              
65             has cfgHash => sub {
66             my $self = shift;
67             my $cfg_file = shift;
68             my $parser = $self->makeParser();
69             my $cfg = $parser->parse($self->file, {encoding => 'utf8'}) or croak($parser->{err});
70             return $cfg;
71             };
72              
73             =head2 pod
74              
75             returns a pod documenting the config file
76              
77             =cut
78              
79             has pod => sub {
80             my $self = shift;
81             my $parser = $self->makeParser();
82             my $E = '=';
83             my $footer = <<"FOOTER";
84              
85             ${E}head1 COPYRIGHT
86              
87             Copyright (c) 2014 by OETIKER+PARTNER AG. All rights reserved.
88              
89             ${E}head1 AUTHOR
90              
91             Stobi\@oetiker.chE>
92             Sfritz.zaucker\@oetiker.chE>
93              
94             ${E}head1 HISTORY
95              
96             2014-01-11 to 1.0 first version
97             2014-04-29 fz 1.1 implement plugin path
98              
99             FOOTER
100             my $header = <<"HEADER";
101             ${E}head1 NAME
102              
103             callbackery.cfg - The Apliance FRONTEND Builder config file
104              
105             ${E}head1 SYNOPSIS
106              
107             *** BACKEND ***
108             log_file = /tmp/nw-tobi.log
109              
110             *** FRONTEND ***
111             logo = logo.png
112             spinner = myspinner.gif
113             logo_small = logo-small.png
114             title = Appliance Configurator
115              
116             ${E}head1 DESCRIPTION
117              
118             The afb.cfg provides all the info for afb and its gui modules to interact with your appliance.
119              
120             ${E}head1 CONFIGURATION
121              
122             HEADER
123             return $header.$parser->makepod().$footer;
124             };
125              
126             =head2 pluginPath
127              
128             array of name spaces to look for gui plugins
129              
130             =cut
131              
132             has pluginPath => sub { ['CallBackery::GuiPlugin']; };
133              
134             =head2 B('PluginModule')
135              
136             Find the given module in the F, load it and create a first instance.
137              
138             =cut
139              
140              
141             sub loadAndNewPlugin {
142 4     4 1 27 my $self = shift;
143 4         8 my $plugin = shift;
144              
145 4         8 my $module;
146             my $ok;
147 4         8 for my $path (@{$self->pluginPath}) {
  4         25  
148             #$self->log->debug("looking for $plugin in $path");
149 4 50       41 if (my $e = load_class "${path}::$plugin") {
150 0 0       0 die mkerror(3894,"Loading ${path}::$plugin: $e") if ref $e;
151             } else {
152 4         119 return "${path}::${plugin}"->new();
153             }
154             }
155 0         0 die mkerror(123, "Plugin Module $plugin not found");
156             };
157              
158             has grammar => sub {
159             my $self = shift;
160             my $pluginList = {};
161             my $pluginPath = $self->pluginPath;
162             for my $path (@INC){
163             for my $pPath (@$pluginPath) {
164             my @pDirs = split /::/, $pPath;
165             my $fPath = File::Spec->catdir($path, @pDirs, '*.pm');
166             for my $file (glob($fPath)) {
167             my ($volume, $modulePath, $moduleName) = File::Spec->splitpath($file);
168             $moduleName =~ s{\.pm$}{};
169             $pluginList->{$moduleName} = 'Plugin Module';
170             }
171             }
172             }
173             return {
174             _sections => [ qw(BACKEND FRONTEND FRONTEND-COLORS /PLUGIN:\s*\S+/)],
175             _mandatory => [qw(BACKEND FRONTEND)],
176             BACKEND => {
177             _doc => 'BACKEND Settings',
178             _vars => [ qw(log_file cfg_db sesame_user sesame_pass) ],
179             _mandatory => [ qw(cfg_db sesame_user sesame_user) ],
180             log_file => { _doc => 'write a log file to this location (unless in development mode)'},
181             cfg_db => { _doc => 'file to store the config database'},
182             sesame_user => { _doc => <<'DOC'},
183             In Open Sesame mode, one has to use this username to get access to the system.
184             The password you enter does not matter.
185             DOC
186             sesame_pass => { _doc => <<'DOC'},
187             Using sesame_user and sesame_pass, the system can always be accessed.
188             In default configuration sesame_pass is NOT set.
189             DOC
190             },
191             FRONTEND => {
192             _doc => 'Settings for the Web FRONTEND',
193             _vars => [ qw(logo logo_small logo_noscale spinner title initial_plugin company_name company_url company_support
194             hide_password hide_password_icon hide_release hide_company max_width
195             )
196             ],
197             logo => {
198             _doc => 'url for the logo brand the login sceen',
199             },
200             company_name => {
201             _doc => 'who created the app',
202             },
203             company_url => {
204             _doc => 'link to the company homepage'
205             },
206             max_width => {
207             _doc => 'maximum content width'
208             },
209             company_support => {
210             _doc => 'company support eMail'
211             },
212             logo_small => {
213             _doc => 'url for the small logo brand the UI',
214             },
215             logo_noscale => {
216             _doc => "don't scale logo on login window",
217             _re => '(yes|no|true|false)',
218             _re_error => 'pick yes or no OR true or false',
219             _sub => sub {
220             $_[0] = ($_[0] =~ /yes|true/) ? true : false;
221             return;
222             },
223             },
224             spinner => {
225             _doc => 'url for the busy animation spinner gif',
226             },
227             title => {
228             _doc => 'title string for the application'
229             },
230             initial_plugin => {
231             _doc => 'which tab should be active upon login ?'
232             },
233             hide_password => {
234             _doc => 'hide password field on login screen',
235             _re => '(yes|no|true|false)',
236             _re_error => 'pick yes or no OR true or false',
237             _sub => sub {
238             $_[0] = ($_[0] =~ /yes|true/) ? true : false;
239             return;
240             },
241             },
242             hide_password_icon => {
243             _doc => 'hide password icon on login screen',
244             _re => '(yes|no|true|false)',
245             _re_error => 'pick yes or no OR true or false',
246             _sub => sub {
247             $_[0] = ($_[0] =~ /yes|true/) ? true : false;
248             return;
249             },
250             },
251             hide_release => {
252             _doc => 'hide release string on login screen',
253             _re => '(yes|no|true|false)',
254             _re_error => 'pick yes or no OR true or false',
255             _sub => sub {
256             $_[0] = ($_[0] =~ /yes|true/) ? true : false;
257             return;
258             },
259             },
260             hide_company => {
261             _doc => 'hide company string on login screen',
262             _re => '(yes|no|true|false)',
263             _re_error => 'pick yes or no OR true or false',
264             _sub => sub {
265             $_[0] = ($_[0] =~ /yes|true/) ? true : false;
266             return;
267             },
268             },
269             },
270             'FRONTEND-COLORS' => {
271             _vars => [ '/[a-zA-Z]\S+/' ],
272             '/[a-zA-Z]\S+/' => {
273             _doc => <
274             Use this section to override any color key used in the qooxdoo simple theme as well as the following:
275             C,
276             C,
277             C,
278             C,
279             C,
280             C,
281             C,
282             C.
283             C.
284              
285             The keys can be set to standard web colors C or to other key names.
286             COLORKEYS_END
287             _example => <
288             ff0000
289             EXAMPLE_END
290             _sub => sub {
291             if ($_[0] =~ /^\s*([0-9a-f]{3,6})\s*$/i){
292             $_[0] = '#'.lc($1);
293             }
294             return undef;
295             }
296             }
297             },
298             '/PLUGIN:\s*\S+/' => {
299             _order => 1,
300             _doc => 'Plugins providing appliance specific funtionality',
301             _vars => [qw(module)],
302             _mandatory => [qw(module)],
303             module => {
304             _sub => sub {
305             eval {
306             $_[0] = $self->loadAndNewPlugin($_[0]);
307             };
308             if ($@){
309             return "Failed to load Plugin $_[0]: $@";
310             }
311             return undef;
312             },
313             _dyn => sub {
314             my $var = shift;
315             my $module = shift;
316             $module = $self->loadAndNewPlugin($module) if not ref $module;
317             my $tree = shift;
318             my $grammar = $module->grammar();
319             push @{$grammar->{_vars}}, 'module';
320             for my $key (keys %$grammar){
321             $tree->{$key} = $grammar->{$key};
322             }
323             },
324             _dyndoc => $pluginList,
325             },
326             }
327             };
328             };
329              
330             sub makeParser {
331 1     1 0 2 my $self = shift;
332 1         24 my $parser = Config::Grammar::Dynamic->new($self->grammar);
333 1         19 return $parser;
334             }
335              
336             =head2 getTranslations
337              
338             Load translations from po files
339              
340             =cut
341              
342             sub getTranslations {
343 1     1 1 6 my $self = shift;
344 1   50     6 my $cfg = shift || {};
345 1         2 my %lx;
346 1   33     9 my $path = $cfg->{path} // $self->app->home->rel_file("share");
347 1         139 my $po = new Locale::PO();
348 1         68 for my $file (glob(File::Spec->catdir($path, '*.po'))) {
349 0         0 my ($volume, $localePath, $localeName) = File::Spec->splitpath($file);
350 0         0 my $locale = $localeName;
351 0         0 $locale =~ s/\.po$//;
352 0         0 my $lang = $locale;
353 0         0 $lang =~ s/_.+//;
354 0         0 local $_; # since load_file_ashash modifies $_ and does not localize it
355 0         0 my $href = Locale::PO->load_file_ashash($file, 'utf8');
356 0         0 for my $key (keys %$href) {
357 0         0 my $o = $href->{$key};
358 0         0 my $id = $po->dequote($o->msgid);
359 0         0 my $str = $po->dequote($o->msgstr);
360 0 0       0 next unless $id;
361 0         0 $lx{$locale}{$id} = $str;
362             }
363             }
364 1         86 return \%lx;
365             }
366              
367             =head2 postProcessCfg
368              
369             Post process the configuration data into a format that is easily used
370             by the application.
371              
372             =cut
373              
374             sub postProcessCfg {
375 1     1 1 13 my $self = shift;
376 1         4 my $cfg = $self->cfgHash;
377             # only postprocess once
378 1 50       7 return $cfg if $cfg->{PLUGIN}{list};
379 1         3 my %plugin;
380             my @pluginOrder;
381 1         11 for my $section (sort keys %$cfg){
382 7         13 my $sec = $cfg->{$section};
383 7 100       20 next unless ref $sec eq 'HASH'; # skip non hash stuff
384 6         16 for my $key (keys %$sec){
385 17 50 33     43 next unless ref $sec->{$key} eq 'HASH' and $sec->{$key}{_text};
386 0         0 $sec->{$key} = $sec->{$key}{_text};
387             }
388 6 100       24 if ($section =~ /^PLUGIN:\s*(.+)/){
389 2         5 my $name = $1;
390 2         6 $pluginOrder[$sec->{_order}] = $name;
391 2         6 delete $sec->{_order};
392 2         8 my $obj = $cfg->{PLUGIN}{prototype}{$name} = $sec->{module};
393 2         3 delete $sec->{module};
394 2         23 $obj->config($sec);
395 2         25 $obj->name($name);
396 2         16 $obj->app($self->app);
397 2         45 $obj->massageConfig($cfg);
398             # cleanup the config
399 2         6 delete $cfg->{$section};
400             }
401 6         16 $cfg->{PLUGIN}{list} = \@pluginOrder;
402             }
403             # rename section
404             # delete returns the value of the deleted hash element
405 1 50       7 if (exists $cfg->{'FRONTEND-COLORS'}) {
406 1         6 $cfg->{FRONTEND}{COLORS} = $cfg->{'FRONTEND-COLORS'};
407 1         3 delete $cfg->{'FRONTEND-COLORS'};
408             }
409 1         7 $cfg->{FRONTEND}{TRANSLATIONS} = $self->getTranslations();
410 1         6 return $cfg;
411             }
412              
413             =head2 instantiatePlugin(pluginName,userObj,args)
414              
415             create a new instance of this plugin prototype
416              
417             =cut
418              
419             sub _getPluginObject {
420 0     0     my $self = shift;
421 0           my $name = shift;
422              
423 0           my $user = shift;
424 0           my $args = shift;
425              
426 0           my $prototype = $self->cfgHash->{PLUGIN}{prototype}{$name};
427              
428             # clean the name
429 0           $name =~ s/[^-_0-9a-z]/_/gi;
430 0 0         die mkerror(39943,"No prototype for $name")
431             if not defined $prototype;
432              
433 0   0       $prototype->new(
434             user => $user,
435             name => $prototype->name,
436             config => $prototype->config,
437             args => $args // {},
438             app => $self->app,
439             );
440             }
441              
442 0     0 0   async sub instantiatePlugin_p {
443 0           my $self = shift;
444 0           my $obj = $self->_getPluginObject(@_);
445 0           my $name = $obj->name;
446 0 0         die mkerror(39944,"No permission to access $name")
447             if not await $self->promisify($obj->checkAccess);
448 0           return $obj;
449             }
450              
451             sub instantiatePlugin {
452 0     0 1   my $self = shift;
453 0           my $obj = $self->_getPluginObject(@_);
454 0           my $name = $obj->name;
455 0 0         die mkerror(39944,"No permission to access $name")
456             if not $self->promiseDeath($obj->checkAccess);
457 0           return $obj;
458             }
459              
460             =head2 $configBlob = $cfg->getConfigBlob()
461              
462             return the configuration state of the system as a blob
463              
464             =cut
465              
466             has configPlugins => sub {
467             my $self = shift;
468             my $user = $self->app->userObject->new(app=>$self->app,userId=>'__CONFIG');
469             my $cfg = $self->cfgHash;
470             my @plugins;
471             for my $name (@{$cfg->{PLUGIN}{list}}){
472             my $obj = eval {
473             $self->instantiatePlugin($name,$user);
474             } or next;
475             push @plugins, $obj;
476             }
477             return \@plugins;
478             };
479              
480             sub getCrypt {
481 0     0 0   require Crypt::Rijndael;
482 0           my $self = shift;
483 0   0       my $password = substr((shift || '').('x' x 32),0,32);
484 0           return Crypt::Rijndael->new( $password,Crypt::Rijndael::MODE_CBC() );
485             }
486              
487             sub pack16 {
488 0     0 0   my $self = shift;
489 0           my $string = shift;
490 0           my $len = length($string);
491 0           my $mod = 16 - ($len % 16);
492 0           return sprintf("%016x%s",$len,$string.('x' x $mod));
493             }
494              
495             sub unpack16 {
496 0     0 0   my $self = shift;
497 0           my $string = shift;
498 0           my $len = substr($string,0,16);
499 0 0 0       if ( $len !~ /^[0-9a-f]{16}$/ or hex($len) > length($string)-16 ){
500 0           die mkerror(3844,trm("Wrong password!"));
501             }
502 0           return substr($string,16,hex($len));
503             }
504              
505             sub getConfigBlob {
506 0     0 1   my $self = shift;
507 0           my $password = shift;
508 0           require Archive::Zip;
509              
510 0           my $zip = Archive::Zip->new();
511 0           my $cfg = $self->cfgHash;
512             # flush all the changes in the database to the db file
513 0           my $dumpfile = '/tmp/cbdump'.$$;
514 0 0         unlink $dumpfile if -f $dumpfile;
515 0           open my $dump, '|-','/usr/bin/sqlite3',$cfg->{BACKEND}{cfg_db};
516 0           print $dump ".output $dumpfile\n";
517 0           print $dump ".dump\n";
518 0           close $dump;
519 0           $zip->addFile({
520             filename => $dumpfile,
521             zipName => '{DATABASEDUMP}',
522             });
523 0           for my $obj (@{$self->configPlugins}){
  0            
524 0           my $name = $obj->name;
525 0           for my $file (@{$obj->stateFiles}) {
  0            
526 0 0         if (-r $file){
527 0           $zip->addFile({
528             filename => $file,
529             zipName => '{PLUGINSTATE.'.$name.'}'.$file
530             })
531             }
532             }
533             }
534 0           my $zipData;
535 0           open(my $fh, ">", \$zipData);
536 0           $zip->writeToFileHandle($fh,0);
537              
538 0           my $crypt = $self->getCrypt($password);
539 0           return $crypt->encrypt($self->pack16($zipData));
540             }
541              
542             =head2 $cfg->restoreConfigBlob(configBlob)
543              
544             retore the confguration state
545              
546             =cut
547              
548             sub restoreConfigBlob {
549 0     0 1   my $self = shift;
550 0           my $config = shift;
551 0           my $password = shift;
552 0           require Archive::Zip;
553 0           my $crypt = $self->getCrypt($password);
554 0           $config = $self->unpack16($crypt->decrypt($config));
555              
556 0           my $cfg = $self->cfgHash;
557 0           my $user = $self->app->userObject->new(app=>$self->app,userId=>'__CONFIG');
558 0           open my $fh ,'<', \$config;
559 0           my $zip = Archive::Zip->new();
560 0           $zip->readFromFileHandle($fh);
561 0           my %stateFileCache;
562 0           for my $member ($zip->members){
563 0           for ($member->fileName){
564 0 0         /^\{DATABASE\}$/ && do {
565 0           $self->log->warn("Restoring Database!");
566 0           $self->app->database->mojoSqlDb->disconnect;
567 0           unlink glob $cfg->{BACKEND}{cfg_db}.'*';
568 0           $member->extractToFileNamed($cfg->{BACKEND}{cfg_db});
569 0           last;
570             };
571 0 0         /^\{DATABASEDUMP\}$/ && do {
572 0           $self->log->warn("Restoring Database Dump!");
573 0           $self->app->database->mojoSqlDb->disconnect;
574 0           unlink glob $cfg->{BACKEND}{cfg_db}.'*';
575 0           open my $sqlite, '|-', '/usr/bin/sqlite3',$cfg->{BACKEND}{cfg_db};
576 0           my $sql = $member->contents();
577 0           $sql =~ s/0$//; # for some reason the dump ends in 0
578 0           print $sqlite $sql;
579 0           close $sqlite;
580 0           last;
581             };
582 0 0         m/^\{PLUGINSTATE\.([^.]+)\}(.+)/ && do {
583 0           my $plugin = $1;
584 0           my $file = $2;
585 0 0         if (not $stateFileCache{$plugin}){
586 0           my $obj = eval {
587 0           $self->instantiatePlugin($plugin,$user);
588             };
589 0 0         if (not $obj){
590 0           $self->log->warn("Ignoring $file from plugin $plugin since the plugin is not available here.");
591 0           next;
592             }
593 0           $stateFileCache{$plugin} = { map { $_ => 1 } @{$obj->stateFiles} };
  0            
  0            
594             };
595 0 0         if ($stateFileCache{$plugin}{$file}){
596 0           $member->extractToFileNamed($file);
597             }
598             else {
599 0           $self->log->warn("Ignoring $file from archive since it is not listed in $plugin stateFiles.");
600             }
601             }
602             }
603             }
604 0           $self->reConfigure;
605             }
606              
607             =head2 $cfg->reConfigure()
608              
609             Regenerate all the template based configuration files using input from the database.
610              
611             =cut
612              
613             sub reConfigure {
614 0     0 1   my $self = shift;
615 0           my $secretFile = $self->secretFile;
616 0 0         if (not -f $secretFile){
617 0           open my $rand, '>', $secretFile;
618 0           chmod 0600,$secretFile;
619 0           print $rand sprintf('%x%x',int(rand()*1e14),int(rand()*1e14));
620 0           close $rand;
621 0           chmod 0400,$secretFile;
622             }
623 0           for my $obj (@{$self->configPlugins}){
  0            
624 0           $obj->reConfigure;
625             }
626             }
627              
628             =head2 $cfg->unConfigure()
629              
630             Restore the system to unconfigured state. By removing the
631             configuration database, unlinking all user supplied configuration
632             files and regenerating all template based configuration files with
633             empty input.
634              
635             =cut
636              
637             sub unConfigure {
638 1     1   10 no autodie;
  1         2  
  1         6  
639 0     0 1   my $self = shift;
640 0           my $cfg = $self->cfgHash;
641 0           $self->log->debug("unlinking config database ".$cfg->{BACKEND}{cfg_db});
642 0 0         unlink $cfg->{BACKEND}{cfg_db} if -f $cfg->{BACKEND}{cfg_db};
643 0           open my $gen, '>', $cfg->{BACKEND}{cfg_db}.'.flush';
644 0           close $gen;
645             #get 'clean' config files
646 0           $self->reConfigure();
647             # and now remove all state
648 0           for my $obj (@{$self->configPlugins}){
  0            
649 0           for my $file (@{$obj->stateFiles},@{$obj->unConfigureFiles}) {
  0            
  0            
650 0 0         next if not -f $file;
651 0           $self->log->debug('['.$obj->name."] unlinking $file");
652 0           unlink $file;
653             }
654             }
655 0 0 0       unlink $cfg->{BACKEND}{log_file} if defined $cfg->{BACKEND}{log_file} and -f $cfg->{BACKEND}{log_file} ;
656 0 0         unlink $self->secretFile if -f $self->secretFile;
657 0           system "sync";
658             }
659              
660             =head2 $cfg->promisify(xxx)
661              
662             always return a promise resolving to the value
663              
664             =cut
665              
666             sub promisify {
667 0     0 1   my $self = shift;
668 0           my $value = shift;
669 0 0         if (eval { blessed $value && $value->isa('Mojo::Promise') }){
  0 0          
670 0           return $value;
671             }
672 0           return Mojo::Promise->resolve($value,@_);
673             }
674              
675             =head2 $cfg->promiseDeath(xxx)
676              
677             die when there is a promise response
678              
679             =cut
680              
681             sub promiseDeath {
682 0     0 1   my $self = shift;
683 0           my $value = shift;
684 0 0         if (eval { blessed $value && $value->isa('Mojo::Promise') }){
  0 0          
685 0           Mojo::Exception->throw("unexpected promise respone!");
686             }
687 0           return $value;
688             }
689              
690              
691             1;
692              
693             __END__