licom.cgi

   1 #!/usr/bin/perl
   2
   3 # LiCoM - Lightweight contact manager
   4 # Copyright (c) 2005-2006  Florian octo Forster <octo at verplant.org>
   5 #
   6 # This program is free software; you can redistribute it and/or modify it under
   7 # the terms of the GNU General Public License as published by the Free Software
   8 # Foundation; only version 2 of the License is applicable.
   9 #
  10 # This program is distributed in the hope that it will be useful, but WITHOUT
  11 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  12 # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
  13 # details.
  14 #
  15 # You should have received a copy of the GNU General Public License along with
  16 # this program; if not, write to the Free Software # Foundation, Inc.,
  17 # 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18
  19 use strict;
  20 use warnings;
  21 use lib (qw(lib));
  22
  23 use Encode (qw(encode decode is_utf8));
  24 use CGI (':cgi');
  25 use CGI::Carp (qw(fatalsToBrowser));
  26 use URI::Escape;
  27 use HTML::Entities (qw(encode_entities));
  28
  29 use LiCoM::Config (qw(get_config set_config read_config));
  30 use LiCoM::Connection ();
  31 use LiCoM::Group ();
  32 use LiCoM::Person ();
  33
  34 our $Debug = 0;
  35
  36 our @MultiFields = (qw(address homephone cellphone officephone fax mail uri));
  37
  38 our %FieldNames =
  39 (
  40         address         => 'Address',
  41         homephone       => 'Home Phone',
  42         cellphone       => 'Cell Phone',
  43         officephone     => 'Office Phone',
  44         fax             => 'FAX',
  45         mail            => 'E-Mail',
  46         uri             => 'URI (Homepage)',
  47         group           => 'Group'
  48 );
  49
  50 our $MySelf = $ENV{'SCRIPT_NAME'};
  51
  52 our $Action = param_utf8 ('action');
  53 $Action ||= 'default';
  54
  55 our %Actions =
  56 (
  57         browse  => [\&html_start, \&action_browse,  \&html_end],
  58         default => [\&html_start, \&action_browse,  \&html_end],
  59         detail  => [\&html_start, \&action_detail,  \&html_end],
  60         edit    => [\&html_start, \&action_edit,    \&html_end],
  61         list    => [\&html_start, \&action_list,    \&html_end],
  62         save    => [\&html_start, \&action_save,    \&html_end],
  63         search  => [\&html_start, \&action_search,  \&html_end],
  64         verify  => [\&html_start, \&action_verify,  \&html_end],
  65         delete  => [\&html_start, \&action_ask_del,  \&html_end],
  66         expunge => [\&html_start, \&action_do_del,  \&html_end],
  67         vcard   => \&action_vcard,
  68         edit_group => [\&html_start, \&action_edit_group, \&html_end],
  69         save_group => [\&html_start, \&action_save_group, \&html_end]
  70 );
  71
  72 {
  73         my @files = (qw(/etc/licom/licom.conf));
  74         push (@files, './licom.conf') if (-r './licom.conf');
  75         read_config (@files);
  76 }
  77
  78 # make sure AuthLDAPRemoteUserIsDN is enabled.
  79 die unless ($ENV{'REMOTE_USER'});
  80 #set_config ('base_dn', $ENV{'REMOTE_USER'});
  81
  82 die ("Configuration is incomplete") unless (defined (get_config ('uri'))
  83         and defined (get_config ('base_dn'))
  84         and defined (get_config ('bind_dn'))
  85         and defined (get_config ('password')));
  86
  87 LiCoM::Connection->connect
  88 (
  89         uri      => get_config ('uri'),
  90         bind_dn  => get_config ('bind_dn'),
  91         password => get_config ('password')
  92 ) or die ("Unable to connect to LDAP directory server " . get_config ('uri'));
  93
  94 our ($UserCN, $UserID) = LiCoM::Person->get_user ($ENV{'REMOTE_USER'});
  95
  96 if (!$UserID and $Action ne 'save')
  97 {
  98         $Action = 'edit';
  99 }
 100
 101 if (!$UserCN)
 102 {
 103         die ("UserCN is not set. Make sure `AuthLDAPRemoteUserIsDN' in enabled.");
 104 }
 105
 106 if (!defined ($Actions{$Action}))
 107 {
 108         die ("No such action: $Action");
 109 }
 110
 111 if (ref ($Actions{$Action}) eq 'CODE')
 112 {
 113         $Actions{$Action}->();
 114 }
 115 elsif (ref ($Actions{$Action}) eq 'ARRAY')
 116 {
 117         for (@{$Actions{$Action}})
 118         {
 119                 $_->();
 120         }
 121 }
 122
 123 LiCoM::Connection->disconnect ();
 124
 125 exit (0);
 126
 127 ###
 128
 129 sub action_browse
 130 {
 131         my $group = param_utf8 ('group');
 132         $group = shift if (@_);
 133         $group ||= '';
 134
 135         if (!$group)
 136         {
 137                 my @groups = LiCoM::Group->all ();
 138
 139                 print qq(\t\t<h2>Contact groups</h2>\n\t\t<ul class="groups">\n);
 140                 for (@groups)
 141                 {
 142                         my $group = $_;
 143                         my @members = $group->get_members ();
 144                         my $members = scalar (@members);
 145                         my $group_name = $group->name ();
 146                         my $group_uri  = uri_escape_utf8 ($group_name);
 147                         my $desc = $group->description ();
 148
 149                         print qq#\t\t\t<li><a href="$MySelf?action=browse&group=$group_uri">#,
 150                         encode_entities ($group_name),
 151                         qq#</a> ($members Member#, ($members == 1 ? ')' : 's)');
 152                         print qq(<br />\n\t\t\t\t<span class="description">),
 153                         encode_entities ($desc) . '</span>' if ($desc);
 154                         print "</li>\n";
 155                 }
 156                 if (!@groups)
 157                 {
 158                         print qq(\t\t\t<li class="empty">There are no groups yet.</li>\n);
 159                 }
 160                 print <<EOF;
 161                 </ul>
 162                 <div class="menu">
 163                         [<a href="$MySelf?action=list">List&nbsp;all</a>]
 164                 </div>
 165 EOF
 166         }
 167         else
 168         {
 169                 my $group_obj    = LiCoM::Group->load ($group);
 170                 my $group_uri    = uri_escape_utf8 ($group_obj->name ());
 171                 my $group_html   = encode_entities ($group_obj->name ());
 172                 my @member_names = $group_obj->get_members ();
 173                 my $desc         = $group_obj->description ();
 174                 my $desc_html    = encode_entities ($desc || '');
 175
 176                 print qq(\t\t<h2>Contact group &quot;$group_html&quot;</h2>\n);
 177                 print qq(\t\t<div>$desc_html</div>\n) if ($desc);
 178                 print qq(\t\t<ul class="results">\n);
 179                 for (sort (@member_names))
 180                 {
 181                         my $cn = $_;
 182                         my $cn_uri  = uri_escape_utf8 ($cn);
 183                         my $cn_html = encode_entities ($cn);
 184
 185                         print qq(\t\t\t<li><a href="$MySelf?action=detail&cn=$cn_uri">$cn_html</a></li>\n);
 186                 }
 187
 188                 print <<EOF;
 189                 </ul>
 190                 <div class="menu">
 191                         [<a href="$MySelf?action=list&group=$group_uri">List</a>]
 192                         [<a href="$MySelf?action=browse">Back</a>]
 193                         [<a href="$MySelf?action=edit_group&group=$group_uri">Edit</a>]
 194                 </div>
 195 EOF
 196         }
 197 }
 198
 199 sub action_list
 200 {
 201         my $group_name = param_utf8 ('group');
 202         $group_name = shift if (@_);
 203         $group_name ||= '';
 204
 205         my $group_name_html = encode_entities ($group_name || '');
 206
 207         my $title = $group_name
 208                 ? "List of group &quot;$group_name_html&quot;"
 209                 : 'List of all addresses';
 210         my @fields = (qw(address homephone cellphone officephone fax mail));
 211
 212         my @all = ();
 213         if ($group_name)
 214         {
 215                 my $group_obj = LiCoM::Group->load ($group_name);
 216                 if (!$group_obj)
 217                 {
 218                         print <<HTML;
 219                 <div class="error">
 220                         Unable to load group &quot;$group_name_html&quot;.
 221                 </div>
 222 HTML
 223                         return;
 224                 }
 225                 for ($group_obj->get_members ())
 226                 {
 227                         my $cn = $_;
 228                         my $person_obj = LiCoM::Person->load ($cn);
 229
 230                         if (!$person_obj)
 231                         {
 232                                 print STDERR "Unable to load cn = $cn;\n";
 233                                 next;
 234                         }
 235                         push (@all, $person_obj);
 236                 }
 237         }
 238         else
 239         {
 240                 @all = LiCoM::Person->search ([[group => $group_name]]);
 241         }
 242
 243         print <<EOF;
 244                 <h2>$title</h2>
 245
 246                 <table class="list">
 247                         <tr>
 248                                 <th>Name</th>
 249 EOF
 250         for (@fields)
 251         {
 252                 print "\t\t\t\t<th>" . (defined ($FieldNames{$_}) ? $FieldNames{$_} : $_) . "</th>\n";
 253         }
 254         print "\t\t\t</tr>\n";
 255
 256         for (sort { $a->name () cmp $b->name () } (@all))
 257         {
 258                 my $person = $_;
 259                 my $cn = $person->name ();
 260                 my $sn = $person->lastname ();
 261                 my $gn = $person->firstname ();
 262
 263                 my $cn_uri  = uri_escape_utf8 ($cn);
 264                 my $cn_html = encode_entities ("$sn, $gn");
 265
 266                 print "\t\t\t<tr>\n",
 267                 qq(\t\t\t\t<td><a href="$MySelf?action=detail&cn=$cn_uri">$cn_html</a></td>\n);
 268
 269                 for (@fields)
 270                 {
 271                         my $field = $_;
 272                         my @values = $person->get ($field);
 273                         print "\t\t\t\t<td>" . join ('<br />', map { markup_field ($field, $_) } (@values)) . "</td>\n";
 274                 }
 275
 276                 print "\t\t\t</tr>\n";
 277         }
 278         print "\t\t</table>\n\n";
 279
 280         if ($group_name)
 281         {
 282                 my $group_esc = uri_escape_utf8 ($group_name);
 283                 print qq(\t\t<div class="menu">[<a href="$MySelf?action=browse&group=$group_esc">Back</a>]</div>\n);
 284         }
 285         else
 286         {
 287                 print qq(\t\t<div class="menu">[<a href="$MySelf?action=browse">Back</a>]</div>\n);
 288         }
 289 }
 290
 291 sub action_detail
 292 {
 293         my $cn = param_utf8 ('cn');
 294         $cn = shift if (@_);
 295         die unless ($cn);
 296
 297         my $cn_html = encode_entities ($cn);
 298         my $cn_uri  = uri_escape_utf8 ($cn);
 299
 300         my $person = LiCoM::Person->load ($cn);
 301         if (!$person)
 302         {
 303                 print qq(\t<div>Entry &quot;$cn_html&quot; could not be loaded from DB.</div>\n);
 304                 return;
 305         }
 306
 307         print qq(\t\t<h2>Details for $cn_html</h2>\n);
 308
 309         print <<EOF;
 310                 <table class="detail">
 311                         <tr>
 312                                 <th>Name</th>
 313                                 <td>$cn_html</td>
 314                         </tr>
 315 EOF
 316         for (@MultiFields)
 317         {
 318                 my $field = $_;
 319                 my $values = $person->get ($field);
 320                 my $num = scalar (@$values);
 321                 my $field_name = defined ($FieldNames{$field}) ? $FieldNames{$field} : $field;
 322
 323                 next unless ($num);
 324
 325                 $field_name = encode_entities ($field_name);
 326
 327                 print "\t\t\t<tr>\n";
 328                 if ($num > 1)
 329                 {
 330                         print qq(\t\t\t\t<th rowspan="$num">$field_name</th>\n);
 331                 }
 332                 else
 333                 {
 334                         print qq(\t\t\t\t<th>$field_name</th>\n);
 335                 }
 336
 337                 for (my $i = 0; $i < $num; $i++)
 338                 {
 339                         my $val = markup_field ($field, $values->[$i]);
 340
 341                         print "\t\t\t<tr>\n" if ($i);
 342                         print "\t\t\t\t<td>$val</td>\n",
 343                         "\t\t\t</tr>\n";
 344                 }
 345         }
 346
 347         my @groups = LiCoM::Group->load_by_member ($cn);
 348         if (@groups)
 349         {
 350                 my $num = scalar (@groups);
 351                 print "\t\t\t<tr>\n",
 352                 "\t\t\t\t<th", ($num == 1 ? '' : qq( rowspan="$num")), ">Group", ($num == 1 ? '' : 's'), "</th>\n";
 353                 for (my $i = 0; $i < $num; $i++)
 354                 {
 355                         my $group = $groups[$i];
 356                         my $group_name = $group->name ();
 357                         my $group_uri  = uri_escape_utf8 ($group_name);
 358                         my $group_html = encode_entities ($group_name);
 359
 360                         print "\t\t\t<tr>\n" if ($i != 0);
 361                         print qq(\t\t\t\t<td><a href="$MySelf?action=browse&group=$group_uri">$group_html</a></td>\n),
 362                         "\t\t\t</tr>\n";
 363                 }
 364         }
 365
 366         print <<EOF;
 367                 </table>
 368
 369                 <div class="menu">
 370                         [<a href="$MySelf?action=verify&cn=$cn_uri">Verify</a>]
 371                         [<a href="$MySelf?action=vcard&cn=$cn_uri">vCard</a>]
 372                         [<a href="$MySelf?action=edit&cn=$cn_uri">Edit</a>]
 373                         [<a href="$MySelf?action=delete&cn=$cn_uri">Delete</a>]
 374                 </div>
 375
 376 EOF
 377 }
 378
 379 sub action_search
 380 {
 381         my $search = param_utf8 ('search');
 382
 383         $search ||= '';
 384         $search =~ s/[^\s\w]//g;
 385
 386         if (!$search)
 387         {
 388                 print qq(\t<div class="error">Sorry, the empty search is not allowed.</div>\n);
 389                 action_default ();
 390                 return;
 391         }
 392
 393         my @patterns = split (m/\s+/, $search);
 394         my @filter = ();
 395
 396         for (@patterns)
 397         {
 398                 my $pattern = "$_*";
 399                 push (@filter, [[lastname => $pattern], [firstname => $pattern]]);
 400         }
 401
 402         my @matches = LiCoM::Person->search (@filter);
 403
 404         if (!@matches)
 405         {
 406                 print qq(\t<div>No entries matched your search.</div>\n);
 407                 return;
 408         }
 409
 410         if (scalar (@matches) == 1)
 411         {
 412                 my $person = shift (@matches);
 413                 my $cn = $person->name ();
 414                 action_detail ($cn);
 415                 return;
 416         }
 417
 418         print qq(\t<ul class="result">\n);
 419         for (sort { $a->name () cmp $b->name () } (@matches))
 420         {
 421                 my $person = $_;
 422                 my $cn = $person->name ();
 423                 my $cn_uri  = uri_escape_utf8 ($cn);
 424                 my $cn_html = encode_entities ($cn);
 425
 426                 print qq(\t\t<li><a href="$MySelf?action=detail&cn=$cn_uri">$cn_html</a></li>\n);
 427         }
 428         print qq(\t</ul>\n);
 429 }
 430
 431 sub action_edit
 432 {
 433         my %opts = @_;
 434
 435         my $cn = param_utf8 ('cn');
 436
 437         $cn = $opts{'cn'} if (defined ($opts{'cn'}));
 438         $cn ||= '';
 439
 440         my $cn_html = encode_entities ($cn);
 441
 442         if (!$UserID)
 443         {
 444                 $cn = $UserCN;
 445         }
 446
 447         my $person;
 448
 449         my $lastname;
 450         my $firstname;
 451
 452         my $lastname_html;
 453         my $firstname_html;
 454
 455         my $contacts = {};
 456         $contacts->{$_} = [] for (@MultiFields);
 457
 458         if ($cn)
 459         {
 460                 $person = LiCoM::Person->load ($cn);
 461
 462                 if (!$person)
 463                 {
 464                         print qq(\t<div class="error">Unable to load CN &quot;$cn&quot;. Sorry.</div>\n);
 465                         return;
 466                 }
 467
 468                 $lastname    = $person->lastname ();
 469                 $firstname   = $person->firstname ();
 470
 471                 for (@MultiFields)
 472                 {
 473                         $contacts->{$_} = $person->get ($_);
 474                 }
 475         }
 476
 477         $lastname  = param_utf8 ('lastname')  if (param_utf8 ('lastname')  and $UserID);
 478         $firstname = param_utf8 ('firstname') if (param_utf8 ('firstname') and $UserID);
 479
 480         get_contacts ($contacts);
 481
 482         $lastname    =   $opts{'lastname'}     if (defined ($opts{'lastname'}));
 483         $firstname   =   $opts{'firstname'}    if (defined ($opts{'firstname'}));
 484         $lastname_html  = encode_entities ($lastname);
 485         $firstname_html = encode_entities ($firstname);
 486
 487         for (@MultiFields)
 488         {
 489                 my $field = $_;
 490                 @{$contacts->{$field}} = @{$opts{$field}} if (defined ($opts{$field}));
 491         }
 492
 493         if ($cn)
 494         {
 495                 print "\t\t<h2>Edit contact $cn_html</h2>\n";
 496         }
 497         else
 498         {
 499                 print "\t\t<h2>Create new contact</h2>\n";
 500         }
 501
 502         print <<EOF;
 503                 <form action="$MySelf" method="post" accept-charset="UTF-8">
 504                 <input type="hidden" name="action" value="save" />
 505                 <input type="hidden" name="cn" value="$cn_html" />
 506                 <table class="edit">
 507                         <tr>
 508                                 <th>Lastname</th>
 509 EOF
 510         if ($UserID)
 511         {
 512                 print qq(\t\t\t\t<td><input type="text" name="lastname" value="$lastname_html" /></td>\n);
 513         }
 514         else
 515         {
 516                 print qq(\t\t\t\t<td>$lastname_html</td>\n);
 517         }
 518         print <<EOF;
 519                         </tr>
 520                         <tr>
 521                                 <th>Firstname</th>
 522 EOF
 523         if ($UserID)
 524         {
 525                 print qq(\t\t\t\t<td><input type="text" name="firstname" value="$firstname_html" /></td>\n);
 526         }
 527         else
 528         {
 529                 print qq(\t\t\t\t<td>$firstname_html</td>\n);
 530         }
 531
 532         print "\t\t\t</tr>\n";
 533
 534         for (@MultiFields)
 535         {
 536                 my $field = $_;
 537                 my $print = defined ($FieldNames{$field}) ? $FieldNames{$field} : $field;
 538                 my @values = @{$contacts->{$field}};
 539
 540                 next if ($field eq 'group');
 541
 542                 push (@values, '');
 543
 544                 $field = encode_entities ($field);
 545                 $print = encode_entities ($print);
 546
 547                 for (@values)
 548                 {
 549                         my $value = encode_entities ($_);
 550
 551                         print <<EOF;
 552                         <tr>
 553                                 <th>$print</th>
 554                                 <td><input type="text" name="$field" value="$value" /></td>
 555                         </tr>
 556 EOF
 557                 }
 558         }
 559
 560         if ($UserID)
 561         {
 562                 my @all_groups = LiCoM::Group->all ();
 563
 564                 if (@all_groups)
 565                 {
 566                         print "\t\t\t<tr>\n",
 567                         "\t\t\t\t<th>Group(s)</th>\n",
 568                         qq(\t\t\t\t<td><select name="group" multiple="multiple" size="5">\n);
 569
 570                         for (@all_groups)
 571                         {
 572                                 my $group = $_;
 573                                 my $group_name = encode_entities ($group->name ());
 574                                 my $selected = '';
 575
 576                                 if (grep { $cn eq $_ } ($group->get_members ()))
 577                                 {
 578                                         $selected = ' selected="selected"';
 579                                 }
 580
 581                                 print qq(\t\t\t\t\t<option value="$group_name"$selected>$group_name</option>\n);
 582                         }
 583                         print "\t\t\t\t</select></td>\n",
 584                         "\t\t\t</tr>\n";
 585                 }
 586
 587                 print "\t\t\t<tr>\n",
 588                 "\t\t\t\t<th>New Group</th>\n",
 589                 qq(\t\t\t\t<td><input type="text" name="newgroup" value="" /></td>\n),
 590                 "\t\t\t</tr>\n";
 591         }
 592
 593         print <<EOF;
 594                         <tr>
 595                                 <th colspan="2" class="menu">
 596 EOF
 597         if ($UserID)
 598         {
 599                 print <<EOF;
 600                                         <input type="submit" name="button" value="Cancel" />
 601                                         <input type="submit" name="button" value="Apply" />
 602 EOF
 603         }
 604         print <<EOF;
 605                                         <input type="submit" name="button" value="Save" />
 606                                 </th>
 607                         </tr>
 608                 </table>
 609                 </form>
 610 EOF
 611 }
 612
 613 sub action_save
 614 {
 615         my $cn = $UserID ? param_utf8 ('cn') : $UserCN;
 616
 617         if (verify_fields ())
 618         {
 619                 action_edit (cn => $cn);
 620                 return;
 621         }
 622
 623         if ($cn)
 624         {
 625                 action_update ();
 626                 return;
 627         }
 628
 629         die unless ($UserID);
 630
 631         my $button = lc (param_utf8 ('button'));
 632         $button ||= 'save';
 633
 634         if ($button eq 'cancel')
 635         {
 636                 action_browse ();
 637                 return;
 638         }
 639
 640         if (!param_utf8 ('lastname') or !param_utf8 ('firstname'))
 641         {
 642                 print qq(\t<div class="error">You have to give both, first and lastname, to identify this record.</div>\n);
 643                 action_edit (cn => '');
 644                 return;
 645         }
 646
 647         my $lastname  = param_utf8 ('lastname');
 648         my $firstname = param_utf8 ('firstname');
 649
 650         my $contacts = get_contacts ();
 651
 652         my $person = LiCoM::Person->create (lastname => $lastname, firstname => $firstname, %$contacts);
 653
 654         if (!$person)
 655         {
 656                 print qq(\t<div class="error">Unable to save entry. Sorry.</div>\n);
 657                 return;
 658         }
 659
 660         $cn = $person->name ();
 661
 662         for (param_utf8 ('group'))
 663         {
 664                 my $group_name = $_;
 665                 my $group = LiCoM::Group->load ($group_name);
 666
 667                 if ($group)
 668                 {
 669                         $group->add_members ($cn);
 670                 }
 671                 else
 672                 {
 673                         my $group_html = encode_entities ($group_name);
 674                         print qq(\t<div class="error">Group &quot;$group_html&quot; does not exist or could not be loaded.</div>\n);
 675                 }
 676         }
 677
 678         if (param_utf8 ('newgroup'))
 679         {
 680                 # FIXME add error handling
 681                 my $group_name = param_utf8 ('newgroup');
 682                 LiCoM::Group->create ($group_name, '', $cn);
 683         }
 684
 685         if ($button eq 'apply')
 686         {
 687                 action_edit (cn => $cn);
 688         }
 689         else
 690         {
 691                 action_detail ($cn);
 692         }
 693 }
 694
 695 sub action_update
 696 {
 697         my $cn = $UserID ? param_utf8 ('cn') : $UserCN;
 698
 699         my $person = LiCoM::Person->load ($cn);
 700         die ("Unable to load CN `$cn'") unless ($person);
 701
 702         my $button = lc (param_utf8 ('button'));
 703         $button ||= 'save';
 704
 705         if ($UserID and $button eq 'cancel')
 706         {
 707                 action_detail ($cn);
 708                 return;
 709         }
 710
 711         if ($UserID)
 712         {
 713                 my $lastname  = param_utf8 ('lastname');
 714                 my $firstname = param_utf8 ('firstname');
 715
 716                 my $old_cn = $person->name ();
 717
 718                 print <<HTML;
 719 <div><code>
 720         \$lastname = $lastname<br />
 721         \$firstname = $firstname<br />
 722         \$old_cn = $old_cn
 723 </code></div>
 724 HTML
 725
 726                 $person->lastname  ($lastname)  if ($lastname  and $lastname  ne $person->lastname ());
 727                 $person->firstname ($firstname) if ($firstname and $firstname ne $person->firstname ());
 728
 729                 $cn = $person->name ();
 730
 731                 # Change the cn's saved in the groups
 732                 if ($old_cn ne $cn)
 733                 {
 734                         my @groups = LiCoM::Group->load_by_member ($old_cn);
 735                         for (@groups)
 736                         {
 737                                 # ->del_members automatically deleted the
 738                                 # group, if no more members exist. So this
 739                                 # order is important.
 740                                 print "<div><code>\$cn = " . encode_entities ($cn) . "; "
 741                                 . "\$old_cn = " . encode_entities ($old_cn) . ";</code></div>\n";
 742                                 $_->add_members ($cn);
 743                                 $_->del_members ($old_cn);
 744                         }
 745                 } # if ($old_cn ne $cn)
 746         }
 747
 748         my $contacts = get_contacts ();
 749
 750         for (@MultiFields)
 751         {
 752                 my $field = $_;
 753
 754                 next if (!$UserID and $field eq 'group');
 755
 756                 if (defined ($contacts->{$field}))
 757                 {
 758                         my $values = $contacts->{$field};
 759                         $person->set ($field, $values);
 760                 }
 761                 else
 762                 {
 763                         $person->set ($field, []);
 764                 }
 765         }
 766
 767         # only `authorized' users may see and change groups
 768         if ($UserID)
 769         {
 770                 my %changed_groups = map { $_ => 1 } (param_utf8 ('group'));
 771                 my @current_groups = LiCoM::Group->load_by_member ($cn);
 772
 773                 for (@current_groups)
 774                 {
 775                         my $group_obj = $_;
 776                         my $group_name = $group_obj->name ();
 777
 778                         if (!defined ($changed_groups{$group_name}))
 779                         {
 780                                 $group_obj->del_members ($cn);
 781                         }
 782                         else
 783                         {
 784                                 delete ($changed_groups{$group_name});
 785                         }
 786                 }
 787                 for (keys %changed_groups)
 788                 {
 789                         my $group_name = $_;
 790                         my $group_obj = LiCoM::Group->load ($group_name) or die;
 791
 792                         $group_obj->add_members ($cn);
 793                 }
 794
 795                 if (param_utf8 ('newgroup'))
 796                 {
 797                         # FIXME add error handling
 798                         my $group_name = param_utf8 ('newgroup');
 799                         LiCoM::Group->create ($group_name, '', $cn);
 800                 }
 801         }
 802
 803         if (!$UserID)
 804         {
 805                 print <<HTML;
 806                 <h3>Your changes have been saved.</h3>
 807                 <p>Thank you very much for taking the time to keep this record up to date.</p>
 808
 809 HTML
 810         }
 811
 812         if ($button eq 'apply' or !$UserID)
 813         {
 814                 action_edit (cn => $cn);
 815         }
 816         else
 817         {
 818                 action_detail ($cn);
 819         }
 820 }
 821
 822 sub action_vcard
 823 {
 824         my $cn = param_utf8 ('cn');
 825         $cn = shift if (@_);
 826         die unless ($cn);
 827
 828         my $person = LiCoM::Person->load ($cn);
 829         die unless ($person);
 830
 831         my %vcard_types =
 832         (
 833                 homephone       => 'TEL;TYPE=home,voice',
 834                 cellphone       => 'TEL;TYPE=cell',
 835                 officephone     => 'TEL;TYPE=work,voice',
 836                 fax             => 'TEL;TYPE=fax',
 837                 mail            => 'EMAIL',
 838                 uri             => 'URL',
 839                 group           => 'ORG'
 840         );
 841
 842         my $sn = $person->lastname ();
 843         my $gn = $person->firstname ();
 844         my $cn_esc = uri_escape_utf8 ($cn);
 845
 846         print <<EOF;
 847 Content-Type: text/x-vcard
 848 Content-Disposition: attachment; filename="$cn.vcf"
 849
 850 BEGIN:VCARD
 851 VERSION:3.0
 852 FN: $cn
 853 N: $sn;$gn
 854 EOF
 855
 856         for (@MultiFields)
 857         {
 858                 my $field = $_;
 859                 my $vc_fld = $vcard_types{$field};
 860                 my $values = $person->get ($field);
 861
 862                 next unless ($vc_fld);
 863
 864                 for (@$values)
 865                 {
 866                         my $value = $_;
 867                         print "$vc_fld:$value\n";
 868                 }
 869         }
 870         print "END:VCARD\n";
 871 }
 872
 873 sub action_verify
 874 {
 875         my $cn = param_utf8 ('cn');
 876         $cn = shift if (@_);
 877         die unless ($cn);
 878
 879         my $cn_html = encode_entities ($cn);
 880
 881         my $person = LiCoM::Person->load ($cn);
 882         die unless ($person);
 883
 884         my ($mail) = $person->get ('mail');
 885         $mail ||= '';
 886
 887         my $message;
 888         my ($password) = $person->get ('password');
 889         my $password_html;
 890
 891         if (!$password)
 892         {
 893                 $password = pwgen ();
 894                 $person->set ('password', [$password]);
 895         }
 896         $password_html = encode_entities ($password);
 897
 898         $message = qq(The password for the record &quot;$cn_html&quot; is &quot;$password_html&quot;.);
 899
 900         if ($mail)
 901         {
 902                 if (action_verify_send_mail ($person))
 903                 {
 904                         my $mail_html = encode_entities ($mail);
 905                         $message .= qq( A request for verification has been sent to $mail_html.);
 906                 }
 907         }
 908         else
 909         {
 910                 $message .= q( There was no e-mail address, thus no verification request could be sent.);
 911         }
 912
 913         print qq(\t\t<div class="message">$message</div>\n);
 914
 915         action_detail ($cn);
 916 }
 917
 918 sub action_verify_send_mail
 919 {
 920         my $person = shift;
 921         my $owner = LiCoM::Person->load ($UserCN);
 922         my $smh;
 923
 924         my ($owner_mail) = $owner->get ('mail');
 925         if (!$owner_mail)
 926         {
 927                 my $cn_uri = uri_escape_utf8 ($UserCN);
 928                 print qq(\t\t<div class="error">You have no email set in your own profile. <a href="$MySelf?action=edit&cn=$cn_uri">Edit it now</a>!</div>\n);
 929                 return (0);
 930         }
 931
 932         my $max_width = 0;
 933         for (keys %FieldNames)
 934         {
 935                 $max_width = length $FieldNames{$_} if ($max_width < length $FieldNames{$_});
 936         }
 937         $max_width++;
 938
 939         my $person_name   = $person->name ();
 940         my ($person_mail) = $person->get ('mail');
 941         my $person_gn     = $person->firstname ();
 942         my ($password)    = $person->get ('password');
 943
 944         my $host = $ENV{'HTTP_HOST'};
 945         my $url = (defined ($ENV{'HTTPS'}) ? 'https://' : 'http://') . $host . $MySelf;
 946
 947         open ($smh, '|-', '/usr/sbin/sendmail', '-t', '-f', $owner_mail) or die ("open (sendmail): $!");
 948         print $smh <<EOM;
 949 To: $person_name <$person_mail>
 950 From: $UserCN <$owner_mail>
 951 Subject: Please verify our entry in my address book
 952
 953 Hello $person_gn,
 954
 955 the following is your entry in my address book:
 956 EOM
 957         for (@MultiFields)
 958         {
 959                 my $field = $_;
 960                 my $print = defined ($FieldNames{$field}) ? $FieldNames{$field} : $field;
 961                 my @values = $person->get ($field);
 962
 963                 for (@values)
 964                 {
 965                         printf $smh ('%'.$max_width."s: %-s\n", $print, $_);
 966                 }
 967         }
 968         print $smh <<EOM;
 969
 970 If this entry is outdated or incomplete, please take a minute and correct it.
 971   Address: $url
 972  Username: $person_name
 973  Password: $password
 974
 975 Thank you very much :)
 976
 977 Regards,
 978 $UserCN
 979 --
 980 This message was automatically generated by LiCoM,
 981 http://verplant.org/licom/
 982 EOM
 983         close ($smh);
 984
 985         return (1);
 986 }
 987
 988 sub action_ask_del
 989 {
 990         my $cn = param_utf8 ('cn');
 991         $cn or die;
 992
 993         my $person = LiCoM::Person->load ($cn);
 994         $person or die;
 995
 996         my $cn_uri  = uri_escape_utf8 ($cn);
 997         my $cn_html = encode_entities ($cn);
 998
 999         print <<EOF;
1000                 <h2>Really delete $cn_html?</h2>
1001
1002                 <div>
1003                         You are about to delete <strong>$cn_html</strong>.
1004                         Are you totally, absolutely sure you want to do this?
1005                 </div>
1006
1007                 <div class="menu">
1008                         [<a href="$MySelf?action=expunge&cn=$cn_uri">Yes, delete</a>]
1009                         [<a href="$MySelf?action=detail&cn=$cn_uri">No, keep</a>]
1010                 </div>
1011
1012 EOF
1013 }
1014
1015 sub action_do_del
1016 {
1017         my $cn = param_utf8 ('cn');
1018         $cn or die;
1019
1020         my $cn_html = encode_entities ($cn);
1021
1022         my $person = LiCoM::Person->load ($cn);
1023         $person or die;
1024
1025         $person->delete ();
1026
1027         print <<EOF;
1028                 <div>$cn_html has been deleted.</div>
1029
1030 EOF
1031         action_browse ();
1032 }
1033
1034 sub action_edit_group
1035 {
1036         my $group_name = param_utf8 ('group') or die;
1037
1038         my $group_name_html = encode_entities ($group_name);
1039
1040         my $group_obj = LiCoM::Group->load ($group_name);
1041
1042         if (!$group_obj)
1043         {
1044                 print qq(\t<div class="error">Group &quot;$group_name_html&quot; does not exist or could not be loaded.</div>\n);
1045                 return;
1046         }
1047
1048         $group_name_html = encode_entities ($group_obj->name ());
1049
1050         my $desc_html = encode_entities ($group_obj->description () || '');
1051
1052         print <<HTML;
1053         <h2>Edit contact group &quot;$group_name_html&quot;</h2>
1054         <form action="$MySelf" method="post" accept-charset="UTF-8">
1055           <input type="hidden" name="action" value="save_group" />
1056           <input type="hidden" name="group" value="$group_name_html" />
1057           <table>
1058             <tr>
1059               <th>Group Name</th>
1060               <td>$group_name_html</td>
1061             </tr>
1062             <tr>
1063               <th>Description</th>
1064               <td><input type="text" name="description" value="$desc_html" /></td>
1065             </tr>
1066             <tr>
1067               <th colspan="2"><input type="submit" name="button" value="Save" /></th>
1068             </tr>
1069           </table>
1070         </form>
1071 HTML
1072 }
1073
1074 sub action_save_group
1075 {
1076         my $group_name = param_utf8 ('group') or die;
1077
1078         my $group_name_html = encode_entities ($group_name);
1079
1080         my $group_obj = LiCoM::Group->load ($group_name);
1081
1082         if (!$group_obj)
1083         {
1084                 print qq(\t<div class="error">Group &quot;$group_name_html&quot; does not exist or could not be loaded.</div>\n);
1085                 return;
1086         }
1087
1088         my $desc = param_utf8 ('description');
1089         $group_obj->description ($desc);
1090
1091         action_browse ();
1092         return;
1093 }
1094
1095 sub html_start
1096 {
1097         my $title = shift;
1098         $title = q(Lightweight Contact Manager) unless ($title);
1099
1100         $title = encode_entities ($title);
1101
1102         print <<EOF;
1103 Content-Type: text/html; charset=UTF-8
1104
1105 <html>
1106         <head>
1107                 <title>$title</title>
1108                 <style type="text/css">
1109                 <!--
1110                 \@media screen
1111                 {
1112                         a
1113                         {
1114                                 color: blue;
1115                                 background-color: inherit;
1116                                 text-decoration: none;
1117                         }
1118
1119                         a:hover
1120                         {
1121                                 text-decoration: underline;
1122                         }
1123
1124                         a:visited
1125                         {
1126                                 color: navy;
1127                                 background-color: inherit;
1128                         }
1129
1130                         body
1131                         {
1132                                 color: black;
1133                                 background-color: white;
1134                         }
1135
1136                         div.error
1137                         {
1138                                 color: red;
1139                                 background-color: yellow;
1140
1141                                 font-weight: bold;
1142                                 padding: 1ex;
1143                                 border: 2px solid red;
1144                         }
1145
1146                         div.foot
1147                         {
1148                                 color: gray;
1149                                 background-color: white;
1150
1151                                 position: fixed;
1152                                 top: auto;
1153                                 right: 0px;
1154                                 bottom: 0px;
1155                                 left: 0px;
1156
1157                                 font-size: x-small;
1158                                 text-align: right;
1159                                 border-top: 1px solid black;
1160                                 width: 100%;
1161                         }
1162
1163                         div.foot a
1164                         {
1165                                 color: black;
1166                                 background-color: inherit;
1167                                 text-decoration: none;
1168                         }
1169
1170                         div.foot a:hover
1171                         {
1172                                 text-decoration: underline;
1173                         }
1174
1175                         div.menu
1176                         {
1177                                 border-top: 1px solid black;
1178                                 margin-top: 1ex;
1179                                 font-weight: bold;
1180                         }
1181
1182                         div.menu a
1183                         {
1184                                 color: blue;
1185                                 background-color: transparent;
1186                         }
1187
1188                         div.topmenu
1189                         {
1190                                 margin-bottom: 1ex;
1191                                 padding-bottom: 1ex;
1192                                 border-bottom: 1px solid black;
1193                         }
1194
1195                         div.topmenu form
1196                         {
1197                                 display: inline;
1198                                 margin-right: 5ex;
1199                         }
1200
1201                         h1
1202                         {
1203                                 position: absolute;
1204                                 top: 1ex;
1205                                 right: 1ex;
1206                                 bottom: auto;
1207                                 left: auto;
1208
1209                                 font-size: 100%;
1210                                 font-weight: bold;
1211                         }
1212
1213                         img
1214                         {
1215                                 border: none;
1216                         }
1217
1218                         table.list
1219                         {
1220                                 width: 100%;
1221                                 border: 2px solid #d0d0d0;
1222                         }
1223
1224                         table.list td
1225                         {
1226                                 empty-cells: show;
1227                         }
1228
1229                         td
1230                         {
1231                                 color: black;
1232                                 background-color: #e8e8e8;
1233                                 vertical-align: top;
1234                         }
1235
1236                         th
1237                         {
1238                                 color: black;
1239                                 background-color: #d0d0d0;
1240                                 padding: 0.3ex;
1241                                 text-align: left;
1242                                 vertical-align: top;
1243                         }
1244
1245                         ul.groups li
1246                         {
1247                                 margin-top: 0.5ex;
1248                         }
1249                 }
1250
1251                 \@media print
1252                 {
1253                         a
1254                         {
1255                                 color: inherit;
1256                                 background-color: inherit;
1257                                 text-decoration: underline;
1258                         }
1259
1260                         div.topmenu, div.menu
1261                         {
1262                                 display: none;
1263                         }
1264
1265                         div.foot
1266                         {
1267                                 font-size: 50%;
1268                                 text-align: right;
1269                         }
1270
1271                         h1
1272                         {
1273                                 display: none;
1274                         }
1275
1276                         h2
1277                         {
1278                                 font-size: 100%;
1279                         }
1280
1281                         table
1282                         {
1283                                 border-collapse: collapse;
1284                         }
1285
1286                         table.list
1287                         {
1288                                 width: 100%;
1289                         }
1290
1291                         table.list td
1292                         {
1293                                 empty-cells: show;
1294                         }
1295
1296                         table.list th
1297                         {
1298                                 border-bottom-width: 2px;
1299                         }
1300
1301                         td, th
1302                         {
1303                                 border: 1px solid black;
1304                                 vertical-align: top;
1305                         }
1306
1307                         th
1308                         {
1309                                 font-weight: bold;
1310                                 text-align: center;
1311                         }
1312                 }
1313                 //-->
1314                 </style>
1315         </head>
1316
1317         <body>
1318 EOF
1319
1320         if ($UserID)
1321         {
1322                 my $search = param_utf8 ('search') || '';
1323                 $search = encode_entities ($search);
1324                 print <<EOF;
1325                 <div class="topmenu">
1326                         <form action="$MySelf" method="post" accept-charset="UTF-8">
1327                                 <input type="hidden" name="action" value="browse" />
1328                                 <input type="submit" name="button" value="Browse" />
1329                         </form>
1330                         <form action="$MySelf" method="post" accept-charset="UTF-8">
1331                                 <input type="hidden" name="action" value="search" />
1332                                 <input type="text" name="search" value="$search" />
1333                                 <input type="submit" name="button" value="Search" />
1334                         </form>
1335                         <form action="$MySelf" method="post" accept-charset="UTF-8">
1336                                 <input type="hidden" name="action" value="edit" />
1337                                 <input type="hidden" name="dn" value="" />
1338                                 <input type="submit" name="button" value="Add New" />
1339                         </form>
1340                 </div>
1341 EOF
1342         }
1343         print "\t\t<h1>$title</h1>\n";
1344 }
1345
1346 sub html_end
1347 {
1348         print <<EOF;
1349                 <div class="foot">
1350                         &quot;Lightweight Contact Manager&quot;,
1351                         written 2005-2006 by <a href="http://verplant.org/">Florian octo Forster</a>
1352                         &lt;octo at verplant.org&gt;
1353                 </div>
1354         </body>
1355 </html>
1356 EOF
1357 }
1358
1359 sub pwgen
1360 {
1361         my $len = @_ ? shift : 6;
1362         my $retval = '';
1363
1364         while (!$retval)
1365         {
1366                 my $numbers = 0;
1367                 my $lchars  = 0;
1368                 my $uchars  = 0;
1369
1370                 while (length ($retval) < $len)
1371                 {
1372                         my $chr = int (rand (128));
1373
1374                         if ($chr >= 48 and $chr < 58)
1375                         {
1376                                 $numbers++;
1377                         }
1378                         elsif ($chr >= 65 and $chr < 91)
1379                         {
1380                                 $uchars++;
1381                         }
1382                         elsif ($chr >= 97 and $chr < 123)
1383                         {
1384                                 $lchars++;
1385                         }
1386                         else
1387                         {
1388                                 next;
1389                         }
1390                         $retval .= chr ($chr);
1391                 }
1392
1393                 $retval = '' if (!$numbers or !$lchars or !$uchars);
1394         }
1395
1396         return ($retval);
1397 }
1398
1399 sub verify_fields
1400 {
1401         my @errors = ();
1402         for (param_utf8 ('uri'))
1403         {
1404                 my $val = $_;
1405                 next unless ($val);
1406
1407                 if ($val !~ m#^[a-zA-Z]+://#)
1408                 {
1409                         push (@errors, 'URIs have to begin with a protocol, e.g. &quot;http://&quot;, &quot;ftp://&quot; etc.');
1410                         last;
1411                 }
1412         }
1413
1414         for (param_utf8 ('homephone'), param_utf8 ('cellphone'), param_utf8 ('officephone'), param_utf8 ('fax'))
1415         {
1416                 my $number = $_;
1417                 next unless ($number);
1418
1419                 if ($number !~ m/^\+[0-9 \-]+$/)
1420                 {
1421                         push (@errors, 'Telephone numbers have to begin with the country code and only numbers, spaces and dashes are allowed, e.g. &quot;+49 911-123456&quot;');
1422                         last;
1423                 }
1424         }
1425
1426         print qq(\t\t<div class="error">\n) if (@errors);
1427         for (my $i = 0; $i < scalar (@errors); $i++)
1428         {
1429                 my $e = $errors[$i];
1430
1431                 print "<br />\n" if ($i);
1432                 print "\t\t\t$e";
1433         }
1434         print qq(\n\t\t</div>\n\n) if (@errors);
1435
1436         return (scalar (@errors));
1437 }
1438
1439 sub markup_field
1440 {
1441         my $field = shift;
1442         my $value = shift;
1443
1444         my $value_uri  = uri_escape_utf8 ($value);
1445         my $value_html = encode_entities ($value);
1446
1447         if ($field eq 'group')
1448         {
1449                 return (qq(<a href="$MySelf?action=browse&group=$value_uri">$value_html</a>));
1450         }
1451         elsif ($field eq 'uri')
1452         {
1453                 if ($value =~ m#^([a-z]+)://(.+)$#)
1454                 {
1455                         $value_uri = $1 . '://' . uri_escape_utf8 ($2);
1456                 }
1457                 else
1458                 {
1459                         $value_uri = 'http://' . uri_escape_utf8 ($value);
1460                 }
1461                 return (qq(<a href="$value_uri" class="extern">$value_html</a>));
1462         }
1463         elsif ($field eq 'mail')
1464         {
1465                 return (qq(<a href="mailto:$value_uri" class="mail">$value_html</a>));
1466         }
1467         return ($value_html);
1468 }
1469
1470 sub get_contacts
1471 {
1472         my $contacts = @_ ? shift : {};
1473
1474         for (@MultiFields)
1475         {
1476                 my $field = $_;
1477                 my @values = grep { $_ } (param_utf8 ($field));
1478
1479                 next unless (@values);
1480
1481                 if ($field eq 'homephone' or $field eq 'cellphone' or $field eq 'officephone' or $field eq 'fax')
1482                 {
1483                         for (@values)
1484                         {
1485                                 $_ =~ s/[^0-9 \-]//g;
1486                                 $_ = '+' . $_ if ($_);
1487                         }
1488                 }
1489
1490                 $contacts->{$field} = [@values] if (@values);
1491         }
1492
1493         return ($contacts);
1494 }
1495
1496 sub is_valid_utf8
1497 {
1498         my $str = join ('', @_);
1499
1500         # Taken from here: <http://www.w3.org/International/questions/qa-forms-utf-8>
1501         return ($str =~ m/^(
1502      [\x09\x0A\x0D\x20-\x7E]            # ASCII
1503    | [\xC2-\xDF][\x80-\xBF]             # non-overlong 2-byte
1504    |  \xE0[\xA0-\xBF][\x80-\xBF]        # excluding overlongs
1505    | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}  # straight 3-byte
1506    |  \xED[\x80-\x9F][\x80-\xBF]        # excluding surrogates
1507    |  \xF0[\x90-\xBF][\x80-\xBF]{2}     # planes 1-3
1508    | [\xF1-\xF3][\x80-\xBF]{3}          # planes 4-15
1509    |  \xF4[\x80-\x8F][\x80-\xBF]{2}     # plane 16
1510   )*$/x);
1511 }
1512
1513 sub param_utf8
1514 {
1515         my @args = @_;
1516         my @ret = ();
1517
1518         @ret = grep { is_valid_utf8 ($_) } (param (@args));
1519         $_ = decode ('UTF-8', $_) for (@ret);
1520         return (wantarray () ? @ret : $ret[0]);
1521 }
1522
1523 sub uri_escape_utf8
1524 {
1525         return (uri_escape (encode ('UTF-8', shift)));
1526 }