root/trunk/cgi-bin/ljprotocol.pl @ 925

Revision 925, 83.2 KB (checked in by bradfitz, 11 years ago)

die tab
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1#!/usr/bin/perl
2#
3
4use strict;
5
6require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
7require "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
8require "$ENV{'LJHOME'}/cgi-bin/console.pl";
9
10#### New interface (meta handler) ... other handlers should call into this.
11package LJ::Protocol;
12
13sub error_message
14{
15    my $code = shift;
16    my $des;
17    if ($code =~ /^(\d\d\d):(.+)/) {
18        ($code, $des) = ($1, $2);
19    }
20    my %e = (
21             # User Errors
22             "100" => "Invalid username",
23             "101" => "Invalid password",
24             "102" => "Can't use custom security on shared/community journals.",
25             "103" => "Poll error",
26             "104" => "Error adding one or more friends",
27             "150" => "Can't post as non-user",
28             "151" => "Banned from journal",
29             "152" => "Can't make back-dated entries in non-personal journal.",
30
31             # Client Errors
32             "200" => "Missing required argument(s)",
33             "201" => "Unknown method",
34             "202" => "Too many arguments",
35             "203" => "Invalid argument(s)",
36             "204" => "Invalid metadata datatype",
37             "205" => "Unknown metadata",
38             "206" => "Invalid destination journal username.",
39             "207" => "Protocol version mismatch",
40             "208" => "Invalid text encoding",
41
42             # Access Errors
43             "300" => "Don't have access to shared/community journal",
44             "301" => "Access of restricted feature",
45             "302" => "Can't edit post from requested journal",
46             "303" => "Can't edit post in community journal",
47             "304" => "Can't delete post in this community journal",
48             "305" => "Action forbidden; account is suspended.",
49             "306" => "This journal is temporarily in read-only mode.  Try again in a couple minutes.",
50
51             # Server Errors
52             "500" => "Internal server error",
53             "501" => "Database error",
54             "502" => "Database temporarily unavailable",
55             );
56
57    my $prefix = "";
58    my $error = $e{$code} || "BUG: Unknown error code!";
59    if ($code >= 200) { $prefix = "Client error: "; }
60    if ($code >= 500) { $prefix = "Server error: "; }
61    my $totalerror = "$prefix$error";
62    $totalerror .= ": $des" if $des;
63    return $totalerror;
64}
65
66# returns result, or undef on failure
67sub do_request_without_db
68{
69    my ($method, $req, $err, $flags) = @_;
70    my $dbs = LJ::get_dbs();
71    return fail($err,500) unless $dbs;
72    return do_request($dbs, $method, $req, $err, $flags);
73}
74
75sub do_request
76{
77    # get the request and response hash refs
78    my ($dbs, $method, $req, $err, $flags) = @_;
79
80    # if version isn't specified explicitly, it's version 0
81    $req->{'ver'} = 0 unless defined $req->{'ver'};
82
83    $flags ||= {};
84    my @args = ($dbs, $req, $err, $flags);
85
86    if ($method eq "login")            { return login(@args);            }
87    if ($method eq "getfriendgroups")  { return getfriendgroups(@args);  }
88    if ($method eq "getfriends")       { return getfriends(@args);       }
89    if ($method eq "friendof")         { return friendof(@args);         }
90    if ($method eq "checkfriends")     { return checkfriends(@args);     }
91    if ($method eq "getdaycounts")     { return getdaycounts(@args);     }
92    if ($method eq "postevent")        { return postevent(@args);        }
93    if ($method eq "editevent")        { return editevent(@args);        }
94    if ($method eq "syncitems")        { return syncitems(@args);        }
95    if ($method eq "getevents")        { return getevents(@args);        }
96    if ($method eq "editfriends")      { return editfriends(@args);      }
97    if ($method eq "editfriendgroups") { return editfriendgroups(@args); }
98    if ($method eq "consolecommand")   { return consolecommand(@args);   }
99
100    return fail($err,201);
101}
102
103sub login
104{
105    my ($dbs, $req, $err, $flags) = @_;
106    return undef unless authenticate($dbs, $req, $err, $flags);
107
108    my $dbh = $dbs->{'dbh'};
109    return fail($err,502) unless $dbh && $dbs->{'reader'};
110
111    my $u = $flags->{'u'};
112    my $res = {};
113    my $ver = $req->{'ver'};
114
115    ## check for version mismatches
116    ## non-Unicode installations can't handle versions >=1
117
118    return fail($err,207, "This installation does not support Unicode clients")
119        if $ver>=1 and not $LJ::UNICODE;
120
121    ## return a message to the client to be displayed (optional)
122    login_message($dbs, $req, $res, $flags);
123    LJ::text_out(\$res->{'message'}) if $ver>=1 and defined $res->{'message'};
124
125    ## report what shared journals this user may post in
126    $res->{'usejournals'} = list_usejournals($dbs, $u);
127
128    ## return their friend groups
129    $res->{'friendgroups'} = list_friendgroups($dbs, $u);
130    if ($ver >= 1) {
131        foreach (@{$res->{'friendgroups'}}) {
132            LJ::text_out(\$_->{'name'});
133        }
134    }
135
136    ## if they gave us a number of moods to get higher than, then return them
137    if (defined $req->{'getmoods'}) {
138        $res->{'moods'} = list_moods($dbs, $req->{'getmoods'});
139        if ($ver >= 1) {
140            # currently all moods are in English, but this might change
141            foreach (@{$res->{'moods'}}) { LJ::text_out(\$_->{'name'}) }
142        }
143    }
144
145    ### picture keywords, if they asked for them.
146    if ($req->{'getpickws'}) {
147        my $pickws = list_pickws($dbs, $u);
148        $res->{'pickws'} = [ map { $_->[0] } @$pickws ];
149        if ($req->{'getpickwurls'}) {
150            $res->{'pickwurls'} = [ map {
151                "$LJ::SITEROOT/userpic/$_->[1]"
152            } @$pickws ];
153        }
154        if ($ver >= 1) {
155            # validate all text
156            foreach(@{$res->{'pickws'}}) { LJ::text_out(\$_); }
157            foreach(@{$res->{'pickwurls'}}) { LJ::text_out(\$_); }
158        }
159    }
160
161    ## return client menu tree, if requested
162    if ($req->{'getmenus'}) {
163        $res->{'menus'} = hash_menus($dbs, $u);
164        if ($ver >= 1) {
165            # validate all text, just in case, even though currently
166            # it's all English
167            foreach (@{$res->{'menus'}}) {
168                LJ::text_out(\$_->{'text'});
169                LJ::text_out(\$_->{'url'}); # should be redundant
170            }
171        }
172    }
173
174    ## tell some users they can hit the fast servers later.
175    $res->{'fastserver'} = 1 if LJ::get_cap($u, "fastserver");
176
177    ## user info
178    $res->{'userid'} = $u->{'userid'};
179    $res->{'fullname'} = $u->{'name'};
180    LJ::text_out(\$res->{'fullname'}) if $ver >= 1;
181
182    ## update or add to clientusage table
183    if ($req->{'clientversion'} =~ /^\S+\/\S+$/)  {
184        my $client = $req->{'clientversion'};
185
186        return fail($err, 208, "Bad clientversion string")
187            if $ver >= 1 and not LJ::text_in($client);
188
189        my $qclient = $dbh->quote($client);
190        my $cu_sql = "REPLACE INTO clientusage (userid, clientid, lastlogin) " .
191            "SELECT $u->{'userid'}, clientid, NOW() FROM clients WHERE client=$qclient";
192        my $sth = $dbh->prepare($cu_sql);
193        $sth->execute;
194        unless ($sth->rows) {
195            # only way this can be 0 is if client doesn't exist in clients table, so
196            # we need to add a new row there, to get a new clientid for this new client:
197            $dbh->do("INSERT INTO clients (client) VALUES ($qclient)");
198            # and now we can do the query from before and it should work:
199            $sth = $dbh->prepare($cu_sql);
200            $sth->execute;
201        }
202    }
203
204    return $res;
205}
206
207sub getfriendgroups
208{
209    my ($dbs, $req, $err, $flags) = @_;
210    return undef unless authenticate($dbs, $req, $err, $flags);
211    my $u = $flags->{'u'};
212    my $res = {};
213    $res->{'friendgroups'} = list_friendgroups($dbs, $u);
214    if ($req->{'ver'} >= 1) {
215        foreach (@{$res->{'friendgroups'}}) {
216            LJ::text_out(\$_->{'name'});
217        }
218    }
219    return $res;
220}
221
222sub getfriends
223{
224    my ($dbs, $req, $err, $flags) = @_;
225    return undef unless authenticate($dbs, $req, $err, $flags);
226    return fail($req,502) unless $dbs->{'reader'};
227    my $u = $flags->{'u'};
228    my $res = {};
229    if ($req->{'includegroups'}) {
230        $res->{'friendgroups'} = list_friendgroups($dbs, $u);
231        if ($req->{'ver'} >= 1) {
232            foreach (@{$res->{'friendgroups'}}) {
233                LJ::text_out(\$_->{'name'});
234            }
235        }
236    }
237    if ($req->{'includefriendof'}) {
238        $res->{'friendofs'} = list_friends($dbs, $u, {
239            'limit' => $req->{'friendoflimit'},
240            'friendof' => 1,
241        });
242        if ($req->{'ver'} >= 1) {
243            foreach(@{$res->{'friendofs'}}) { LJ::text_out(\$_->{'fullname'}) };
244        }
245    }
246    $res->{'friends'} = list_friends($dbs, $u, {
247        'limit' => $req->{'friendlimit'}
248    });
249    if ($req->{'ver'} >= 1) {
250        foreach(@{$res->{'friends'}}) { LJ::text_out(\$_->{'fullname'}) };
251    }
252    return $res;
253}
254
255sub friendof
256{
257    my ($dbs, $req, $err, $flags) = @_;
258    return undef unless authenticate($dbs, $req, $err, $flags);
259    return fail($req,502) unless $dbs->{'reader'};
260    my $u = $flags->{'u'};
261    my $res = {};
262    $res->{'friendofs'} = list_friends($dbs, $u, {
263        'friendof' => 1,
264        'limit' => $req->{'friendoflimit'},
265    });
266    if ($req->{'ver'} >= 1) {
267        foreach(@{$res->{'friendofs'}}) { LJ::text_out(\$_->{'fullname'}) };
268    }
269    return $res;
270}
271
272sub checkfriends
273{
274    my ($dbs, $req, $err, $flags) = @_;
275    return undef unless authenticate($dbs, $req, $err, $flags);
276    my $u = $flags->{'u'};
277    my $res = {};
278
279    # return immediately if they can't use this mode
280    unless (LJ::get_cap($u, "checkfriends")) {
281        $res->{'new'} = 0;
282        $res->{'interval'} = 36000;  # tell client to bugger off
283        return $res;
284    }
285
286    my $dbr = $dbs->{'reader'};
287    my ($lastdate, $sth);
288
289    ## have a valid date?
290    my $lastupdate = $req->{'lastupdate'};
291    if ($lastupdate) {
292        return fail($err,203) unless
293            ($lastupdate =~ /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d/);
294    } else {
295        $lastupdate = "0000-00-00 00:00:00";
296    }
297
298    my $interval = LJ::get_cap_min($u, "checkfriends_interval");
299    $res->{'interval'} = $interval;
300
301    unless ($dbr) {
302        # rather than return a 502 no-db error, just say no updates,
303        # because problem'll be fixed soon enough by db admins
304        $res->{'new'} = 0;
305        $res->{'lastupdate'} = $lastupdate;
306        return $res;
307    }
308
309    my $sql = "SELECT MAX(u.timeupdate) FROM userusage u, friends f ".
310              "WHERE u.userid=f.friendid AND f.userid=$u->{'userid'}";
311    if ($req->{'mask'} and $req->{'mask'} !~ /\D/) {
312        $sql .= " AND f.groupmask & $req->{mask} > 0";
313    }
314
315    $sth = $dbr->prepare($sql);
316    $sth->execute;
317    my ($update) = $sth->fetchrow_array;
318    $update ||= "0000-00-00 00:00:00";
319
320    if ($req->{'lastupdate'} && $update gt $lastupdate) {
321        $res->{'new'} = 1;
322    } else {
323        $res->{'new'} = 0;
324    }
325
326    $res->{'lastupdate'} = $update;
327
328    return $res;
329}
330
331sub getdaycounts
332{
333    my ($dbs, $req, $err, $flags) = @_;
334    return undef unless authenticate($dbs, $req, $err, $flags);
335    return undef unless check_altusage($dbs, $req, $err, $flags);
336
337    my $u = $flags->{'u'};
338    my $uowner = $flags->{'u_owner'} || $u;
339    my $ownerid = $flags->{'ownerid'};
340
341    my $res = {};
342    my ($db, $table, $ownercol) = ($dbs->{'reader'}, "log", "ownerid");
343    if ($uowner->{'clusterid'}) {
344        $db = LJ::get_cluster_reader($uowner);
345        ($table, $ownercol) = ("log2", "journalid");
346    }
347    return fail($err,502) unless $db;
348
349    my $sth = $db->prepare("SELECT year, month, day, COUNT(*) AS 'count' ".
350                           "FROM $table WHERE $ownercol=$ownerid GROUP BY 1, 2, 3");
351    $sth->execute;
352    while (my ($y, $m, $d, $c) = $sth->fetchrow_array) {
353        my $date = sprintf("%04d-%02d-%02d", $y, $m, $d);
354        push @{$res->{'daycounts'}}, { 'date' => $date, 'count' => $c };
355    }
356    return $res;
357}
358
359sub common_event_validation
360{
361    my ($dbs, $req, $err, $flags) = @_;
362    my $dbr = $dbs->{'reader'};
363
364    # date validation
365    if ($req->{'year'} !~ /^\d\d\d\d$/ ||
366        $req->{'year'} < 1980 ||
367        $req->{'year'} > 2037)
368    {
369        return fail($err,203,"Invalid year value.");
370    }
371    if ($req->{'mon'} !~ /^\d{1,2}$/ ||
372        $req->{'mon'} < 1 ||
373        $req->{'mon'} > 12)
374    {
375        return fail($err,203,"Invalid month value.");
376    }
377    if ($req->{'day'} !~ /^\d{1,2}$/ || $req->{'day'} < 1 ||
378        $req->{'day'} > LJ::days_in_month($req->{'month'},
379                                          $req->{'year'}))
380    {
381        return fail($err,203,"Invalid day of month value.");
382    }
383    if ($req->{'hour'} !~ /^\d{1,2}$/ ||
384        $req->{'hour'} < 0 || $req->{'hour'} > 23)
385    {
386        return fail($err,203,"Invalid hour value.");
387    }
388    if ($req->{'min'} !~ /^\d{1,2}$/ ||
389        $req->{'min'} < 0 || $req->{'min'} > 59)
390    {
391        return fail($err,203,"Invalid minute value.");
392    }
393
394    # column width
395
396    $req->{'subject'} = LJ::text_trim($req->{'subject'}, $LJ::BMAX_SUBJECT, $LJ::CMAX_SUBJECT);
397    $req->{'event'} = LJ::text_trim($req->{'event'}, $LJ::BMAX_EVENT, $LJ::CMAX_EVENT);
398    foreach (keys %{$req->{'props'}}) {
399        $req->{'props'}->{$_} = LJ::text_trim($req->{'props'}->{$_}, $LJ::BMAX_PROP, $LJ::CMAX_PROP);
400    }
401
402    # setup non-user meta-data.  it's important we define this here to
403    # 0.  if it's not defined at all, then an editevent where a user
404    # removes random 8bit data won't remove the metadata.  not that
405    # that matters much.  but having this here won't hurt.  false
406    # meta-data isn't saved anyway.  so the only point of this next
407    # line is making the metadata be deleted on edit.
408    $req->{'props'}->{'unknown8bit'} = 0;
409
410    # non-ASCII?
411    unless ( LJ::is_ascii($req->{'event'}) &&
412        LJ::is_ascii($req->{'subject'}) &&
413        LJ::is_ascii(join(' ', values %{$req->{'props'}}) ))
414    {
415        if ($req->{'ver'} < 1) { # client doesn't support Unicode
416            return fail($err,207,"only pure ASCII text is allowed for old clients; please upgrade your client") if $LJ::UNICODE_REQUIRE;
417
418            # so rest of site can change chars to ? marks until
419            # default user's encoding is set.  (legacy support)
420            $req->{'props'}->{'unknown8bit'} = 1;
421        } else {
422            return fail($err,207, "This installation does not support Unicode clients") unless $LJ::UNICODE;
423            # validate that the text is valid UTF-8
424            if (!LJ::text_in($req->{'subject'}) ||
425                !LJ::text_in($req->{'event'}) ||
426                grep { !LJ::text_in($_) } values %{$req->{'props'}}) {
427                return fail($err, 208, "The text entered is not a valid UTF-8 stream");
428            }
429        }
430    }
431
432    ## handle meta-data (properties)
433    LJ::load_props($dbs, "log");
434    foreach my $pname (keys %{$req->{'props'}})
435    {
436        my $p = LJ::get_prop("log", $pname);
437
438        # does the property even exist?
439        unless ($p) {
440            $pname =~ s/[^\w]//g;
441            return fail($err,205,$pname);
442        }
443
444        # don't validate its type if it's 0 or undef (deleting)
445        next unless ($req->{'props'}->{$pname});
446
447        my $ptype = $p->{'datatype'};
448        my $val = $req->{'props'}->{$pname};
449
450        if ($ptype eq "bool" && $val !~ /^[01]$/) {
451            return fail($err,204,"Property \"$pname\" should be 0 or 1");
452        }
453        if ($ptype eq "num" && $val =~ /[^\d]/) {
454            return fail($err,204,"Property \"$pname\" should be numeric");
455        }
456    }
457
458    return 1;
459}
460
461sub postevent
462{
463    my ($dbs, $req, $err, $flags) = @_;
464    return undef unless authenticate($dbs, $req, $err, $flags);
465    return undef unless check_altusage($dbs, $req, $err, $flags);
466
467    my $u = $flags->{'u'};
468    my $ownerid = $flags->{'ownerid'};
469    my $uowner = $flags->{'u_owner'} || $u;
470    my $dbr = $dbs->{'reader'};
471    my $dbh = $dbs->{'dbh'};
472
473    return fail($err,306) unless $dbh;
474    return fail($err,200) unless ($req->{'event'} =~ /\S/);
475
476    ### make sure community, shared, or news journals don't post
477    ### note: shared and news journals are deprecated.  every shared journal
478    ##        should one day be a community journal, of some form.
479    return fail($err,150) if ($u->{'journaltype'} eq "C" ||
480                              $u->{'journaltype'} eq "S" ||
481                              $u->{'journaltype'} eq "N");
482
483    # suspended users can't post
484    return fail($err,305) if ($u->{'statusvis'} eq "S");
485
486    # check the journal's read-only bit
487    return fail($err,306) if LJ::get_cap($uowner, "readonly");
488
489    #### clean up the event text
490    my $event = $req->{'event'};
491
492    # remove surrounding whitespace
493    $event =~ s/^\s+//;
494    $event =~ s/\s+$//;
495
496    # convert line endings to unix format
497    if ($req->{'lineendings'} eq "mac") {
498        $event =~ s/\r/\n/g;
499    } else {
500        $event =~ s/\r//g;
501    }
502
503    return undef
504        unless common_event_validation($dbs, $req, $err, $flags);
505
506    ### allow for posting to journals that aren't yours (if you have permission)
507    my $posterid = $u->{'userid'};
508    my $ownerid = $flags->{'ownerid'};
509
510    # make the proper date format
511    my $qeventtime = $dbh->quote(sprintf("%04d-%02d-%02d %02d:%02d",
512                                         $req->{'year'}, $req->{'mon'},
513                                         $req->{'day'}, $req->{'hour'},
514                                         $req->{'min'}));
515    my $qsubject = $dbh->quote($req->{'subject'});
516    my $qallowmask = $req->{'allowmask'}+0;
517    my $qsecurity = "public";
518    my $uselogsec = 0;
519    if ($req->{'security'} eq "usemask" || $req->{'security'} eq "private") {
520        $qsecurity = $req->{'security'};
521    }
522    if ($req->{'security'} eq "usemask") {
523        $uselogsec = 1;
524    }
525    $qsecurity = $dbh->quote($qsecurity);
526
527    ### make sure user can't post with "custom security" on shared journals
528    return fail($err,102)
529        if ($req->{'security'} eq "usemask" &&
530            $qallowmask != 1 && ($ownerid != $posterid));
531
532    ### do processing of embedded polls
533    my @polls = ();
534    if (LJ::Poll::contains_new_poll(\$event))
535    {
536        return fail($err,301,"Your account type doesn't permit creating polls.")
537            unless (LJ::get_cap($u, "makepoll"));
538
539        my $error = "";
540        @polls = LJ::Poll::parse($dbs, \$event, \$error, {
541            'journalid' => $ownerid,
542            'posterid' => $posterid,
543        });
544        return fail($err,103,$error) if $error;
545    }
546
547    # make sure this user isn't banned from posting here (if
548    # this is a community journal)
549    return fail($err,151) if
550        LJ::is_banned($dbs, $posterid, $ownerid);
551
552    # don't allow backdated posts in communities
553    return fail($err,152) if
554        ($req->{'props'}->{"opt_backdated"} &&
555         $uowner->{'journaltype'} ne "P");
556
557    my $qownerid = $ownerid+0;
558    my $qposterid = $posterid+0;
559
560    # by default we record the true reverse time that the item was entered.
561    # however, if backdate is on, we put the reverse time at the end of time
562    # (which makes it equivalent to 1969, but get_recent_items will never load
563    # it... where clause there is: < $LJ::EndOfTime).  but this way we can
564    # have entries that don't show up on friends view, now that we don't have
565    # the hints table to not insert into.
566    my $rlogtime = "$LJ::EndOfTime";
567    unless ($req->{'props'}->{"opt_backdated"}) {
568        $rlogtime .= "-UNIX_TIMESTAMP()";
569    }
570
571    my $dbcm = $dbh;
572    my $clustered = 0;
573    my $anum  = int(rand(256));
574
575    if ($uowner->{'clusterid'}) {
576        $dbcm = LJ::get_cluster_master($uowner);
577        $clustered = 1;
578
579        return fail($err,306) unless $dbcm;
580
581        # before we get going here, we want to make sure to purge this user's
582        # delitem cmd buffer, otherwise we could have a race and that might
583        # wake up later and delete this item which is replacing in the database
584        # the old last item which is marked for deletion:
585        LJ::cmd_buffer_flush($dbh, $dbcm, "delitem", $ownerid);
586
587        $dbcm->do("INSERT INTO log2 (journalid, posterid, eventtime, logtime, security, ".
588                  "allowmask, replycount, year, month, day, revttime, rlogtime, anum) ".
589                  "VALUES ($qownerid, $qposterid, $qeventtime, NOW(), $qsecurity, $qallowmask, ".
590                  "0, $req->{'year'}, $req->{'mon'}, $req->{'day'}, $LJ::EndOfTime-".
591                  "UNIX_TIMESTAMP($qeventtime), $rlogtime, $anum)");
592    } else {
593        $dbcm->do("INSERT INTO log (ownerid, posterid, eventtime, logtime, security, ".
594                  "allowmask, replycount, year, month, day, revttime, rlogtime) ".
595                  "VALUES ($qownerid, $qposterid, $qeventtime, NOW(), $qsecurity, $qallowmask, ".
596                  "0, $req->{'year'}, $req->{'mon'}, $req->{'day'}, $LJ::EndOfTime-".
597                  "UNIX_TIMESTAMP($qeventtime), $rlogtime)");
598    }
599    return fail($err,501,$dbcm->errstr) if $dbcm->err;
600
601    my $itemid = $dbcm->{'mysql_insertid'};
602    return fail($err,501,"No itemid could be generated.") unless $itemid;
603
604    my $ditemid = $clustered ? ($itemid * 256 + $anum) : $itemid;
605
606    ### finish embedding stuff now that we have the itemid
607    {
608        ### this should NOT return an error, and we're mildly fucked by now
609        ### if it does (would have to delete the log row up there), so we're
610        ### not going to check it for now.
611
612        my $error = "";
613        LJ::Poll::register($dbs, \$event, \$error, $ditemid, @polls);
614    }
615    #### /embedding
616
617    ### extract links for meme tracking
618    unless ($req->{'security'} eq "usemask" ||
619            $req->{'security'} eq "private")
620    {
621        foreach my $url (LJ::get_urls($event)) {
622            my $jid = $clustered ? $ownerid : 0;
623            LJ::record_meme($dbs, $url, $posterid, $ditemid, $jid);
624        }
625    }
626
627    # record journal's disk usage (clustered users only)
628    if ($clustered)
629    {
630        my $bytes = length($event) + length($req->{'subject'});
631        LJ::dudata_set($dbcm, $ownerid, 'L', $itemid, $bytes);
632    }
633
634    my $qevent = $dbh->quote($event);
635    $event = "";
636
637    if ($clustered) {
638        $dbcm->do("REPLACE INTO logtext2 (journalid, jitemid, subject, event) ".
639                  "VALUES ($ownerid, $itemid, $qsubject, $qevent)");
640        if ($dbcm->err) {
641            my $msg = $dbcm->errstr;
642            LJ::delete_item2($dbh, $dbcm, $ownerid, $itemid);   # roll-back
643            return fail($err,501,"logtext:$msg");
644        }
645    } else {
646        my @prefix = ("");
647        if ($LJ::USE_RECENT_TABLES) { push @prefix, "recent_"; }
648        foreach my $pfx (@prefix)
649        {
650            $dbh->do("INSERT INTO ${pfx}logtext (itemid, subject, event) ".
651                     "VALUES ($itemid, $qsubject, $qevent)");
652            if ($dbh->err) {
653                my $msg = $dbh->errstr;
654                LJ::delete_item($dbh, $ownerid, $itemid);   # roll-back
655                return fail($err,501,$msg);
656            }
657        }
658    }
659
660    # this is to speed month view and other places that don't need full text.
661    if ($clustered) {
662        $dbcm->do("REPLACE INTO logsubject2 (journalid, jitemid, subject) ".
663                  "VALUES ($ownerid, $itemid, $qsubject)");
664        if ($dbcm->err) {
665            my $msg = $dbcm->errstr;
666            LJ::delete_item2($dbh, $dbcm, $ownerid, $itemid);   # roll-back
667            return fail($err,501,"logsubject:$msg");
668        }
669    } else {
670        $dbh->do("INSERT INTO logsubject (itemid, subject) VALUES ($itemid, $qsubject)");
671        if ($dbh->err) {
672            my $msg = $dbh->errstr;
673            LJ::delete_item($dbh, $ownerid, $itemid);   # roll-back
674            return fail($err,501,$msg);
675        }
676    }
677
678    ## update sync table (selected from log table, so logtime is identical!)
679    if ($clustered) {
680        $dbcm->do("REPLACE INTO syncupdates2 (userid, atime, nodetype, nodeid, atype) ".
681                  "SELECT journalid, logtime, 'L', jitemid, 'create' FROM log2 ".
682                  "WHERE journalid=$ownerid AND jitemid=$itemid");
683        if ($dbcm->err) {
684            my $msg = $dbcm->errstr;
685            LJ::delete_item2($dbh, $dbcm, $ownerid, $itemid);   # roll-back
686            return fail($err,501,$msg);
687        }
688    } else {
689        $dbh->do("REPLACE INTO syncupdates (userid, atime, nodetype, nodeid, atype) ".
690                 "SELECT ownerid, logtime, 'L', itemid, 'create' FROM log WHERE itemid=$itemid");
691        if ($dbh->err) {
692            my $msg = $dbh->errstr;
693            LJ::delete_item($dbh, $ownerid, $itemid);   # roll-back
694            return fail($err,501,$msg);
695        }
696    }
697
698    # keep track of custom security stuff in other table.
699    if ($uselogsec) {
700        if ($clustered) {
701            $dbcm->do("REPLACE INTO logsec2 (journalid, jitemid, allowmask) ".
702                      "VALUES ($qownerid, $itemid, $qallowmask)");
703            if ($dbcm->err) {
704                my $msg = $dbcm->errstr;
705                LJ::delete_item2($dbh, $dbcm, $ownerid, $itemid);   # roll-back
706                return fail($err,501,"logsec2:$msg");
707            }
708        } else {
709            $dbh->do("INSERT INTO logsec (ownerid, itemid, allowmask) ".
710                     "VALUES ($qownerid, $itemid, $qallowmask)");
711            if ($dbh->err) {
712                my $msg = $dbh->errstr;
713                LJ::delete_item($dbh, $ownerid, $itemid);   # roll-back
714                return fail($err,501,$msg);
715            }
716        }
717    }
718
719    # meta-data
720    if (%{$req->{'props'}}) {
721        my $propinsert = "";
722        foreach my $pname (keys %{$req->{'props'}}) {
723            next unless $req->{'props'}->{$pname};
724            if ($propinsert) {
725                $propinsert .= ", ";
726            } else {
727                if ($clustered) {
728                    $propinsert = "REPLACE INTO logprop2 (journalid, jitemid, propid, value) VALUES ";
729                } else {
730                    $propinsert = "INSERT INTO logprop (itemid, propid, value) VALUES ";
731                }
732            }
733            my $p = LJ::get_prop("log", $pname);
734            if ($p) {
735                my $qvalue = $dbh->quote($req->{'props'}->{$pname});
736                if ($clustered) {
737                    $propinsert .= "($ownerid, $itemid, $p->{'id'}, $qvalue)";
738                } else {
739                    $propinsert .= "($itemid, $p->{'id'}, $qvalue)";
740                }
741            }
742        }
743        if ($propinsert) {
744            $dbcm->do($propinsert);   # note: $dbcm may be $dbh
745            if ($dbcm->err) {
746                my $msg = $dbh->errstr;
747                if ($clustered) {
748                    LJ::delete_item2($dbh, $dbcm, $ownerid, $itemid);   # roll-back
749                } else {
750                    LJ::delete_item($dbh, $ownerid, $itemid);   # roll-back
751                }
752                return fail($err,501,"logprop2:$msg");
753            }
754        }
755    }
756
757    $dbh->do("UPDATE userusage SET timeupdate=NOW(), lastitemid=$itemid ".
758             "WHERE userid=$qownerid");
759
760    # update user update table (on which friends views rely)
761    {
762        my @bits;
763        if ($req->{'security'} eq "public") {
764            push @bits, 31;  # 31 means public
765        } elsif ($req->{'security'} eq "private") {
766            push @bits, 32;  # 1<<32 doesn't exist (too big), but we'll use it in this table
767        } else {
768            for (my $i=0; $i<=30; $i++) {
769                next unless $qallowmask & (1<<$i);
770                push @bits, $i;
771            }
772        }
773        if (@bits) {
774            $dbh->do("REPLACE INTO userupdate (userid, groupbit, timeupdate) VALUES ".
775                     join(",", map { "($ownerid, $_, NOW())" } @bits));
776        }
777    }
778
779    if ($u->{'track'} eq "yes") {
780        # dear community, relax.  if we get a court order to provide data on somebody,
781        # we're legally required to.  this doesn't enable us to do that.  it enables
782        # us to do it without killing the database and/or servers as we do O(n) scans
783        # over everything and grep the hell out of hundreds of gigs of webserver logs.
784        my $quserid = $u->{'userid'}+0;
785        my $qip = $dbh->quote($ENV{'REMOTE_ADDR'});
786        $dbh->do("INSERT INTO tracking (userid, acttime, ip, actdes, associd) ".
787                 "VALUES ($quserid, NOW(), $qip, 'post', $itemid)");
788    }
789
790    my $res = {};
791    $res->{'itemid'} = $itemid;  # by request of mart
792    $res->{'anum'} = $anum if $clustered;
793    return $res;
794}
795
796sub editevent
797{
798    my ($dbs, $req, $err, $flags) = @_;
799    return undef unless authenticate($dbs, $req, $err, $flags);
800    return undef unless check_altusage($dbs, $req, $err, $flags);
801
802    my $u = $flags->{'u'};
803    my $ownerid = $flags->{'ownerid'};
804    my $uowner = $flags->{'u_owner'} || $u;
805    my $posterid = $u->{'userid'};
806    my $dbr = $dbs->{'reader'};
807    my $dbh = $dbs->{'dbh'};
808    my $sth;
809
810    my $qitemid = $req->{'itemid'}+0;
811
812    # check the journal's read-only bit
813    return fail($err,306) if LJ::get_cap($uowner, "readonly");
814
815    my ($dbcm, $dbcr, $clustered) = ($dbh, $dbr, 0);
816    if ($uowner->{'clusterid'}) {
817        $dbcm = LJ::get_cluster_master($uowner);
818        $clustered = 1;
819    }
820    return fail($err,306) unless $dbcm;
821
822    # fetch the old entry from master database so we know what we
823    # really have to update later.  usually people just edit one part,
824    # not every field in every table.  reads are quicker than writes,
825    # so this is worth it.
826    my $oldevent;
827    if ($clustered)
828    {
829        $oldevent = $dbcm->selectrow_hashref
830            ("SELECT l.journalid AS 'ownerid', l.posterid, l.eventtime, l.logtime, ".
831             "l.compressed, l.security, l.allowmask, l.year, l.month, l.day, lt.subject, ".
832             "MD5(lt.event) AS 'md5event', l.rlogtime, l.anum FROM log2 l, logtext2 lt ".
833             "WHERE l.journalid=$ownerid AND lt.journalid=$ownerid ".
834             "AND l.jitemid=$qitemid AND lt.jitemid=$qitemid");
835    } else {
836        $oldevent = $dbcm->selectrow_hashref
837            ("SELECT l.ownerid, l.posterid, l.eventtime, l.logtime, ".
838             "l.compressed, l.security, l.allowmask, l.year, l.month, l.day, lt.subject, ".
839             "MD5(lt.event) AS 'md5event', l.rlogtime FROM log l, logtext lt ".
840             "WHERE l.itemid=$qitemid AND lt.itemid=$qitemid");
841    }
842
843    ### make sure this user is allowed to edit this entry
844    return fail($err,302)
845        unless ($ownerid == $oldevent->{'ownerid'});
846
847    ### what can they do to somebody elses entry?  (in shared journal)
848    if ($posterid != $oldevent->{'posterid'})
849    {
850        ## deleting.
851        return fail($err,304)
852            if ($req->{'event'} !~ /\S/ && !
853                ($ownerid == $u->{'userid'} ||
854                 # community account can delete it (ick)
855
856                 LJ::check_priv($dbr, $u,
857                                "sharedjournal", $req->{'usejournal'})
858                 # if user is a community maintainer they can delete
859                 # it too (good)
860                 ));
861
862        ## editing:
863        return fail($err,303)
864            if ($req->{'event'} =~ /\S/);
865    }
866
867    ## update sync table (before we actually do it!  in case updates
868    ## partially fail below)
869    if ($clustered) {
870        my $synctype = "update";
871        if ($req->{'event'} !~ /\S/) { $synctype = "del"; }
872        $dbcm->do("REPLACE INTO syncupdates2 (userid, atime, nodetype, nodeid, atype) ".
873                  "VALUES ($ownerid, NOW(), 'L', $qitemid, '$synctype')");
874    } else {
875        $dbh->do("REPLACE INTO syncupdates (userid, atime, nodetype, nodeid, atype) ".
876                 "VALUES ($ownerid, NOW(), 'L', $qitemid, 'update')");
877    }
878
879    # simple logic for deleting an entry
880    if ($req->{'event'} !~ /\S/)
881    {
882        if ($clustered) {
883            LJ::delete_item2($dbh, $dbcm, $ownerid, $req->{'itemid'},
884                             'quick', $oldevent->{'anum'});
885        } else {
886            LJ::delete_item($dbh, $ownerid, $req->{'itemid'});
887        }
888        my $res = { 'itemid' => $qitemid,
889                    'anum' => $oldevent->{'anum'} };
890        return $res;
891    }
892
893    # don't allow backdated posts in communities
894    return fail($err,152) if
895        ($req->{'props'}->{"opt_backdated"} &&
896         $uowner->{'journaltype'} ne "P");
897
898    # updating an entry:
899    return undef
900        unless common_event_validation($dbs, $req, $err, $flags);
901
902    ### load existing meta-data
903    my %curprops;
904
905    if ($clustered) {
906        LJ::load_props($dbs, "log");
907        LJ::load_log_props2($dbcm, $ownerid, [ $qitemid ], \%curprops);
908    } else {
909        LJ::load_log_props($dbh, [ $qitemid ], \%curprops);
910    }
911
912    ## handle meta-data (properties)
913    my %props_byname = ();
914    foreach my $key (keys %{$req->{'props'}}) {
915        ## changing to something else?
916        if ($curprops{$qitemid}->{$key} ne $req->{'props'}->{$key}) {
917            $props_byname{$key} = $req->{'props'}->{$key};
918        }
919    }
920
921    #### clean up the event text
922    my $event = $req->{'event'};
923
924    # remove surrounding whitespace
925    $event =~ s/^\s+//;
926    $event =~ s/\s+$//;
927
928    # convert line endings to unix format
929    if ($req->{'lineendings'} eq "mac") {
930        $event =~ s/\r/\n/g;
931    } else {
932        $event =~ s/\r//g;
933    }
934    my $qevent = $dbh->quote($event);
935    my $bytes = length($event) + length($req->{'subject'});
936    $event = "";
937
938    my $eventtime = sprintf("%04d-%02d-%02d %02d:%02d",
939                            map { $req->{$_} } qw(year mon day hour min));
940    my $qeventtime = $dbh->quote($eventtime);
941
942    my $qallowmask = $req->{'allowmask'}+0;
943    my $security = "public";
944    if ($req->{'security'} eq "private" || $req->{'security'} eq "usemask") {
945        $security = $req->{'security'};
946    }
947
948    my $qyear = $req->{'year'}+0;
949    my $qmonth = $req->{'mon'}+0;
950    my $qday = $req->{'day'}+0;
951
952    if ($qyear != $oldevent->{'year'} ||
953        $qmonth != $oldevent->{'month'} ||
954        $qday != $oldevent->{'day'} ||
955        $eventtime ne $oldevent->{'eventtime'} ||
956        $security ne $oldevent->{'security'} ||
957        $qallowmask != $oldevent->{'allowmask'}
958        )
959    {
960        my $qsecurity = $dbh->quote($security);
961        if ($clustered) {
962            $dbcm->do("UPDATE log2 SET eventtime=$qeventtime, revttime=$LJ::EndOfTime-".
963                      "UNIX_TIMESTAMP($qeventtime), year=$qyear, month=$qmonth, day=$qday, ".
964                      "security=$qsecurity, allowmask=$qallowmask WHERE journalid=$ownerid ".
965                      "AND jitemid=$qitemid");
966        } else {
967            $dbh->do("UPDATE log SET eventtime=$qeventtime, revttime=$LJ::EndOfTime-".
968                     "UNIX_TIMESTAMP($qeventtime), year=$qyear, month=$qmonth, day=$qday, ".
969                     "security=$qsecurity, allowmask=$qallowmask WHERE itemid=$qitemid");
970        }
971    }
972
973    if ($security ne $oldevent->{'security'} ||
974        $qallowmask != $oldevent->{'allowmask'})
975    {
976        if ($security eq "public" || $security eq "private") {
977            if ($clustered) {
978                $dbcm->do("DELETE FROM logsec2 WHERE journalid=$ownerid AND jitemid=$qitemid");
979            } else {
980                $dbh->do("DELETE FROM logsec WHERE ownerid=$ownerid AND itemid=$qitemid");
981            }
982        } else {
983            my $qsecurity = $dbh->quote($security);
984            if ($clustered) {
985                $dbcm->do("REPLACE INTO logsec2 (journalid, jitemid, allowmask) ".
986                          "VALUES ($ownerid, $qitemid, $qallowmask)");
987            } else {
988                $dbh->do("REPLACE INTO logsec (ownerid, itemid, allowmask) ".
989                         "VALUES ($ownerid, $qitemid, $qallowmask)");
990            }
991        }
992        return fail($err,501,$dbcm->errstr) if $dbcm->err;
993    }
994
995    if (Digest::MD5::md5_hex($event) ne $oldevent->{'md5event'} ||
996        $req->{'subject'} ne $oldevent->{'subject'})
997    {
998        my $qsubject = $dbh->quote($req->{'subject'});
999
1000        if ($clustered) {
1001            $dbcm->do("UPDATE logtext2 SET event=$qevent, subject=$qsubject ".
1002                      "WHERE journalid=$ownerid AND jitemid=$qitemid");
1003        } else {
1004            my @prefix = ("");
1005            if ($LJ::USE_RECENT_TABLES) { push @prefix, "recent_"; }
1006            foreach my $pfx (@prefix) {
1007                $dbh->do("UPDATE ${pfx}logtext SET event=$qevent, subject=$qsubject ".
1008                         "WHERE itemid=$qitemid");
1009            }
1010            return fail($err,501,$dbcm->errstr) if $dbcm->err;
1011        }
1012        if ($clustered) {
1013            $dbcm->do("REPLACE INTO logsubject2 (journalid, jitemid, subject) ".
1014                      "VALUES ($ownerid, $qitemid, $qsubject)");
1015        } else {
1016            $dbh->do("REPLACE INTO logsubject (itemid, subject) ".
1017                     "VALUES ($qitemid, $qsubject)");
1018        }
1019
1020        # update disk usage
1021        if ($clustered) {
1022            LJ::dudata_set($dbcm, $ownerid, 'L', $qitemid, $bytes);
1023        }
1024
1025        return fail($err,501,$dbcm->errstr) if $dbcm->err;
1026    }
1027
1028    if (%{$req->{'props'}}) {
1029        my $propinsert = "";
1030        my @props_to_delete;
1031        foreach my $pname (keys %{$req->{'props'}}) {
1032            my $p = LJ::get_prop("log", $pname);
1033            next unless $p;
1034            my $val = $req->{'props'}->{$pname};
1035            unless ($val) {
1036                push @props_to_delete, $p->{'id'};
1037                next;
1038            }
1039            if ($propinsert) {
1040                $propinsert .= ", ";
1041            } else {
1042                if ($clustered) {
1043                    $propinsert = "REPLACE INTO logprop2 (journalid, jitemid, propid, value) VALUES ";
1044                } else {
1045                    $propinsert = "REPLACE INTO logprop (itemid, propid, value) VALUES ";
1046                }
1047            }
1048            my $qvalue = $dbh->quote($val);
1049            if ($clustered) {
1050                $propinsert .= "($ownerid, $qitemid, $p->{'id'}, $qvalue)";
1051            } else {
1052                $propinsert .= "($qitemid, $p->{'id'}, $qvalue)";
1053            }
1054        }
1055        if ($propinsert) { $dbcm->do($propinsert); }
1056        if (@props_to_delete) {
1057            my $propid_in = join(", ", @props_to_delete);
1058            if ($clustered) {
1059                $dbcm->do("DELETE FROM logprop2 WHERE journalid=$ownerid AND ".
1060                          "jitemid=$qitemid AND propid IN ($propid_in)");
1061            } else {
1062                $dbh->do("DELETE FROM logprop WHERE itemid=$qitemid AND propid IN ($propid_in)");
1063            }
1064        }
1065    }
1066
1067    # deal with backdated changes.  if the entry's rlogtime is
1068    # $EndOfTime, then it's backdated.  if they want that off, need to
1069    # reset rlogtime to real reverse log time.  also need to set
1070    # rlogtime to $EndOfTime if they're turning backdate on.
1071    if ($req->{'props'}->{'opt_backdated'} eq "1" &&
1072        $oldevent->{'rlogtime'} != $LJ::EndOfTime) {
1073        if ($clustered) {
1074            $dbh->do("UPDATE log SET rlogtime=$LJ::EndOfTime WHERE ".
1075                     "itemid=$qitemid");
1076        } else {
1077            $dbcm->do("UPDATE log2 SET rlogtime=$LJ::EndOfTime WHERE ".
1078                      "journalid=$ownerid AND jitemid=$qitemid");
1079        }
1080    }
1081    if ($req->{'props'}->{'opt_backdated'} eq "0" &&
1082        $oldevent->{'rlogtime'} == $LJ::EndOfTime) {
1083        if ($clustered) {
1084            $dbcm->do("UPDATE log2 SET rlogtime=$LJ::EndOfTime-UNIX_TIMESTAMP(logtime) ".
1085                      "WHERE journalid=$ownerid AND jitemid=$qitemid");
1086        } else {
1087            $dbh->do("UPDATE log SET rlogtime=$LJ::EndOfTime-UNIX_TIMESTAMP(logtime) ".
1088                     "WHERE itemid=$qitemid");
1089        }
1090    }
1091
1092    return fail($err,501,$dbcm->errstr) if $dbcm->err;
1093
1094    my $res = { 'itemid' => $qitemid };
1095    $res->{'anum'} = $oldevent->{'anum'} if defined $oldevent->{'anum'};
1096    return $res;
1097}
1098
1099sub getevents
1100{
1101    my ($dbs, $req, $err, $flags) = @_;
1102    return undef unless authenticate($dbs, $req, $err, $flags);
1103    return undef unless check_altusage($dbs, $req, $err, $flags);
1104
1105    my $u = $flags->{'u'};
1106    my $uowner = $flags->{'u_owner'} || $u;
1107
1108    ### shared-journal support
1109    my $posterid = $u->{'userid'};
1110    my $ownerid = $flags->{'ownerid'};
1111
1112    my $dbr = $dbs->{'reader'};
1113    my $dbh = $dbs->{'dbh'};
1114    my $sth;
1115
1116    my ($dbcr, $clustered) = ($dbr, 0);
1117    if ($uowner->{'clusterid'}) {
1118        $dbcr = LJ::get_cluster_reader($uowner);
1119        $clustered = 1;
1120    }
1121    return fail($err,502) unless $dbcr;
1122
1123    # if this is on, we sort things different (logtime vs. posttime)
1124    # to avoid timezone issues
1125    my $is_community = ($uowner->{'journaltype'} eq "C" ||
1126                        $uowner->{'journaltype'} eq "S");
1127
1128    # in some cases we'll use the master, to ensure there's no
1129    # replication delay.  useful cases: getting one item, use master
1130    # since user might have just made a typo and realizes it as they
1131    # post, or wants to append something they forgot, etc, etc.  in
1132    # other cases, slave is pretty sure to have it.
1133    my $use_master = 0;
1134
1135    # the benefit of this mode over actually doing 'lastn/1' is
1136    # the $use_master usage.
1137    if ($req->{'selecttype'} eq "one" && $req->{'itemid'} eq "-1") {
1138        $req->{'selecttype'} = "lastn";
1139        $req->{'howmany'} = 1;
1140        undef $req->{'itemid'};
1141        $use_master = 1;  # see note above.
1142    }
1143
1144    # build the query to get log rows.  each selecttype branch is
1145    # responsible for either populating the following 3 variables
1146    # OR just populating $sql
1147    my ($orderby, $where, $limit);
1148    my $sql;
1149    if ($req->{'selecttype'} eq "day")
1150    {
1151        return fail($err,203)
1152            unless ($req->{'year'} =~ /^\d\d\d\d$/ &&
1153                    $req->{'month'} =~ /^\d\d?$/ &&
1154                    $req->{'day'} =~ /^\d\d?$/ &&
1155                    $req->{'month'} >= 1 && $req->{'month'} <= 12 &&
1156                    $req->{'day'} >= 1 && $req->{'day'} <= 31);
1157
1158        my $qyear = $dbh->quote($req->{'year'});
1159        my $qmonth = $dbh->quote($req->{'month'});
1160        my $qday = $dbh->quote($req->{'day'});
1161        $where = "AND year=$qyear AND month=$qmonth AND day=$qday";
1162        $limit = "LIMIT 200";  # FIXME: unhardcode this constant (also in ljviews.pl)
1163
1164        # see note above about why the sort order is different
1165        $orderby = $is_community ? "ORDER BY logtime" : "ORDER BY eventtime";
1166    }
1167    elsif ($req->{'selecttype'} eq "lastn")
1168    {
1169        my $howmany = $req->{'howmany'} || 20;
1170        if ($howmany > 50) { $howmany = 50; }
1171        $howmany = $howmany + 0;
1172        $limit = "LIMIT $howmany";
1173
1174        # okay, follow me here... see how we add the revttime predicate
1175        # even if no beforedate key is present?  you're probably saying,
1176        # that's retarded -- you're saying: "revttime > 0", that's like
1177        # saying, "if entry occured at all."  yes yes, but that hints
1178        # mysql's braindead optimizer to use the right index.
1179        my $rtime_after = 0;
1180        my $rtime_what = $is_community ? "rlogtime" : "revttime";
1181        if ($req->{'beforedate'}) {
1182            return fail($err,203,"Invalid beforedate format.")
1183                unless ($req->{'beforedate'} =~
1184                        /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d$/);
1185            my $qd = $dbh->quote($req->{'beforedate'});
1186            $rtime_after = "$LJ::EndOfTime-UNIX_TIMESTAMP($qd)";
1187        }
1188        $where .= "AND $rtime_what > $rtime_after ";
1189        $orderby = "ORDER BY $rtime_what";
1190    }
1191    elsif ($req->{'selecttype'} eq "one")
1192    {
1193        my $id = $req->{'itemid'} + 0;
1194        $where = $clustered ? "AND jitemid=$id" : "AND itemid=$id";
1195    }
1196    elsif ($req->{'selecttype'} eq "syncitems")
1197    {
1198        my ($date);
1199        ## have a valid date?
1200        $date = $req->{'lastsync'} || "0000-00-00 00:00:00";
1201        if ($date !~ /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d/) {
1202            return fail($err,203,"Invalid syncitems date format.");
1203        }
1204
1205        my $LIMIT = 300;
1206        if ($clustered) {
1207            $sql = "SELECT jitemid, eventtime, security, allowmask, anum ".
1208                "FROM log2 l, syncupdates2 s ".
1209                "WHERE s.userid=$ownerid AND l.journalid=$ownerid ".
1210                "AND s.atime>='$date' AND s.nodetype='L' AND s.nodeid=l.jitemid ".
1211                "AND s.nodeid=l.jitemid ORDER BY s.atime LIMIT $LIMIT";
1212        } else {
1213            $use_master = 1;
1214            $sql = "SELECT itemid, eventtime, security, allowmask ".
1215                "FROM log l, syncupdates s WHERE s.userid=$ownerid ".
1216                "AND s.atime>='$date' AND s.nodetype='L' AND s.nodeid=l.itemid ".
1217                "AND s.nodeid=l.itemid ORDER BY s.atime LIMIT $LIMIT";
1218        }
1219    }
1220    else
1221    {
1222        return fail($err,200,"Invalid selecttype.");
1223    }
1224
1225    # common SQL template:
1226    unless ($sql) {
1227        if ($clustered) {
1228            $sql = "SELECT jitemid, eventtime, security, allowmask, anum ".
1229                   "FROM log2 WHERE journalid=$ownerid $where $orderby $limit";
1230        } else {
1231            $sql = "SELECT itemid, eventtime, security, allowmask ".
1232                      "FROM log WHERE ownerid=$ownerid $where $orderby $limit";
1233        }
1234    }
1235
1236    # whatever selecttype might have wanted us to use the master db.
1237    $dbcr = $clustered ? LJ::get_cluster_master($uowner) : $dbh
1238        if $use_master;
1239
1240    return fail($err,502) unless $dbcr;
1241
1242    ## load the log rows
1243    ($sth = $dbcr->prepare($sql))->execute;
1244    return fail($err,501,$dbcr->errstr) if $dbcr->err;
1245
1246    my $count = 0;
1247    my @itemids = ();
1248    my $res = {};
1249    my $events = $res->{'events'} = [];
1250    my %evt_from_itemid;
1251
1252    while (my ($itemid, $eventtime, $sec, $mask, $anum) = $sth->fetchrow_array)
1253    {
1254        $count++;
1255        my $evt = {};
1256        $evt->{'itemid'} = $itemid;
1257        push @itemids, $itemid;
1258
1259        $evt_from_itemid{$itemid} = $evt;
1260
1261        $evt->{"eventtime"} = $eventtime;
1262        if ($sec ne "public") {
1263            $evt->{'security'} = $sec;
1264            $evt->{'allowmask'} = $mask if $sec eq "usemask";
1265        }
1266        $evt->{'anum'} = $anum if $clustered;
1267        push @$events, $evt;
1268    }
1269
1270    # load properties. Even if the caller doesn't want them, we need
1271    # them in Unicode installations to recognize older 8bit non-UF-8
1272    # entries.
1273    unless ($req->{'noprops'} && !$LJ::UNICODE)
1274    {
1275        ### do the properties now
1276        $count = 0;
1277        my %props = ();
1278        if ($clustered) {
1279            LJ::load_props($dbs, "log");
1280            LJ::load_log_props2($dbcr, $ownerid, \@itemids, \%props);
1281        } else {
1282            LJ::load_log_props($dbcr, \@itemids, \%props);
1283        }
1284        foreach my $itemid (keys %props) {
1285            my $evt = $evt_from_itemid{$itemid};
1286            $evt->{'props'} = {};
1287            foreach my $name (keys %{$props{$itemid}}) {
1288                my $value = $props{$itemid}->{$name};
1289                $value =~ s/\n/ /g;
1290                $evt->{'props'}->{$name} = $value;
1291            }
1292        }
1293    }
1294
1295    ## load the text
1296    my $text;
1297    my $gt_opts = {
1298        'prefersubjects' => $req->{'prefersubject'} ,
1299        'usemaster' => $use_master,
1300    };
1301    if ($clustered) {
1302        $text = LJ::get_logtext2($uowner, $gt_opts, @itemids);
1303    } else {
1304        $text = LJ::get_logtext($dbs, $gt_opts, @itemids);
1305    }
1306    foreach my $i (@itemids)
1307    {
1308        my $t = $text->{$i};
1309        my $evt = $evt_from_itemid{$i};
1310
1311        # now that we have the subject, the event and the props,
1312        # auto-translate them to UTF-8 if they're not in UTF-8.
1313        if ($LJ::UNICODE && $req->{'ver'} >= 1 &&
1314                $evt->{'props'}->{'unknown8bit'}) {
1315            my $error = 0;
1316            $t->[0] = LJ::text_convert($dbs, $t->[0], $uowner, \$error);
1317            $t->[1] = LJ::text_convert($dbs, $t->[1], $uowner, \$error);
1318            foreach (keys %{$evt->{'props'}}) {
1319                $evt->{'props'}->{$_} = LJ::text_convert($dbs,
1320                    $evt->{'props'}->{$_}, $uowner, \$error);
1321            }
1322            return fail($err,208,"Cannot display non-Unicode posts unless default encoding has been selected")
1323                if $error;
1324        }
1325 
1326        if ($t->[0]) {
1327            $t->[0] =~ s/[\r\n]/ /g;
1328            $evt->{'subject'} = $t->[0];
1329        }
1330
1331        # truncate
1332        if ($req->{'truncate'} >= 4) {
1333            if ($req->{'ver'} > 1) {
1334                $t->[1] = LJ::text_trim($t->[1], $req->{'truncate'} - 3, 0);
1335            } else {
1336                $t->[1] = LJ::text_trim($t->[1], 0, $req->{'truncate'} - 3);
1337            };
1338            $t->[1] .= "...";
1339        }
1340       
1341        # line endings
1342        $t->[1] =~ s/\r//g;
1343        if ($req->{'lineendings'} eq "unix") {
1344            # do nothing.  native format.
1345        } elsif ($req->{'lineendings'} eq "mac") {
1346            $t->[1] =~ s/\n/\r/g;
1347        } elsif ($req->{'lineendings'} eq "space") {
1348            $t->[1] =~ s/\n/ /g;
1349        } elsif ($req->{'lineendings'} eq "dots") {
1350            $t->[1] =~ s/\n/ ... /g;
1351        } else { # "pc" -- default
1352            $t->[1] =~ s/\n/\r\n/g;
1353        }
1354        $evt->{'event'} = $t->[1];
1355    }
1356
1357    # maybe we don't need the props after all
1358    if ($req->{'noprops'}) {
1359        foreach(@$events) { delete $_->{'props'}; }
1360    }
1361
1362    return $res;
1363}
1364
1365sub editfriends
1366{
1367    my ($dbs, $req, $err, $flags) = @_;
1368    return undef unless authenticate($dbs, $req, $err, $flags);
1369
1370    my $u = $flags->{'u'};
1371    my $userid = $u->{'userid'};
1372    my $dbr = $dbs->{'reader'};
1373    my $dbh = $dbs->{'dbh'};
1374    my $sth;
1375
1376    return fail($err,306) unless $dbh;
1377
1378    my $res = {};
1379
1380    ## first, figure out who the current friends are to save us work later
1381    my %curfriend;
1382    my $friend_count = 0;
1383    $sth = $dbh->prepare("SELECT u.user FROM user u, friends f ".
1384                         "WHERE u.userid=f.friendid AND f.userid=$userid ".
1385                         "AND u.statusvis='V'");
1386    $sth->execute;
1387    while (my ($friend) = $sth->fetchrow_array) {
1388        $curfriend{$friend} = 1;
1389        $friend_count++;
1390    }
1391    $sth->finish;
1392
1393    # perform the deletions
1394  DELETEFRIEND:
1395    foreach (@{$req->{'delete'}})
1396    {
1397        my $deluser = LJ::canonical_username($_);
1398        next DELETEFRIEND unless ($curfriend{$deluser});
1399
1400        my $friendid = LJ::get_userid($dbh, $deluser);
1401        $sth = $dbh->prepare("DELETE FROM friends ".
1402                             "WHERE userid=$userid AND friendid=$friendid");
1403        $sth->execute;
1404        $friend_count--;
1405    }
1406
1407    my $error_flag = 0;
1408    my $friends_added = 0;
1409
1410    # perform the adds
1411  ADDFRIEND:
1412    foreach my $fa (@{$req->{'add'}})
1413    {
1414        unless (ref $fa eq "HASH") {
1415            $fa = { 'username' => $fa };
1416        }
1417
1418        my $aname = LJ::canonical_username($fa->{'username'});
1419        unless ($aname) {
1420            $error_flag = 1;
1421            next ADDFRIEND;
1422        }
1423
1424        $friend_count++ unless $curfriend{$aname};
1425
1426        my $maxfriends = LJ::get_cap($u, "maxfriends");
1427        return fail($err,104,"Exceeded $maxfriends friends limit (now: $friend_count)")
1428            if ($friend_count > $maxfriends);
1429
1430        my $fg = $fa->{'fgcolor'} || "#000000";
1431        my $bg = $fa->{'bgcolor'} || "#FFFFFF";
1432        if ($fg !~ /^\#[0-9A-F]{6,6}$/i || $bg !~ /^\#[0-9A-F]{6,6}$/i) {
1433            return fail($err,203,"Invalid color values");
1434        }
1435
1436        my $row = LJ::load_user($dbs, $aname);
1437        unless ($row && $row->{'statusvis'} eq "V") {
1438            $error_flag = 1;
1439        } else {
1440            $friends_added++;
1441            my $added = { 'username' => $aname,
1442                          'fullname' => $row->{'name'},
1443                      };
1444            if ($req->{'ver'} >= 1) {
1445                LJ::text_out(\$added->{'fullname'});
1446            }
1447            push @{$res->{'added'}}, $added;
1448
1449            my $qfg = LJ::color_todb($fg);
1450            my $qbg = LJ::color_todb($bg);
1451
1452            my $friendid = $row->{'userid'};
1453
1454            my $gmask = $fa->{'groupmask'};
1455            if (! $gmask && $curfriend{$aname}) {
1456                # if no group mask sent, use the existing one if this is an existing friend
1457                my $sth = $dbh->prepare("SELECT groupmask FROM friends ".
1458                                        "WHERE userid=$userid AND friendid=$friendid");
1459                $sth->execute;
1460                $gmask = $sth->fetchrow_array;
1461            }
1462            # force bit 0 on.
1463            $gmask |= 1;
1464
1465            $sth = $dbh->prepare("REPLACE INTO friends (userid, friendid, fgcolor, bgcolor, groupmask) ".
1466                                 "VALUES ($userid, $friendid, $qfg, $qbg, $gmask)");
1467            $sth->execute;
1468            return fail($err,501,$dbh->errstr) if $dbh->err;
1469
1470        }
1471    }
1472
1473    return fail($err,104) if $error_flag;
1474    return $res;
1475}
1476
1477sub editfriendgroups
1478{
1479    my ($dbs, $req, $err, $flags) = @_;
1480    return undef unless authenticate($dbs, $req, $err, $flags);
1481
1482    my $u = $flags->{'u'};
1483    my $userid = $u->{'userid'};
1484    my $dbr = $dbs->{'reader'};
1485    my $dbh = $dbs->{'dbh'};
1486    my $sth;
1487
1488    return fail($err,306) unless $dbh;
1489    return fail($err,502) unless $dbr;
1490
1491    my $res = {};
1492
1493    ## make sure tree is how we want it
1494    $req->{'groupmasks'} = {} unless
1495        (ref $req->{'groupmasks'} eq "HASH");
1496    $req->{'set'} = {} unless
1497        (ref $req->{'set'} eq "HASH");
1498    $req->{'delete'} = [] unless
1499        (ref $req->{'delete'} eq "ARRAY");
1500
1501    ###
1502    ## Keep track of what bits are already set, so we can know later whether to INSERT
1503    #  or UPDATE.
1504
1505    my %bitset;
1506    $sth = $dbr->prepare("SELECT groupnum FROM friendgroup WHERE userid=$userid");
1507    $sth->execute;
1508    while (my ($bit) = $sth->fetchrow_array) {
1509        $bitset{$bit} = 1;
1510    }
1511
1512    ## before we perform any DB operations, validate input text
1513    # (groups' names) for correctness so we can fail gracefully
1514
1515    if ($LJ::UNICODE) {
1516        foreach my $bit (keys %{$req->{'set'}})
1517        {
1518            my $name = $req->{'set'}->{$bit}->{'name'};
1519            return fail($err,207,"non-ASCII names require a Unicode-capable client")
1520                if $req->{'ver'} < 1 and not LJ::ascii($name);
1521            return fail($err,208,"Some of the group names aren't valid UTF-8 strings")
1522                unless LJ::text_in($name);
1523        }
1524    }
1525   
1526    ## figure out deletions we'll do later
1527    foreach my $bit (@{$req->{'delete'}})
1528    {
1529        $bit += 0;
1530        next unless ($bit >= 1 && $bit <= 30);
1531        $bitset{$bit} = 0;  # so later we replace into, not update.
1532    }
1533
1534    ## change friends' masks
1535    foreach my $friend (keys %{$req->{'groupmasks'}})
1536    {
1537        my $mask = int($req->{'groupmasks'}->{$friend}) | 1;
1538
1539        my $friendid = LJ::get_userid($dbs, $friend);
1540        if ($friendid) {
1541            $sth = $dbh->prepare("UPDATE friends SET groupmask=$mask ".
1542                                 "WHERE userid=$userid AND friendid=$friendid");
1543            $sth->execute;
1544        }
1545    }
1546
1547    ## do additions/modifications ('set' hash)
1548    my %added;
1549    foreach my $bit (keys %{$req->{'set'}})
1550    {
1551        $bit += 0;
1552        next unless ($bit >= 1 && $bit <= 30);
1553        my $sa = $req->{'set'}->{$bit};
1554        my $name = LJ::text_trim($sa->{'name'}, $LJ::BMAX_GRPNAME, $LJ::CMAX_GRPNAME);
1555       
1556        # setting it to name is like deleting it.
1557        unless ($name =~ /\S/) {
1558            push @{$req->{'delete'}}, $bit;
1559            next;
1560        }
1561
1562        my $qname = $dbh->quote($name);
1563        my $qsort = defined $sa->{'sort'} ? ($sa->{'sort'}+0) : 50;
1564        my $qpublic = $dbh->quote(defined $sa->{'public'} ? ($sa->{'public'}+0) : 0);
1565
1566        if ($bitset{$bit}) {
1567            # so update it
1568            my $sets;
1569            if (defined $sa->{'public'}) {
1570                $sets .= ", is_public=$qpublic";
1571            }
1572            $sth = $dbh->prepare("UPDATE friendgroup SET groupname=$qname, sortorder=$qsort ".
1573                                 "$sets WHERE userid=$userid AND groupnum=$bit");
1574        } else {
1575            $sth = $dbh->prepare("REPLACE INTO friendgroup (userid, groupnum, ".
1576                                 "groupname, sortorder, is_public) VALUES ".
1577                                 "($userid, $bit, $qname, $qsort, $qpublic)");
1578        }
1579        $sth->execute;
1580        $added{$bit} = 1;
1581    }
1582
1583
1584    ## do deletions ('delete' array)
1585    foreach my $bit (@{$req->{'delete'}})
1586    {
1587        $bit += 0;
1588        next unless ($bit >= 1 && $bit <= 30);
1589
1590        # Old note: remove all friend's priviledges on that bit
1591        # number?  No, client should do this.
1592
1593        # remove all posts from allowing that group:
1594        my @posts_to_clean = ();
1595        $sth = $dbr->prepare("SELECT itemid FROM logsec WHERE ownerid=$userid AND allowmask & (1 << $bit)");
1596        $sth->execute;
1597        while (my ($id) = $sth->fetchrow_array) { push @posts_to_clean, $id; }
1598        while (@posts_to_clean) {
1599            my @batch;
1600            if (scalar(@posts_to_clean) < 20) {
1601                @batch = @posts_to_clean;
1602                @posts_to_clean = ();
1603            } else {
1604                @batch = splice(@posts_to_clean, 0, 20);
1605            }
1606            my $in = join(",", @batch);
1607            $dbh->do("UPDATE log SET allowmask=allowmask & ~(1 << $bit) ".
1608                     "WHERE itemid IN ($in) AND security='usemask'");
1609            $dbh->do("UPDATE logsec SET allowmask=allowmask & ~(1 << $bit) ".
1610                     "WHERE ownerid=$userid AND itemid IN ($in)");
1611        }
1612
1613        # remove the friend group, unless we just added it this transaction
1614        unless ($added{$bit}) {
1615            $sth = $dbh->prepare("DELETE FROM friendgroup WHERE ".
1616                                 "userid=$userid AND groupnum=$bit");
1617            $sth->execute;
1618        }
1619    }
1620
1621    # return value for this is nothing.
1622    return {};
1623}
1624
1625sub list_friends
1626{
1627    my ($dbs, $u, $opts) = @_;
1628    my $dbr = $dbs->{'reader'};
1629
1630    my $limitnum = $opts->{'limit'}+0;
1631    my $where = "u.userid=f.friendid AND f.userid=$u->{'userid'}";
1632    if ($opts->{'friendof'}) {
1633        $where = "u.userid=f.userid AND f.friendid=$u->{'userid'}";
1634    }
1635
1636    my $limit = $limitnum ? "LIMIT $limitnum" : "";
1637    my $sth = $dbr->prepare("SELECT u.user AS 'friend', u.name, u.journaltype, f.fgcolor, f.bgcolor, f.groupmask ".
1638                            "FROM user u, friends f WHERE $where AND u.statusvis='V' ORDER BY u.user $limit");
1639    $sth->execute;
1640    my @friends;
1641    push @friends, $_ while $_ = $sth->fetchrow_hashref;
1642    $sth->finish;
1643
1644    my $res = [];
1645    foreach my $f (@friends)
1646    {
1647        my $r =  { 'username' => $f->{'friend'},
1648                   'fullname' => $f->{'name'},
1649               };
1650        $r->{'fgcolor'} = LJ::color_fromdb($f->{'fgcolor'});
1651        $r->{'bgcolor'} = LJ::color_fromdb($f->{'bgcolor'});
1652        if (! $opts->{'friendof'} && $f->{'groupmask'} != 1) {
1653            $r->{"groupmask"} = $f->{'groupmask'};
1654        }
1655        if ($f->{'journaltype'} eq "C") {
1656            $r->{"type"} = "community";
1657        }
1658
1659        push @$res, $r;
1660    }
1661    return $res;
1662}
1663
1664sub syncitems
1665{
1666    my ($dbs, $req, $err, $flags) = @_;
1667    return undef unless authenticate($dbs, $req, $err, $flags);
1668    return undef unless check_altusage($dbs, $req, $err, $flags);
1669
1670    my $ownerid = $flags->{'ownerid'};
1671    my $uowner = $flags->{'u_owner'} || $flags->{'u'};
1672    my $dbr = $dbs->{'reader'};
1673    my ($date, $sth);
1674
1675    # cluster differences
1676    my ($db, $table) = ($dbs->{'dbh'}, "syncupdates");
1677    ($db, $table) = (LJ::get_cluster_reader($uowner), "syncupdates2")
1678        if $uowner->{'clusterid'};
1679
1680    return fail($err,502) unless $db;
1681
1682    ## have a valid date?
1683    $date = $req->{'lastsync'};
1684    if ($date) {
1685        return fail($err,203,"Invalid date format")
1686            unless ($date =~ /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d/);
1687    } else {
1688        $date = "0000-00-00 00:00:00";
1689    }
1690
1691    my $LIMIT = 500;
1692
1693    my $total = $db->selectrow_array("SELECT COUNT(*) FROM $table WHERE ".
1694                                     "userid=$ownerid AND atime >= '$date'");
1695
1696    $sth = $db->prepare("SELECT atime, nodetype, nodeid, atype FROM ".
1697                        "$table WHERE userid=$ownerid AND ".
1698                        "atime >= '$date' ORDER BY atime LIMIT $LIMIT");
1699    $sth->execute;
1700    return fail($err,501,$db->errstr) if $db->err;
1701
1702    my $res = {};
1703    my $list = $res->{'syncitems'} = [];
1704    my $ct = 0;
1705    while (my ($atime, $nodetype, $nodeid, $atype) = $sth->fetchrow_array) {
1706        $ct++;
1707        push @$list, { 'item' => "$nodetype-$nodeid",
1708                       'action' => $atype,
1709                       'time' => $atime,
1710                   };
1711    }
1712    $res->{'count'} = $ct;
1713    $res->{'total'} = $total;
1714    return $res;
1715}
1716
1717sub consolecommand
1718{
1719    my ($dbs, $req, $err, $flags) = @_;
1720
1721    # TODO: LJ::Con doesn't yet support $dbs/$dbarg
1722    my $dbh = $dbs->{'dbh'};
1723    return fail($err,502) unless $dbh;
1724
1725    # logging in isn't necessary, but most console commands do require it
1726    my $remote = undef;
1727    $remote = $flags->{'u'} if authenticate($dbs, $req, $err, $flags);
1728
1729    my $res = {};
1730    my $cmdout = $res->{'results'} = [];
1731
1732    foreach my $cmd (@{$req->{'commands'}})
1733    {
1734        # callee can pre-parse the args, or we can do it bash-style
1735        $cmd = [ LJ::Con::parse_line($cmd) ] unless (ref $cmd eq "ARRAY");
1736
1737        my @output;
1738        my $rv = LJ::Con::execute($dbh, $remote, $cmd, \@output);
1739        push @{$cmdout}, {
1740            'success' => $rv,
1741            'output' => \@output,
1742        };
1743    }
1744
1745    return $res;
1746}
1747
1748sub login_message
1749{
1750    my ($dbs, $req, $res, $flags) = @_;
1751
1752    my $u = $flags->{'u'};
1753
1754    if ($u eq "test") {
1755        $res->{'message'} = "Hello Test Account!";
1756    }
1757    if ($req->{'clientversion'} =~ /^Win32-MFC\/(1.2.[0123456])$/ ||
1758        $req->{'clientversion'} =~ /^Win32-MFC\/(1.3.[01234])\b/)
1759    {
1760        $res->{'message'} = "There's a significantly newer version of LiveJournal for Windows available.";
1761    }
1762    unless ($LJ::EVERYONE_VALID)
1763    {
1764        if ($u->{'status'} eq "N") { $res->{'message'} = "You are currently not validated.  You may continue to use LiveJournal, but please validate your email address for continued use.  See the instructions that were mailed to you when you created your journal, or see $LJ::SITEROOT/support/ for more information."; }
1765        if ($u->{'status'} eq "T") { $res->{'message'} = "You need to validate your new email address.  Your old one was good, but since you've changed it, you need to re-validate the new one.  Visit the support area for more information."; }
1766    }
1767    if ($u->{'status'} eq "B") { $res->{'message'} = "You are currently using a bad email address.  All mail we try to send you is bouncing.  We require a valid email address for continued use.  Visit the support area for more information."; }
1768
1769    if (LJ::get_cap($u, "readonly")) {
1770        $res->{'message'} = "Your account is temporarily in read-only mode.  Some operations will fail for a few minutes.";
1771    }
1772
1773}
1774
1775sub list_friendgroups
1776{
1777    my $dbs = shift;
1778    my $u = shift;
1779
1780    my $res = [];
1781    my $dbr = $dbs->{'reader'};
1782
1783    my $sth = $dbr->prepare("SELECT groupnum, groupname, sortorder, is_public ".
1784                            "FROM friendgroup WHERE userid=$u->{'userid'} ".
1785                            "ORDER BY sortorder");
1786    $sth->execute;
1787    while (my ($gid, $name, $sort, $public) = $sth->fetchrow_array) {
1788        push @$res, { 'id' => $gid,
1789                      'name' => $name,
1790                      'sortorder' => $sort,
1791                      'public' => $public };
1792    }
1793    $sth->finish;
1794    return $res;
1795}
1796
1797sub list_usejournals
1798{
1799    my $dbs = shift;
1800    my $u = shift;
1801
1802    my $res = [];
1803
1804    my $dbr = $dbs->{'reader'};
1805    my $sth = $dbr->prepare("SELECT u.user FROM useridmap u, logaccess la ".
1806                            "WHERE la.ownerid=u.userid AND ".
1807                            "la.posterid=$u->{'userid'} ORDER BY u.user");
1808    $sth->execute;
1809    while (my $u = $sth->fetchrow_array) {
1810        push @$res, $u;
1811    }
1812    $sth->finish;
1813    return $res;
1814}
1815
1816sub hash_menus
1817{
1818    my $dbs = shift;
1819    my $u = shift;
1820    my $user = $u->{'user'};
1821
1822    my $menu = [
1823                { 'text' => "Recent Entries",
1824                  'url' => "$LJ::SITEROOT/users/$user/", },
1825                { 'text' => "Calendar View",
1826                  'url' => "$LJ::SITEROOT/users/$user/calendar", },
1827                { 'text' => "Friends View",
1828                  'url' => "$LJ::SITEROOT/users/$user/friends", },
1829                { 'text' => "-", },
1830                { 'text' => "Your Profile",
1831                  'url' => "$LJ::SITEROOT/userinfo.bml?user=$user", },
1832                { 'text' => "Your To-Do List",
1833                  'url' => "$LJ::SITEROOT/todo/?user=$user", },
1834                { 'text' => "-", },
1835                { 'text' => "Change Settings",
1836                  'sub' => [ { 'text' => "Personal Info",
1837                               'url' => "$LJ::SITEROOT/editinfo.bml", },
1838                             { 'text' => "Journal Settings",
1839                               'url' =>"$LJ::SITEROOT/modify.bml", }, ] },
1840                { 'text' => "-", },
1841                { 'text' => "Support",
1842                  'url' => "$LJ::SITEROOT/support/", }
1843                ];
1844
1845    LJ::run_hooks("modify_login_menu", {
1846        'dbs' => $dbs,
1847        'menu' => $menu,
1848        'u' => $u,
1849        'user' => $user,
1850    });
1851
1852    return $menu;
1853}
1854
1855sub list_pickws
1856{
1857    my $dbs = shift;
1858    my $u = shift;
1859
1860    my $dbr = $dbs->{'reader'};
1861    my $res = [];
1862
1863    my $sth = $dbr->prepare("SELECT k.keyword, m.picid FROM userpicmap m, keywords k ".
1864                            "WHERE m.userid=$u->{'userid'} AND m.kwid=k.kwid ".
1865                            "ORDER BY k.keyword");
1866    $sth->execute;
1867    while (my ($kw, $id) = $sth->fetchrow_array) {
1868        $kw =~ s/[\n\r\0]//g;  # used to be a bug that allowed these characters to get in.
1869        push @$res, [ $kw, $id ];
1870    }
1871    return $res;
1872}
1873
1874sub list_moods
1875{
1876    my $dbs = shift;
1877    my $mood_max = int(shift);
1878
1879    LJ::load_moods($dbs);
1880
1881    my $res = [];
1882    return $res unless ($mood_max < $LJ::CACHED_MOOD_MAX);
1883
1884    for (my $id = $mood_max+1; $id <= $LJ::CACHED_MOOD_MAX; $id++) {
1885        next unless defined $LJ::CACHE_MOODS{$id};
1886        my $mood = $LJ::CACHE_MOODS{$id};
1887        push @$res, { 'id' => $id,
1888                      'name' => $mood->{'name'},
1889                      'parent' => $mood->{'parent'} };
1890    }
1891
1892    return $res;
1893}
1894
1895sub check_altusage
1896{
1897    my ($dbs, $req, $err, $flags) = @_;
1898
1899    # see note in ljlib.pl::can_use_journal about why we return
1900    # both 'ownerid' and 'u_owner' in $flags
1901
1902    my $alt = $req->{'usejournal'};
1903    my $u = $flags->{'u'};
1904    $flags->{'ownerid'} = $u->{'userid'};
1905
1906    # all good if not using an alt journal
1907    return 1 unless $alt;
1908
1909    # complain if the username is invalid
1910    return fail($err,206) unless LJ::canonical_username($alt);
1911
1912    # allow usage if we're told explicitly that it's okay
1913    if ($flags->{'usejournal_okay'}) {
1914        $flags->{'u_owner'} = LJ::load_user($dbs, $alt);
1915        $flags->{'ownerid'} = $flags->{'u_owner'}->{'userid'};
1916        return 1 if $flags->{'ownerid'};
1917        return fail($err,206);
1918    }
1919
1920    # otherwise, check logaccess table:
1921    my $info = {};
1922    if (LJ::can_use_journal($dbs, $u->{'userid'}, $req->{'usejournal'}, $info)) {
1923        $flags->{'ownerid'} = $info->{'ownerid'};
1924        $flags->{'u_owner'} = $info->{'u_owner'};
1925        return 1;
1926    }
1927
1928    # not allowed to access it
1929    return fail($err,300);
1930}
1931
1932sub authenticate
1933{
1934    my ($dbs, $req, $err, $flags) = @_;
1935
1936    my $username = $req->{'username'};
1937    return fail($err,200) unless $username;
1938    return fail($err,100) unless LJ::canonical_username($username);
1939
1940    my $u = $flags->{'u'};
1941    unless ($u) {
1942        my $dbr = $dbs->{'reader'};
1943        return fail($err,502) unless $dbr;
1944        my $quser = $dbr->quote($username);
1945        my $other = $LJ::UNICODE ? ", oldenc" : "";
1946        my $sth = $dbr->prepare("SELECT user, userid, journaltype, name, ".
1947                                "password, status, statusvis, caps, ".
1948                                "clusterid, dversion, ".
1949                                "track $other FROM user WHERE user=$quser");
1950        $sth->execute;
1951        return fail($err,501,$dbr->errstr) if $dbr->err;
1952        $u = $sth->fetchrow_hashref;
1953    }
1954
1955    return fail($err,100) unless $u;
1956    return fail($err,100) if ($u->{'statusvis'} eq "X");
1957    return fail($err,101) unless ($flags->{'nopassword'} ||
1958                                  $flags->{'noauth'} ||
1959                                    LJ::auth_okay($username,
1960                                                $req->{'password'},
1961                                                $req->{'hpassword'},
1962                                                $u->{'password'}));
1963    # remember the user record for later.
1964    $flags->{'u'} = $u;
1965    return 1;
1966}
1967
1968sub fail
1969{
1970    my $err = shift;
1971    my $code = shift;
1972    my $des = shift;
1973    $code .= ":$des" if $des;
1974    $$err = $code if (ref $err eq "SCALAR");
1975    return undef;
1976}
1977
1978#### Old interface (flat key/values) -- wrapper aruond LJ::Protocol
1979package LJ;
1980
1981sub do_request
1982{
1983    # get the request and response hash refs
1984    my ($db_arg, $req, $res, $flags) = @_;
1985
1986    # initialize some stuff
1987    my $dbs = LJ::make_dbs_from_arg($db_arg);
1988    my $dbh = $dbs->{'dbh'};
1989    my $dbr = $dbs->{'reader'};
1990    %{$res} = ();                      # clear the given response hash
1991    $flags = {} unless (ref $flags eq "HASH");
1992
1993    my ($user, $userid, $journaltype, $name, $correctpassword, $status, $statusvis, $track, $sth);
1994    $user = LJ::canonical_username($req->{'user'});
1995    my $quser = $dbh->quote($user);
1996
1997    # check for an alive database connection
1998    unless ($dbh) {
1999        $res->{'success'} = "FAIL";
2000        $res->{'errmsg'} = "Server error: cannot connect to database.";
2001        return;
2002    }
2003
2004    # did they send a mode?
2005    unless ($req->{'mode'}) {
2006        $res->{'success'} = "FAIL";
2007        $res->{'errmsg'} = "Client error: No mode specified.";
2008        return;
2009    }
2010
2011    unless ($user) {
2012        $res->{'success'} = "FAIL";
2013        $res->{'errmsg'} = "Client error: No username sent.";
2014        return;
2015    }
2016
2017    ### see if the server's under maintenance now
2018    if ($LJ::SERVER_DOWN) {
2019        $res->{'success'} = "FAIL";
2020        $res->{'errmsg'} = $LJ::SERVER_DOWN_MESSAGE;
2021        return;
2022    }
2023
2024    ## dispatch wrappers
2025    if ($req->{'mode'} eq "login") {
2026        return login($dbs, $req, $res, $flags);
2027    }
2028    if ($req->{'mode'} eq "getfriendgroups") {
2029        return getfriendgroups($dbs, $req, $res, $flags);
2030    }
2031    if ($req->{'mode'} eq "getfriends") {
2032        return getfriends($dbs, $req, $res, $flags);
2033    }
2034    if ($req->{'mode'} eq "friendof") {
2035        return friendof($dbs, $req, $res, $flags);
2036    }
2037    if ($req->{'mode'} eq "checkfriends") {
2038        return checkfriends($dbs, $req, $res, $flags);
2039    }
2040    if ($req->{'mode'} eq "getdaycounts") {
2041        return getdaycounts($dbs, $req, $res, $flags);
2042    }
2043    if ($req->{'mode'} eq "postevent") {
2044        return postevent($dbs, $req, $res, $flags);
2045    }
2046    if ($req->{'mode'} eq "editevent") {
2047        return editevent($dbs, $req, $res, $flags);
2048    }
2049    if ($req->{'mode'} eq "syncitems") {
2050        return syncitems($dbs, $req, $res, $flags);
2051    }
2052    if ($req->{'mode'} eq "getevents") {
2053        return getevents($dbs, $req, $res, $flags);
2054    }
2055    if ($req->{'mode'} eq "editfriends") {
2056        return editfriends($dbs, $req, $res, $flags);
2057    }
2058    if ($req->{'mode'} eq "editfriendgroups") {
2059        return editfriendgroups($dbs, $req, $res, $flags);
2060    }
2061    if ($req->{'mode'} eq "consolecommand") {
2062        return consolecommand($dbs, $req, $res, $flags);
2063    }
2064
2065    ### unknown mode!
2066    $res->{'success'} = "FAIL";
2067    $res->{'errmsg'} = "Client error: Unknown mode ($req->{'mode'})";
2068    return;
2069}
2070
2071## flat wrapper
2072sub login
2073{
2074    my ($dbs, $req, $res, $flags) = @_;
2075
2076    my $err = 0;
2077    my $rq = upgrade_request($req);
2078
2079    my $rs = LJ::Protocol::do_request($dbs, "login", $rq, \$err, $flags);
2080    unless ($rs) {
2081        $res->{'success'} = "FAIL";
2082        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2083        return 0;
2084    }
2085
2086    $res->{'success'} = "OK";
2087    $res->{'name'} = $rs->{'fullname'};
2088    $res->{'message'} = $rs->{'message'} if $rs->{'message'};
2089    $res->{'fastserver'} = 1 if $rs->{'fastserver'};
2090
2091    # shared journals
2092    my $access_count = 0;
2093    foreach my $user (@{$rs->{'usejournals'}}) {
2094        $access_count++;
2095        $res->{"access_${access_count}"} = $user;
2096    }
2097    if ($access_count) {
2098        $res->{"access_count"} = $access_count;
2099    }
2100
2101    # friend groups
2102    populate_friend_groups($res, $rs->{'friendgroups'});
2103
2104    my $flatten = sub {
2105        my ($prefix, $listref) = @_;
2106        my $ct = 0;
2107        foreach (@$listref) {
2108            $ct++;
2109            $res->{"${prefix}_$ct"} = $_;
2110        }
2111        $res->{"${prefix}_count"} = $ct;
2112    };
2113
2114    ### picture keywords
2115    $flatten->("pickw", $rs->{'pickws'})
2116        if defined $req->{"getpickws"};
2117    $flatten->("pickwurl", $rs->{'pickwurls'})
2118        if defined $req->{"getpickwurls"};
2119
2120    ### report new moods that this client hasn't heard of, if they care
2121    if (defined $req->{"getmoods"}) {
2122        my $mood_count = 0;
2123        foreach my $m (@{$rs->{'moods'}}) {
2124            $mood_count++;
2125            $res->{"mood_${mood_count}_id"} = $m->{'id'};
2126            $res->{"mood_${mood_count}_name"} = $m->{'name'};
2127        }
2128        if ($mood_count) {
2129            $res->{"mood_count"} = $mood_count;
2130        }
2131    }
2132
2133    #### send web menus
2134    if ($req->{"getmenus"} == 1) {
2135        my $menu = $rs->{'menus'};
2136        my $menu_num = 0;
2137        populate_web_menu($res, $menu, \$menu_num);
2138    }
2139
2140    return 1;
2141}
2142
2143## flat wrapper
2144sub getfriendgroups
2145{
2146    my ($dbs, $req, $res, $flags) = @_;
2147
2148    my $err = 0;
2149    my $rq = upgrade_request($req);
2150
2151    my $rs = LJ::Protocol::do_request($dbs, "getfriendgroups", $rq, \$err, $flags);
2152    unless ($rs) {
2153        $res->{'success'} = "FAIL";
2154        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2155        return 0;
2156    }
2157    $res->{'success'} = "OK";
2158    populate_friend_groups($res, $rs->{'friendgroups'});
2159
2160    return 1;
2161}
2162
2163## flat wrapper
2164sub getfriends
2165{
2166    my ($dbs, $req, $res, $flags) = @_;
2167
2168    my $err = 0;
2169    my $rq = upgrade_request($req);
2170
2171    my $rs = LJ::Protocol::do_request($dbs, "getfriends", $rq, \$err, $flags);
2172    unless ($rs) {
2173        $res->{'success'} = "FAIL";
2174        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2175        return 0;
2176    }
2177
2178    $res->{'success'} = "OK";
2179    if ($req->{'includegroups'}) {
2180        populate_friend_groups($res, $rs->{'friendgroups'});
2181    }
2182    if ($req->{'includefriendof'}) {
2183        populate_friends($res, "friendof", $rs->{'friendofs'});
2184    }
2185    populate_friends($res, "friend", $rs->{'friends'});
2186
2187    return 1;
2188}
2189
2190## flat wrapper
2191sub friendof
2192{
2193    my ($dbs, $req, $res, $flags) = @_;
2194
2195    my $err = 0;
2196    my $rq = upgrade_request($req);
2197
2198    my $rs = LJ::Protocol::do_request($dbs, "friendof", $rq, \$err, $flags);
2199    unless ($rs) {
2200        $res->{'success'} = "FAIL";
2201        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2202        return 0;
2203    }
2204
2205    $res->{'success'} = "OK";
2206    populate_friends($res, "friendof", $rs->{'friendofs'});
2207    return 1;
2208}
2209
2210## flat wrapper
2211sub checkfriends
2212{
2213    my ($dbs, $req, $res, $flags) = @_;
2214
2215    my $err = 0;
2216    my $rq = upgrade_request($req);
2217
2218    my $rs = LJ::Protocol::do_request($dbs, "checkfriends", $rq, \$err, $flags);
2219    unless ($rs) {
2220        $res->{'success'} = "FAIL";
2221        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2222        return 0;
2223    }
2224
2225    $res->{'success'} = "OK";
2226    $res->{'new'} = $rs->{'new'};
2227    $res->{'lastupdate'} = $rs->{'lastupdate'};
2228    $res->{'interval'} = $rs->{'interval'};
2229    return 1;
2230}
2231
2232## flat wrapper
2233sub getdaycounts
2234{
2235    my ($dbs, $req, $res, $flags) = @_;
2236
2237    my $err = 0;
2238    my $rq = upgrade_request($req);
2239
2240    my $rs = LJ::Protocol::do_request($dbs, "getdaycounts", $rq, \$err, $flags);
2241    unless ($rs) {
2242        $res->{'success'} = "FAIL";
2243        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2244        return 0;
2245    }
2246
2247    $res->{'success'} = "OK";
2248    foreach my $d (@{ $rs->{'daycounts'} }) {
2249        $res->{$d->{'date'}} = $d->{'count'};
2250    }
2251    return 1;
2252}
2253
2254## flat wrapper
2255sub syncitems
2256{
2257    my ($dbs, $req, $res, $flags) = @_;
2258
2259    my $err = 0;
2260    my $rq = upgrade_request($req);
2261
2262    my $rs = LJ::Protocol::do_request($dbs, "syncitems", $rq, \$err, $flags);
2263    unless ($rs) {
2264        $res->{'success'} = "FAIL";
2265        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2266        return 0;
2267    }
2268
2269    $res->{'success'} = "OK";
2270    $res->{'sync_total'} = $rs->{'total'};
2271    $res->{'sync_count'} = $rs->{'count'};
2272
2273    my $ct = 0;
2274    foreach my $s (@{ $rs->{'syncitems'} }) {
2275        $ct++;
2276        foreach my $a (qw(item action time)) {
2277            $res->{"sync_${ct}_$a"} = $s->{$a};
2278        }
2279    }
2280    return 1;
2281}
2282
2283## flat wrapper: limited functionality.  (1 command only, server-parsed only)
2284sub consolecommand
2285{
2286    my ($dbs, $req, $res, $flags) = @_;
2287
2288    my $err = 0;
2289    my $rq = upgrade_request($req);
2290    delete $rq->{'command'};
2291
2292    $rq->{'commands'} = [ $req->{'command'} ];
2293
2294    my $rs = LJ::Protocol::do_request($dbs, "consolecommand", $rq, \$err, $flags);
2295    unless ($rs) {
2296        $res->{'success'} = "FAIL";
2297        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2298        return 0;
2299    }
2300
2301    $res->{'cmd_success'} = $rs->{'results'}->[0]->{'success'};
2302    $res->{'cmd_line_count'} = 0;
2303    foreach my $l (@{$rs->{'results'}->[0]->{'output'}}) {
2304        $res->{'cmd_line_count'}++;
2305        my $line = $res->{'cmd_line_count'};
2306        $res->{"cmd_line_${line}_type"} = $l->[0]
2307            if $l->[0];
2308        $res->{"cmd_line_${line}"} = $l->[1];
2309    }
2310
2311    $res->{'success'} = "OK";
2312
2313}
2314
2315## flat wrapper
2316sub editfriends
2317{
2318    my ($dbs, $req, $res, $flags) = @_;
2319
2320    my $err = 0;
2321    my $rq = upgrade_request($req);
2322
2323    $rq->{'add'} = [];
2324    $rq->{'delete'} = [];
2325
2326    foreach (keys %$req) {
2327        if (/^editfriend_add_(\d+)_user$/) {
2328            my $n = $1;
2329            next unless ($req->{"editfriend_add_${n}_user"} =~ /\S/);
2330            my $fa = { 'username' => $req->{"editfriend_add_${n}_user"},
2331                       'fgcolor' => $req->{"editfriend_add_${n}_fg"},
2332                       'bgcolor' => $req->{"editfriend_add_${n}_bg"},
2333                       'groupmask' => $req->{"editfriend_add_${n}_groupmask"},
2334                   };
2335            push @{$rq->{'add'}}, $fa;
2336        } elsif (/^editfriend_delete_(\w+)$/) {
2337            push @{$rq->{'delete'}}, $1;
2338        }
2339    }
2340
2341    my $rs = LJ::Protocol::do_request($dbs, "editfriends", $rq, \$err, $flags);
2342    unless ($rs) {
2343        $res->{'success'} = "FAIL";
2344        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2345        return 0;
2346    }
2347
2348    $res->{'success'} = "OK";
2349
2350    my $ct = 0;
2351    foreach my $fa (@{ $rs->{'added'} }) {
2352        $ct++;
2353        $res->{"friend_${ct}_user"} = $fa->{'username'};
2354        $res->{"friend_${ct}_name"} = $fa->{'fullname'};
2355    }
2356
2357    $res->{'friends_added'} = $ct;
2358
2359    return 1;
2360}
2361
2362## flat wrapper
2363sub editfriendgroups
2364{
2365    my ($dbs, $req, $res, $flags) = @_;
2366
2367    my $err = 0;
2368    my $rq = upgrade_request($req);
2369
2370    $rq->{'groupmasks'} = {};
2371    $rq->{'set'} = {};
2372    $rq->{'delete'} = [];
2373
2374    foreach (keys %$req) {
2375        if (/^efg_set_(\d+)_name$/) {
2376            next unless ($req->{$_} ne "");
2377            my $n = $1;
2378            my $fs = {
2379                'name' => $req->{"efg_set_${n}_name"},
2380                'sort' => $req->{"efg_set_${n}_sort"},
2381            };
2382            if (defined $req->{"efg_set_${n}_public"}) {
2383                $fs->{'public'} = $req->{"efg_set_${n}_public"};
2384            }
2385            $rq->{'set'}->{$n} = $fs;
2386        }
2387        elsif (/^efg_delete_(\d+)$/) {
2388            if ($req->{$_}) {
2389                # delete group if value is true
2390                push @{$rq->{'delete'}}, $1;
2391            }
2392        }
2393        elsif (/^editfriend_groupmask_(\w+)$/) {
2394            $rq->{'groupmasks'}->{$1} = $req->{$_};
2395        }
2396    }
2397
2398    my $rs = LJ::Protocol::do_request($dbs, "editfriendgroups", $rq, \$err, $flags);
2399    unless ($rs) {
2400        $res->{'success'} = "FAIL";
2401        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2402        return 0;
2403    }
2404
2405    $res->{'success'} = "OK";
2406    return 1;
2407}
2408
2409sub flatten_props
2410{
2411    my ($req, $rq) = @_;
2412
2413    ## changes prop_* to props hashref
2414    foreach my $k (keys %$req) {
2415        next unless ($k =~ /^prop_(.+)/);
2416        $rq->{'props'}->{$1} = $req->{$k};
2417    }
2418}
2419
2420## flat wrapper
2421sub postevent
2422{
2423    my ($dbs, $req, $res, $flags) = @_;
2424
2425    my $err = 0;
2426    my $rq = upgrade_request($req);
2427    flatten_props($req, $rq);
2428
2429    my $rs = LJ::Protocol::do_request($dbs, "postevent", $rq, \$err, $flags);
2430    unless ($rs) {
2431        $res->{'success'} = "FAIL";
2432        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2433        return 0;
2434    }
2435
2436    $res->{'success'} = "OK";
2437    $res->{'itemid'} = $rs->{'itemid'};
2438    $res->{'anum'} = $rs->{'anum'} if defined $rs->{'anum'};
2439    return 1;
2440}
2441
2442## flat wrapper
2443sub editevent
2444{
2445    my ($dbs, $req, $res, $flags) = @_;
2446
2447    my $err = 0;
2448    my $rq = upgrade_request($req);
2449    flatten_props($req, $rq);
2450
2451    my $rs = LJ::Protocol::do_request($dbs, "editevent", $rq, \$err, $flags);
2452    unless ($rs) {
2453        $res->{'success'} = "FAIL";
2454        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2455        return 0;
2456    }
2457
2458    $res->{'success'} = "OK";
2459    $res->{'itemid'} = $rs->{'itemid'};
2460    $res->{'anum'} = $rs->{'anum'} if defined $rs->{'anum'};
2461    return 1;
2462}
2463
2464## flat wrapper
2465sub getevents
2466{
2467    my ($dbs, $req, $res, $flags) = @_;
2468
2469    my $err = 0;
2470    my $rq = upgrade_request($req);
2471
2472    my $rs = LJ::Protocol::do_request($dbs, "getevents", $rq, \$err, $flags);
2473    unless ($rs) {
2474        $res->{'success'} = "FAIL";
2475        $res->{'errmsg'} = LJ::Protocol::error_message($err);
2476        return 0;
2477    }
2478
2479    my $ect = 0;
2480    my $pct = 0;
2481    foreach my $evt (@{$rs->{'events'}}) {
2482        $ect++;
2483        foreach my $f (qw(itemid eventtime security allowmask subject anum)) {
2484            if (defined $evt->{$f}) {
2485                $res->{"events_${ect}_$f"} = $evt->{$f};
2486            }
2487        }
2488        $res->{"events_${ect}_event"} = LJ::eurl($evt->{'event'});
2489
2490        if ($evt->{'props'}) {
2491            foreach my $k (sort keys %{$evt->{'props'}}) {
2492                $pct++;
2493                $res->{"prop_${pct}_itemid"} = $evt->{'itemid'};
2494                $res->{"prop_${pct}_name"} = $k;
2495                $res->{"prop_${pct}_value"} = $evt->{'props'}->{$k};
2496            }
2497        }
2498    }
2499
2500    unless ($req->{'noprops'}) {
2501        $res->{'prop_count'} = $pct;
2502    }
2503    $res->{'events_count'} = $ect;
2504    $res->{'success'} = "OK";
2505
2506    return 1;
2507}
2508
2509
2510sub populate_friends
2511{
2512    my ($res, $pfx, $list) = @_;
2513    my $count = 0;
2514    foreach my $f (@$list)
2515    {
2516        $count++;
2517        $res->{"${pfx}_${count}_name"} = $f->{'fullname'};
2518        $res->{"${pfx}_${count}_user"} = $f->{'username'};
2519        $res->{"${pfx}_${count}_bg"} = $f->{'bgcolor'};
2520        $res->{"${pfx}_${count}_fg"} = $f->{'fgcolor'};
2521        if (defined $f->{'groupmask'}) {
2522            $res->{"${pfx}_${count}_groupmask"} = $f->{'groupmask'};
2523        }
2524        if (defined $f->{'type'}) {
2525            $res->{"${pfx}_${count}_type"} = $f->{'type'};
2526        }
2527    }
2528    $res->{"${pfx}_count"} = $count;
2529}
2530
2531
2532sub upgrade_request
2533{
2534    my $r = shift;
2535    my $new = { %{ $r } };
2536    $new->{'username'} = $r->{'user'};
2537
2538    # but don't delete $r->{'user'}, as it might be, say, %FORM,
2539    # that'll get reused in a later request in, say, update.bml after
2540    # the login before postevent.  whoops.
2541
2542    return $new;
2543}
2544
2545## given a $res hashref and friend group subtree (arrayref), flattens it
2546sub populate_friend_groups
2547{
2548    my ($res, $fr) = @_;
2549
2550    my $maxnum = 0;
2551    foreach my $fg (@$fr)
2552    {
2553        my $num = $fg->{'id'};
2554        $res->{"frgrp_${num}_name"} = $fg->{'name'};
2555        $res->{"frgrp_${num}_sortorder"} = $fg->{'sortorder'};
2556        if ($fg->{'public'}) {
2557            $res->{"frgrp_${num}_public"} = 1;
2558        }
2559        if ($num > $maxnum) { $maxnum = $num; }
2560    }
2561    $res->{'frgrp_maxnum'} = $maxnum;
2562}
2563
2564## given a menu tree, flattens it into $res hashref
2565sub populate_web_menu
2566{
2567    my ($res, $menu, $numref) = @_;
2568    my $mn = $$numref;  # menu number
2569    my $mi = 0;         # menu item
2570    foreach my $it (@$menu) {
2571        $mi++;
2572        $res->{"menu_${mn}_${mi}_text"} = $it->{'text'};
2573        if ($it->{'text'} eq "-") { next; }
2574        if ($it->{'sub'}) {
2575            $$numref++;
2576            $res->{"menu_${mn}_${mi}_sub"} = $$numref;
2577            &populate_web_menu($res, $it->{'sub'}, $numref);
2578            next;
2579
2580        }
2581        $res->{"menu_${mn}_${mi}_url"} = $it->{'url'};
2582    }
2583    $res->{"menu_${mn}_count"} = $mi;
2584}
2585
25861;
Note: See TracBrowser for help on using the browser.