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