[1] | 1 | package LATMOS::Accounts; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
[22] | 6 | use base qw(Config::IniFiles); |
---|
| 7 | use LATMOS::Accounts::Bases; |
---|
[50] | 8 | use LATMOS::Accounts::Synchro; |
---|
[56] | 9 | use LATMOS::Accounts::SynchAccess; |
---|
[255] | 10 | use LATMOS::Accounts::Log; |
---|
[320] | 11 | use LATMOS::Accounts::Acls; |
---|
[1] | 12 | |
---|
[1299] | 13 | our $VERSION = '4.0.7'; |
---|
[1] | 14 | |
---|
[255] | 15 | =head1 NAME |
---|
| 16 | |
---|
| 17 | LATMOS::Accounts - Core module for LATMOS account management tools |
---|
| 18 | |
---|
| 19 | =head1 DESCRITPTION |
---|
| 20 | |
---|
| 21 | =cut |
---|
| 22 | |
---|
[1041] | 23 | # Return the configuration directory according settings: |
---|
| 24 | # |
---|
[861] | 25 | sub _configdir { |
---|
| 26 | my ($self) = @_; |
---|
[1029] | 27 | $ENV{LA_CONFIG} || |
---|
| 28 | ($self || {})->{_configdir} || |
---|
| 29 | '/etc/latmos-accounts' |
---|
[861] | 30 | } |
---|
| 31 | |
---|
[255] | 32 | =head1 FUNCTION |
---|
| 33 | |
---|
[1042] | 34 | =head2 new($configdir, %options) |
---|
[255] | 35 | |
---|
| 36 | Instanciate a new LATMOS::Accounts object. |
---|
| 37 | |
---|
[1042] | 38 | C<$configdir> if defined is the directory containing files to use, |
---|
[861] | 39 | default to F</etc/latmos-accounts/>. |
---|
[255] | 40 | |
---|
[1042] | 41 | C<%options> can contains: |
---|
| 42 | |
---|
| 43 | =over 4 |
---|
| 44 | |
---|
| 45 | =item noacl |
---|
| 46 | |
---|
| 47 | If true, acls configuration are not load and code act like everything is |
---|
| 48 | allowed. |
---|
| 49 | |
---|
| 50 | This flag is usefull for administrative tools, for which no acl must apply. |
---|
| 51 | |
---|
| 52 | =back |
---|
| 53 | |
---|
[255] | 54 | =cut |
---|
| 55 | |
---|
[22] | 56 | sub new { |
---|
[457] | 57 | my ($class, $config, %options) = @_; |
---|
[1] | 58 | |
---|
[861] | 59 | $config ||= _configdir(); |
---|
[24] | 60 | |
---|
[1041] | 61 | my $configfile = join('/', $config, 'latmos-accounts.ini'); |
---|
[861] | 62 | |
---|
[22] | 63 | my $self = Config::IniFiles->new( |
---|
[861] | 64 | -file => $configfile, |
---|
[73] | 65 | '-default' => '_default_', |
---|
[861] | 66 | ) or do { |
---|
| 67 | la_log(LA_ERR, 'Can\'t open main config file %s', $configfile); |
---|
| 68 | return; |
---|
| 69 | }; |
---|
| 70 | |
---|
| 71 | $self->{_configdir} = $config; |
---|
| 72 | bless($self, $class); |
---|
| 73 | |
---|
[1042] | 74 | unless ($options{noacl}) { |
---|
| 75 | if (-f (my $aclf = join('/', $self->_configdir, 'la-acls.ini'))) { |
---|
[861] | 76 | $self->{_acls} = LATMOS::Accounts::Acls->new($aclf) or do { |
---|
| 77 | la_log(LA_ERR, 'Cannot load ACL file %s', $aclf); |
---|
| 78 | return; |
---|
| 79 | }; |
---|
| 80 | } |
---|
[320] | 81 | } |
---|
[1] | 82 | |
---|
[1042] | 83 | if (-f (my $allowf = join('/', $self->_configdir, 'la-allowed-values.ini'))) { |
---|
[683] | 84 | $self->{_allowed_values} = Config::IniFiles->new( |
---|
[861] | 85 | -file => $allowf, |
---|
| 86 | ) or do { |
---|
| 87 | la_log(LA_ERR, 'Cannot load ALLOWED VALUES %s', $allowf); |
---|
| 88 | return; |
---|
| 89 | }; |
---|
[683] | 90 | } |
---|
| 91 | |
---|
[861] | 92 | $self |
---|
[22] | 93 | } |
---|
[1] | 94 | |
---|
[1043] | 95 | =head2 list_bases |
---|
| 96 | |
---|
| 97 | Return the base list found in config file |
---|
| 98 | |
---|
| 99 | =cut |
---|
| 100 | |
---|
| 101 | sub list_bases { |
---|
| 102 | my ($self) = @_; |
---|
| 103 | grep { |
---|
| 104 | !m/^_.*_$/ && |
---|
| 105 | !m/^sync:/ |
---|
| 106 | } $self->Sections |
---|
| 107 | } |
---|
| 108 | |
---|
| 109 | =head2 default_base_name |
---|
[255] | 110 | |
---|
[1043] | 111 | Return the default base name according config file |
---|
[255] | 112 | |
---|
| 113 | =cut |
---|
| 114 | |
---|
[1043] | 115 | sub default_base_name { |
---|
[255] | 116 | my ($self) = @_; |
---|
[1043] | 117 | $self->val('_default_', 'base', ($self->list_bases)[0]); |
---|
[255] | 118 | } |
---|
| 119 | |
---|
| 120 | =head2 base($basename) |
---|
| 121 | |
---|
| 122 | Return a L<LATMOS::Accounts::Base> object over base named $basename |
---|
| 123 | defined in the config file. |
---|
| 124 | |
---|
| 125 | The base is loaded by this function. |
---|
| 126 | |
---|
| 127 | =cut |
---|
| 128 | |
---|
[22] | 129 | sub base { |
---|
| 130 | my ($self, $section) = @_; |
---|
| 131 | # this method perform a cache |
---|
[868] | 132 | $self->_load_base($section || $self->default_base_name); |
---|
[22] | 133 | } |
---|
[1] | 134 | |
---|
[22] | 135 | # do the bad work |
---|
| 136 | sub _load_base { |
---|
| 137 | my ($self, $section) = @_; |
---|
| 138 | my $type = $self->val($section, 'type') or return; |
---|
[1071] | 139 | |
---|
| 140 | my %params = |
---|
| 141 | map { $_ => ($self->val($section, $_)) } |
---|
| 142 | $self->Parameters($section); |
---|
| 143 | |
---|
| 144 | my %defattr = |
---|
| 145 | map { $_ => ($self->val('_defattr_', $_)) } |
---|
| 146 | $self->Parameters('_defattr_'); |
---|
| 147 | |
---|
[320] | 148 | my $base = LATMOS::Accounts::Bases->new( |
---|
| 149 | $type, |
---|
[1071] | 150 | { |
---|
| 151 | params => \%params, |
---|
| 152 | label => $section, |
---|
| 153 | acls => $self->{_acls}, |
---|
| 154 | allowed_values => $self->{_allowed_values}, |
---|
| 155 | configdir => $self->_configdir, |
---|
| 156 | la => $self, |
---|
| 157 | defattr => { %defattr }, |
---|
| 158 | }, |
---|
[320] | 159 | ) or do { |
---|
[255] | 160 | la_log(LA_WARN, "Cannot instanciate base $section ($type)"); |
---|
[192] | 161 | return; |
---|
| 162 | }; |
---|
[34] | 163 | $base->load or return; |
---|
| 164 | $base; |
---|
[22] | 165 | } |
---|
[1] | 166 | |
---|
[1043] | 167 | =head2 list_synchro |
---|
[1012] | 168 | |
---|
[1043] | 169 | List synchronisation setup in L<latmos-accounts.ini> |
---|
[1012] | 170 | |
---|
| 171 | =cut |
---|
| 172 | |
---|
[1043] | 173 | sub list_synchro { |
---|
[77] | 174 | my ($self) = @_; |
---|
[1043] | 175 | grep { $_ } map { /^sync:(.*)$/; $1 } $self->Sections |
---|
[77] | 176 | } |
---|
| 177 | |
---|
[1043] | 178 | =head2 default_synchro_name |
---|
[1012] | 179 | |
---|
[1043] | 180 | Return de default synchronisation name |
---|
[1012] | 181 | |
---|
| 182 | =cut |
---|
| 183 | |
---|
[1043] | 184 | sub default_synchro_name { |
---|
[77] | 185 | my ($self) = @_; |
---|
[1043] | 186 | $self->val('_default_', 'sync'); |
---|
[77] | 187 | } |
---|
| 188 | |
---|
[1012] | 189 | =head2 default_synchro |
---|
| 190 | |
---|
| 191 | Return a reference to default synchronisation object |
---|
| 192 | |
---|
| 193 | =cut |
---|
| 194 | |
---|
[77] | 195 | sub default_synchro { |
---|
[78] | 196 | my ($self, %options) = @_; |
---|
[317] | 197 | my $syncname = $self->default_synchro_name or do { |
---|
| 198 | la_log(LA_ERR, 'Cannot find default synchro in config'); |
---|
| 199 | return; |
---|
| 200 | }; |
---|
[78] | 201 | $self->create_synchro($syncname, %options); |
---|
[77] | 202 | } |
---|
| 203 | |
---|
[1012] | 204 | =head2 create_synchro($name, %options) |
---|
[41] | 205 | |
---|
[1012] | 206 | Return a reference to synchronisation object for C<$name> synchronisation. |
---|
| 207 | |
---|
| 208 | =cut |
---|
| 209 | |
---|
[50] | 210 | sub create_synchro { |
---|
[73] | 211 | my ($self, $name, %options) = @_; |
---|
[50] | 212 | |
---|
[73] | 213 | # taking options from config |
---|
| 214 | if ($name) { |
---|
| 215 | foreach my $param ($self->Parameters("sync:$name")) { |
---|
| 216 | if (!defined($options{$param})) { |
---|
| 217 | my @args = $self->val("sync:$name", $param); |
---|
| 218 | $options{$param} = ($args[1] || $param eq 'to') |
---|
| 219 | ? [ @args ] |
---|
| 220 | : $args[0]; |
---|
| 221 | } |
---|
| 222 | } |
---|
| 223 | } |
---|
[50] | 224 | |
---|
[73] | 225 | my $labfrom = $options{from} ? $self->base($options{from}) : $self->default_base; |
---|
[50] | 226 | |
---|
[192] | 227 | my @labto = |
---|
| 228 | grep { $_ } |
---|
| 229 | map { $self->base($_) } |
---|
| 230 | @{ $options{to} || []} |
---|
[317] | 231 | or do { |
---|
| 232 | la_log(LA_ERR, "No destination base load in this synchro"); |
---|
| 233 | return; |
---|
| 234 | }; |
---|
[73] | 235 | |
---|
[50] | 236 | my $sync = LATMOS::Accounts::Synchro->new( |
---|
| 237 | $labfrom, [ @labto ], |
---|
[563] | 238 | state_dir => ($self->val('_default_', 'state_dir') || undef), |
---|
[73] | 239 | %options, |
---|
[77] | 240 | name => $name, |
---|
[50] | 241 | ); |
---|
| 242 | } |
---|
| 243 | |
---|
[1058] | 244 | sub _sync_from_name { |
---|
| 245 | my ($self, $syncname) = @_; |
---|
| 246 | return if (!$syncname); |
---|
| 247 | $self->val("sync:$syncname", 'from', $self->default_base_name); |
---|
| 248 | } |
---|
| 249 | |
---|
[1012] | 250 | =head2 sync_access($name, %options) |
---|
| 251 | |
---|
| 252 | Return a L<LATMOS::Accounts::SynchAccess> object over C<$name> synchronisation. |
---|
| 253 | |
---|
| 254 | =cut |
---|
| 255 | |
---|
[56] | 256 | sub sync_access { |
---|
[73] | 257 | my ($self, $name, %options) = @_; |
---|
| 258 | |
---|
[178] | 259 | my @obases; |
---|
| 260 | if ($name) { |
---|
| 261 | @obases = |
---|
[1058] | 262 | (map { $self->base($_) } ($self->_sync_from_name($name), $self->val("sync:$name", 'to'))); |
---|
[178] | 263 | } elsif(@{ $options{bases} || []}) { |
---|
| 264 | @obases = map { $self->base($_) } @{ $options{bases} || []}; |
---|
| 265 | } elsif (my $sname = $self->default_synchro_name) { |
---|
| 266 | @obases = (map { $self->base($_) } |
---|
[1058] | 267 | ($self->_sync_from_name($sname), $self->val("sync:$sname", 'to')) |
---|
[178] | 268 | ); |
---|
| 269 | } |
---|
| 270 | |
---|
[56] | 271 | LATMOS::Accounts::SynchAccess->new([ @obases ]); |
---|
| 272 | } |
---|
[50] | 273 | |
---|
[1047] | 274 | =head2 call_batch_sync |
---|
| 275 | |
---|
| 276 | Send signal to L<la-sync-manager> daemon to synchronize bases. |
---|
| 277 | |
---|
| 278 | =cut |
---|
| 279 | |
---|
| 280 | sub call_batch_sync { |
---|
| 281 | my ($self) = @_; |
---|
| 282 | if (my $sd = $self->val('_default_', 'state_dir')) { |
---|
| 283 | if (open(my $fh, '<', $sd . '/sync-manager.pid')) { |
---|
| 284 | my $pid = <$fh> || ''; |
---|
| 285 | chomp($pid); |
---|
| 286 | close($fh); |
---|
| 287 | if ($pid && kill 1, $pid) { |
---|
| 288 | return 1; # \o/ we succeed |
---|
| 289 | } else { |
---|
| 290 | la_log(LA_ERR, "Can send signal -1 to la-sync-manager (pid: %s, %s)", |
---|
| 291 | $pid || 'none', $!); |
---|
| 292 | return; |
---|
| 293 | } |
---|
| 294 | } else { |
---|
| 295 | la_log(LA_ERR, 'Cannot open la-sync-manager pid file'); |
---|
| 296 | return; |
---|
| 297 | } |
---|
| 298 | } else { |
---|
| 299 | la_log(LA_WARN, "No statedir setup, cannot find la-sync-manager pid file"); |
---|
| 300 | return; |
---|
| 301 | } |
---|
| 302 | } |
---|
| 303 | |
---|
[1] | 304 | 1; |
---|
[24] | 305 | |
---|
[1] | 306 | __END__ |
---|
| 307 | |
---|
| 308 | =head1 AUTHOR |
---|
| 309 | |
---|
[255] | 310 | Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.frE<gt> |
---|
[1] | 311 | |
---|
| 312 | =head1 COPYRIGHT AND LICENSE |
---|
| 313 | |
---|
[1018] | 314 | Copyright (C) 2009, 2010, 2011, 2012 by Thauvin Olivier |
---|
[1] | 315 | |
---|
| 316 | This library is free software; you can redistribute it and/or modify |
---|
| 317 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 318 | at your option, any later version of Perl 5 you may have available. |
---|
| 319 | |
---|
| 320 | =cut |
---|