[32] | 1 | package Sophie::Controller::Admin; |
---|
| 2 | use Moose; |
---|
| 3 | use namespace::autoclean; |
---|
[42] | 4 | use YAML qw/freeze thaw/; |
---|
[32] | 5 | |
---|
| 6 | BEGIN {extends 'Catalyst::Controller'; } |
---|
| 7 | |
---|
| 8 | =head1 NAME |
---|
| 9 | |
---|
| 10 | Sophie::Controller::Admin - Catalyst Controller |
---|
| 11 | |
---|
| 12 | =head1 DESCRIPTION |
---|
| 13 | |
---|
| 14 | Catalyst Controller. |
---|
| 15 | |
---|
| 16 | =head1 METHODS |
---|
| 17 | |
---|
| 18 | =cut |
---|
| 19 | |
---|
[316] | 20 | sub begin : Private { |
---|
| 21 | my ($self, $c) = @_; |
---|
| 22 | |
---|
| 23 | if (!($c->user_exists && $c->check_user_roles($c->user, 'Admin'))) { |
---|
| 24 | $c->go('/login/index'); |
---|
| 25 | } |
---|
| 26 | |
---|
| 27 | $c->forward('/begin'); |
---|
| 28 | } |
---|
| 29 | |
---|
[32] | 30 | =head2 index |
---|
| 31 | |
---|
| 32 | =cut |
---|
| 33 | |
---|
| 34 | sub index :Path :Args(0) { |
---|
| 35 | my ( $self, $c ) = @_; |
---|
| 36 | |
---|
| 37 | $c->response->body('Matched Sophie::Controller::Admin in Admin.'); |
---|
| 38 | } |
---|
| 39 | |
---|
| 40 | sub create :XMLRPC { |
---|
| 41 | my ( $self, $c, $distribution, $version, $arch ) = @_; |
---|
| 42 | |
---|
| 43 | my $rs = $c->model('Base')->resultset('Distribution'); |
---|
| 44 | my $rs_d = $rs->find_or_create({ name => $distribution}) or do { |
---|
| 45 | $c->stash->{xmlrpc} = 'Erreur adding distrib'; |
---|
| 46 | return; |
---|
| 47 | }; |
---|
| 48 | |
---|
| 49 | my $rs_r = $rs_d->Release->find_or_create({ version => $version, }) or do { |
---|
| 50 | $c->stash->{xmlrpc} = 'Erreur adding release'; |
---|
| 51 | return; |
---|
| 52 | }; |
---|
| 53 | |
---|
| 54 | my $rs_a = $rs_r->Arch->find_or_create({ arch => $arch }) or do { |
---|
| 55 | $c->stash->{xmlrpc} = 'Erreur adding arch'; |
---|
| 56 | return; |
---|
| 57 | }; |
---|
| 58 | |
---|
| 59 | $c->stash->{xmlrpc} = 'Ok'; |
---|
| 60 | |
---|
| 61 | $c->model('Base')->storage->dbh->commit; |
---|
| 62 | |
---|
| 63 | } |
---|
| 64 | |
---|
| 65 | sub add_media :XMLRPC { |
---|
| 66 | my ( $self, $c, $distribspec, $mediaspec) = @_; |
---|
| 67 | |
---|
| 68 | my $d = $c->model('Base')->resultset('Distribution') |
---|
[375] | 69 | ->search({ name => $distribspec->{distribution} }) |
---|
| 70 | ->search_related('Release', { version => $distribspec->{release} }) |
---|
| 71 | ->search_related('Arch', { arch => $distribspec->{arch} })->next; |
---|
[32] | 72 | if ($d) { |
---|
[41] | 73 | my $new = my $rs = $c->model('Base')->resultset('Medias') |
---|
| 74 | ->update_or_create({ |
---|
[32] | 75 | %{ $mediaspec }, |
---|
| 76 | Arch => $d, |
---|
[41] | 77 | }, |
---|
| 78 | { key => 'label' } |
---|
| 79 | ); |
---|
| 80 | if ($new) { |
---|
[32] | 81 | $c->stash->{xmlrpc} = 'OK'; |
---|
| 82 | $c->model('Base')->storage->dbh->commit; |
---|
| 83 | } else { |
---|
| 84 | $c->stash->{xmlrpc} = 'Erreur adding media'; |
---|
| 85 | } |
---|
| 86 | } |
---|
| 87 | } |
---|
| 88 | |
---|
[185] | 89 | sub remove_media :XMLRPC { |
---|
| 90 | my ( $self, $c, $distribspec, $medianame) = @_; |
---|
| 91 | |
---|
| 92 | my $med = $c->model('Base::Medias')->find( |
---|
| 93 | { |
---|
| 94 | label => $medianame, |
---|
| 95 | d_arch => $c->model('Base')->resultset('Distribution') |
---|
[375] | 96 | ->search({ name => $distribspec->{distribution} }) |
---|
| 97 | ->search_related('Release', |
---|
| 98 | { version => $distribspec->{release}} ) |
---|
| 99 | ->search_related('Arch', |
---|
| 100 | { arch => $distribspec->{arch} })->next->d_arch_key, |
---|
[185] | 101 | } |
---|
| 102 | ); |
---|
| 103 | |
---|
| 104 | if ($med->delete) { |
---|
| 105 | $c->stash->{xmlrpc} = 'OK'; |
---|
| 106 | $c->model('Base')->storage->dbh->commit; |
---|
| 107 | } else { |
---|
| 108 | $c->stash->{xmlrpc} = "Cannot delete $medianame"; |
---|
| 109 | } |
---|
| 110 | } |
---|
| 111 | |
---|
[32] | 112 | sub list_path :XMLRPC { |
---|
| 113 | my ($self, $c, $distribution, $version, $arch, $media) = @_; |
---|
| 114 | |
---|
| 115 | if (ref $distribution) { |
---|
| 116 | ($distribution, $version, $arch, $media) = |
---|
| 117 | ( |
---|
| 118 | $distribution->{distribution}, |
---|
| 119 | $distribution->{release}, |
---|
| 120 | $distribution->{arch}, |
---|
| 121 | $version, |
---|
| 122 | ); |
---|
| 123 | } |
---|
| 124 | |
---|
[42] | 125 | $c->stash->{xmlrpc} = [ |
---|
[32] | 126 | $c->model('Base')->resultset('Distribution') |
---|
| 127 | ->search($distribution ? (name => $distribution) : ()) |
---|
| 128 | ->search_related('Release', $version ? (version => $version) : ()) |
---|
| 129 | ->search_related('Arch', $arch ? (arch => $arch) : ()) |
---|
| 130 | ->search_related('Medias', $media ? (label => $media) : ()) |
---|
| 131 | ->search_related('MediasPaths') |
---|
[346] | 132 | ->search_related('Paths', { meta_path => undef })->get_column('path') |
---|
[42] | 133 | ->all ]; |
---|
[32] | 134 | } |
---|
| 135 | |
---|
[346] | 136 | sub list_meta_path :XMLRPC { |
---|
| 137 | my ($self, $c, $distribution, $version, $arch, $media) = @_; |
---|
| 138 | |
---|
| 139 | if (ref $distribution) { |
---|
| 140 | ($distribution, $version, $arch, $media) = |
---|
| 141 | ( |
---|
| 142 | $distribution->{distribution}, |
---|
| 143 | $distribution->{release}, |
---|
| 144 | $distribution->{arch}, |
---|
| 145 | $version, |
---|
| 146 | ); |
---|
| 147 | } |
---|
| 148 | |
---|
| 149 | $c->stash->{xmlrpc} = [ |
---|
| 150 | $c->model('Base')->resultset('Distribution') |
---|
| 151 | ->search($distribution ? (name => $distribution) : ()) |
---|
| 152 | ->search_related('Release', $version ? (version => $version) : ()) |
---|
| 153 | ->search_related('Arch', $arch ? (arch => $arch) : ()) |
---|
| 154 | ->search_related('MetaPaths') |
---|
| 155 | ->get_column('path')->all ]; |
---|
| 156 | } |
---|
| 157 | |
---|
[32] | 158 | sub media_path :XMLRPC { |
---|
| 159 | my ( $self, $c, $distribution, $version, $arch, $label, $path ) = @_; |
---|
| 160 | |
---|
| 161 | if (ref $distribution) { |
---|
| 162 | ($distribution, $version, $arch, $label, $path) = |
---|
| 163 | ( |
---|
| 164 | $distribution->{distribution}, |
---|
| 165 | $distribution->{release}, |
---|
| 166 | $distribution->{arch}, |
---|
| 167 | $version, |
---|
| 168 | $arch, |
---|
| 169 | ); |
---|
| 170 | } |
---|
| 171 | |
---|
| 172 | $path =~ s/\/*$//; |
---|
| 173 | $path =~ s/\/+/\//g; |
---|
| 174 | |
---|
| 175 | my $med = $c->model('Base')->resultset('Distribution') |
---|
[375] | 176 | ->search({ name => $distribution }) |
---|
| 177 | ->search_related('Release', { version => $version }) |
---|
| 178 | ->search_related('Arch', { arch => $arch }) |
---|
| 179 | ->search_related('Medias', { label => $label })->next or return; |
---|
[32] | 180 | |
---|
| 181 | my $rspath = $c->model('Base')->resultset('Paths') |
---|
| 182 | ->find_or_create({ path => $path }) or do { |
---|
| 183 | }; |
---|
| 184 | my $new = $c->model('Base')->resultset('MediasPaths')->new({ |
---|
| 185 | Medias => $med, |
---|
| 186 | Paths => $rspath, |
---|
| 187 | }); |
---|
| 188 | $new->insert; |
---|
| 189 | |
---|
| 190 | $c->model('Base')->storage->dbh->commit; |
---|
| 191 | } |
---|
| 192 | |
---|
[41] | 193 | sub media_remove_path :XMLRPC { |
---|
| 194 | my ( $self, $c, $distribution, $version, $arch, $label, $path ) = @_; |
---|
[32] | 195 | |
---|
[41] | 196 | if (ref $distribution) { |
---|
| 197 | ($distribution, $version, $arch, $label, $path) = |
---|
| 198 | ( |
---|
| 199 | $distribution->{distribution}, |
---|
| 200 | $distribution->{release}, |
---|
| 201 | $distribution->{arch}, |
---|
| 202 | $version, |
---|
| 203 | $arch, |
---|
| 204 | ); |
---|
| 205 | } |
---|
| 206 | |
---|
| 207 | $path =~ s/\/*$//; |
---|
| 208 | $path =~ s/\/+/\//g; |
---|
| 209 | |
---|
| 210 | my $med = $c->model('Base')->resultset('Distribution') |
---|
| 211 | ->search(name => $distribution) |
---|
| 212 | ->search_related('Release', version => $version) |
---|
| 213 | ->search_related('Arch', arch => $arch) |
---|
[42] | 214 | ->search_related('Medias', label => $label)->find or return; |
---|
[41] | 215 | |
---|
| 216 | my $rspath = $c->model('Base')->resultset('Paths') |
---|
| 217 | ->find({ path => $path }) or do { |
---|
| 218 | return; |
---|
| 219 | }; |
---|
[42] | 220 | my $new = $c->model('Base')->resultset('MediasPaths')->search({ |
---|
| 221 | d_media => $med->d_media_key, |
---|
| 222 | d_path => $rspath->d_path_key, |
---|
| 223 | })->next->delete; |
---|
[41] | 224 | |
---|
| 225 | $c->model('Base')->storage->dbh->commit; |
---|
| 226 | } |
---|
| 227 | |
---|
| 228 | sub ls_local : XMLRPC { |
---|
| 229 | my ($self, $c, $path) = @_; |
---|
| 230 | |
---|
| 231 | $c->stash->{xmlrpc} = [ <$path*> ]; |
---|
| 232 | } |
---|
| 233 | |
---|
[104] | 234 | sub replace_path : XMLRPC { |
---|
| 235 | my ($self, $c, $path, $newpath) = @_; |
---|
| 236 | |
---|
| 237 | my $dpath = $c->model('Base::Paths')->find({ |
---|
| 238 | path => $path, |
---|
| 239 | }) or do { |
---|
| 240 | return $c->stash->{xmlrpc} = 'Path not found'; |
---|
| 241 | }; |
---|
| 242 | |
---|
| 243 | $newpath =~ s/\/*$//; |
---|
| 244 | |
---|
| 245 | $dpath->update( |
---|
| 246 | { |
---|
| 247 | updated => undef, |
---|
| 248 | path => $newpath, |
---|
| 249 | } |
---|
| 250 | ) and $c->model('Base')->storage->dbh->commit; |
---|
| 251 | return $c->stash->{xmlrpc} = 'OK'; |
---|
| 252 | } |
---|
| 253 | |
---|
[185] | 254 | sub remove_path : XMLRPC { |
---|
| 255 | my ($self, $c, $path) = @_; |
---|
| 256 | |
---|
| 257 | my $dpath = $c->model('Base::Paths')->find({ |
---|
| 258 | path => $path, |
---|
| 259 | }) or do { |
---|
| 260 | return $c->stash->{xmlrpc} = 'Path not found'; |
---|
| 261 | }; |
---|
| 262 | |
---|
| 263 | |
---|
| 264 | $dpath->delete and $c->model('Base')->storage->dbh->commit; |
---|
| 265 | return $c->stash->{xmlrpc} = 'OK'; |
---|
| 266 | } |
---|
| 267 | |
---|
| 268 | |
---|
[42] | 269 | sub dump_distrib : XMLRPC { |
---|
| 270 | my ($self, $c, $distribution, $version, $arch) = @_; |
---|
| 271 | |
---|
| 272 | if (!ref $distribution) { |
---|
| 273 | $distribution = { |
---|
| 274 | distribution => $distribution, |
---|
| 275 | release => $version, |
---|
| 276 | arch => $arch, |
---|
| 277 | }; |
---|
| 278 | } |
---|
| 279 | |
---|
[249] | 280 | $c->forward('/distrib/exists', [ $distribution ]) or do { |
---|
| 281 | $c->error('No such distribution'); |
---|
| 282 | return; |
---|
| 283 | }; |
---|
| 284 | |
---|
[42] | 285 | my $ref = { |
---|
| 286 | distrib => $distribution, |
---|
| 287 | }; |
---|
| 288 | |
---|
| 289 | $ref->{media} = $c->forward('/distrib/struct', [ $distribution ]); |
---|
| 290 | |
---|
| 291 | foreach (@{ $ref->{media} || []}) { |
---|
| 292 | warn $_->{label}; |
---|
| 293 | $ref->{path}{$_->{label}} = $c->forward('list_path', [ $distribution, |
---|
| 294 | $_->{label} ]); |
---|
| 295 | } |
---|
| 296 | |
---|
[346] | 297 | $ref->{metapath} = [ map { { $_->get_columns } } |
---|
| 298 | $c->model('Base')->resultset('Distribution') |
---|
| 299 | ->search({ name => $distribution->{distribution} }) |
---|
| 300 | ->search_related('Release', { version => $distribution->{release} }) |
---|
| 301 | ->search_related('Arch', { arch => $distribution->{arch} }) |
---|
| 302 | ->search_related('MetaPaths') |
---|
| 303 | ->search({}, |
---|
| 304 | { |
---|
| 305 | 'select' => [ qw(path type) ], |
---|
| 306 | 'as' => [ qw(path type) ] , |
---|
| 307 | } |
---|
| 308 | )->all ]; |
---|
| 309 | |
---|
[42] | 310 | $c->stash->{xmlrpc} = freeze($ref); |
---|
| 311 | } |
---|
| 312 | |
---|
[346] | 313 | sub add_meta_path : XMLRPC { |
---|
| 314 | my ($self, $c, $distrib, $meta, $type) = @_; |
---|
| 315 | |
---|
| 316 | my ($dist) = |
---|
| 317 | $c->model('Base')->resultset('Distribution') |
---|
| 318 | ->search(name => $distrib->{distribution}) |
---|
| 319 | ->search_related('Release', version => $distrib->{release}) |
---|
| 320 | ->search_related('Arch', arch => $distrib->{arch}) |
---|
| 321 | ->get_column('d_arch_key')->all or do { |
---|
| 322 | return $c->stash->{xmlrpc} = "No such distrib"; |
---|
| 323 | }; |
---|
| 324 | |
---|
| 325 | if ($c->model('Base::MetaPaths')->find_or_create( |
---|
| 326 | { |
---|
| 327 | d_arch => $dist, |
---|
| 328 | type => $type, |
---|
| 329 | path => $meta, |
---|
| 330 | }, |
---|
| 331 | { key => 'upath' }, |
---|
| 332 | )) { |
---|
| 333 | return $c->stash->{xmlrpc} = 'OK'; |
---|
| 334 | } else { |
---|
| 335 | return; |
---|
| 336 | } |
---|
| 337 | |
---|
| 338 | } |
---|
| 339 | |
---|
[42] | 340 | sub clean_distrib : XMLRPC { |
---|
| 341 | my ($self, $c, $distribution, $version, $arch) = @_; |
---|
| 342 | |
---|
| 343 | if (!ref $distribution) { |
---|
| 344 | $distribution = { |
---|
| 345 | distribution => $distribution, |
---|
| 346 | release => $version, |
---|
| 347 | arch => $arch, |
---|
| 348 | }; |
---|
| 349 | } |
---|
| 350 | |
---|
| 351 | my $rsdist = $c->model('Base')->resultset('Distribution') |
---|
[375] | 352 | ->search({ name => $distribution->{distribution} }) |
---|
| 353 | ->search_related('Release', { version => $distribution->{release} }) |
---|
| 354 | ->search_related('Arch', { arch => $distribution->{arch} }) |
---|
[42] | 355 | ->search_related('Medias'); |
---|
| 356 | |
---|
| 357 | my $new = $c->model('Base')->resultset('MediasPaths')->search({ |
---|
| 358 | d_media => { IN => $rsdist->get_column('d_media_key')->as_query }, |
---|
| 359 | })->delete; |
---|
| 360 | |
---|
| 361 | # $c->model('Base')->storage->dbh->rollback; |
---|
| 362 | |
---|
| 363 | } |
---|
| 364 | |
---|
| 365 | sub load_distrib : XMLRPC { |
---|
| 366 | my ( $self, $c, $dump ) = @_; |
---|
| 367 | |
---|
| 368 | my $ref = thaw($dump); |
---|
| 369 | |
---|
| 370 | $c->forward('clean_distrib', [ $ref->{distrib} ]); |
---|
| 371 | |
---|
| 372 | $c->forward('create', [ |
---|
| 373 | $ref->{distrib}{distribution}, |
---|
| 374 | $ref->{distrib}{release}, |
---|
| 375 | $ref->{distrib}{arch}, |
---|
| 376 | ]); |
---|
| 377 | |
---|
[375] | 378 | # cleaning media not existing anymore |
---|
| 379 | foreach my $media (@{ $c->forward('/distrib/list', [ $ref->{distrib} ]) || []}) { |
---|
| 380 | if (!grep { $media eq $_->{label} } (@{ $ref->{media} || []})) { |
---|
| 381 | $c->forward('remove_media', [ $ref->{distrib}, $media ]); |
---|
| 382 | } |
---|
| 383 | } |
---|
[42] | 384 | foreach my $media (@{ $ref->{media} || []}) { |
---|
| 385 | $c->forward('add_media', [ $ref->{distrib}, $media ]); |
---|
| 386 | } |
---|
[296] | 387 | foreach my $media (keys %{ $ref->{path} || {} }) { |
---|
[42] | 388 | foreach my $path (@{ $ref->{path}{$media} || [] }) { |
---|
| 389 | $c->forward('media_path', [ $ref->{distrib}, $media, $path ]); |
---|
| 390 | } |
---|
| 391 | } |
---|
[346] | 392 | foreach my $meta (@{ $ref->{metapath} || []}) { |
---|
| 393 | $c->forward('add_meta_path', |
---|
| 394 | [ $ref->{distrib}, $meta->{path}, $meta->{type} ]); |
---|
| 395 | } |
---|
[42] | 396 | |
---|
| 397 | #$c->model('Base')->storage->dbh->rollback; |
---|
| 398 | } |
---|
| 399 | |
---|
[68] | 400 | sub set_user_data : XMLRPC { |
---|
| 401 | my ( $self, $c, $user, $dataname, $data ) = @_; |
---|
| 402 | $c->forward('/user/set_user_data', [ $user, $dataname, $data ]); |
---|
| 403 | } |
---|
| 404 | |
---|
[188] | 405 | sub get_user_data : XMLRPC { |
---|
| 406 | my ( $self, $c, $user, $dataname ) = @_; |
---|
| 407 | $c->forward('/user/fetch_user_data', [ $user, $dataname ]); |
---|
| 408 | } |
---|
| 409 | |
---|
[68] | 410 | sub update_user_data : XMLRPC { |
---|
| 411 | my ( $self, $c, $user, $dataname, $data ) = @_; |
---|
| 412 | $c->forward('/user/update_user_data', [ $user, $dataname, $data ]); |
---|
| 413 | } |
---|
| 414 | |
---|
[211] | 415 | sub set_user_password : XMLRPC { |
---|
| 416 | my ( $self, $c, $user, $password ) = @_; |
---|
| 417 | |
---|
| 418 | $c->forward('/user/set_user_password', $user, $password); |
---|
| 419 | } |
---|
| 420 | |
---|
[249] | 421 | sub list_user : XMLRPC { |
---|
| 422 | my ($self, $c, $match) = @_; |
---|
| 423 | |
---|
| 424 | $c->stash->{xmlrpc} = [ |
---|
| 425 | $c->model('Base::Users')->search( |
---|
| 426 | { |
---|
| 427 | $match ? ( mail => { '~' => $match } ) : (), |
---|
| 428 | } |
---|
| 429 | )->get_column('mail')->all ]; |
---|
| 430 | } |
---|
| 431 | |
---|
| 432 | sub delete_user : XMLRPC { |
---|
| 433 | my ($self, $c, $mail) = @_; |
---|
| 434 | |
---|
| 435 | if (my $user = $c->model('Base::Users')->find({ mail => $mail })) { |
---|
| 436 | if ($user->delete) { |
---|
| 437 | $c->model('Base')->storage->dbh->commit; |
---|
| 438 | return $c->stash->{xmlrpc} = "User $mail deleted"; |
---|
| 439 | } |
---|
| 440 | } |
---|
| 441 | $c->stash->{xmlrpc} = "No user $mail"; |
---|
| 442 | } |
---|
| 443 | |
---|
[211] | 444 | sub create_user : XMLRPC { |
---|
| 445 | my ($self, $c, $user, $password) = @_; |
---|
| 446 | |
---|
| 447 | if ($c->model('Base::Users')->create({ |
---|
| 448 | mail => $user, |
---|
| 449 | })) { |
---|
| 450 | $c->forward('set_user_password', [ $user, $password ]); |
---|
| 451 | return $c->stash->{xmlrpc} = "User $user created"; |
---|
| 452 | } else { |
---|
| 453 | return; |
---|
| 454 | } |
---|
| 455 | } |
---|
| 456 | |
---|
[32] | 457 | =head1 AUTHOR |
---|
| 458 | |
---|
| 459 | Olivier Thauvin |
---|
| 460 | |
---|
| 461 | =head1 LICENSE |
---|
| 462 | |
---|
| 463 | This library is free software. You can redistribute it and/or modify |
---|
| 464 | it under the same terms as Perl itself. |
---|
| 465 | |
---|
| 466 | =cut |
---|
| 467 | |
---|
| 468 | __PACKAGE__->meta->make_immutable; |
---|
| 469 | |
---|
| 470 | 1; |
---|