source: perl/lib/BarnOwl/Message/Zephyr.pm @ dca6255

Last change on this file since dca6255 was dca6255, checked in by Jason Gross <jgross@mit.edu>, 8 years ago
Moved log file name generation to perl I don't think that the class/personal distinction is the best for general protocols, but I don't know what should replace it. I've made class-logging default to only zephyr (a slight change from previous behavior, where jabber MUC's would be logged to $classlogpath, as well as all non-private non-login messages from other protocols), but made logging path generation overridable. TODO: Decide whether or not to filter out more 'bad' characters. Perhaps we should remove '!' because it indicates history in some shells and makes things obnoxious, or '~' becase it indicates homedirs in many shells. * '/' is for separating directories, and we don't want to accidentally make subdirectories We first NFKC for zephyrs, and then apply lc. The zephyr servers apply case-folded NFKC (so says http://zephyr.1ts.org/browser/zephyr/server/zstring.c). We should probably use Unicode::CaseFold instead of lc. I'm also not sure what the order case-adjustment and normalization should be. We first NFKC, then apply lc, to jabbers, as per http://xmpp.org/internet-drafts/attic/draft-ietf-xmpp-nodeprep-03.html (though I can't actually find anything that specifies the case-folding algorithm, nor the ordering). We now use lc instead of g_utf8_strdown to normalize AIM screennames.
  • Property mode set to 100644
File size: 7.0 KB
Line 
1use strict;
2use warnings;
3
4package BarnOwl::Message::Zephyr;
5
6use constant WEBZEPHYR_PRINCIPAL => "daemon/webzephyr.mit.edu";
7use constant WEBZEPHYR_CLASS     => "webzephyr";
8use constant WEBZEPHYR_OPCODE    => "webzephyr";
9
10use base qw( BarnOwl::Message );
11use Unicode::Normalize qw( NFKC );
12
13sub strip_realm {
14    my $sender = shift;
15    my $realm = BarnOwl::zephyr_getrealm();
16    $sender =~ s/\@\Q$realm\E$//;
17    return $sender;
18}
19
20sub principal_realm {
21    my $principal = shift;
22    my ($user, $realm) = split(/@/,$principal);
23    return $realm;
24}
25
26sub login_type {
27    return (shift->zsig eq "") ? "(PSEUDO)" : "";
28}
29
30sub login_extra {
31    my $m = shift;
32    return undef if (!$m->is_loginout);
33    my $s = lc($m->host);
34    $s .= " " . $m->login_tty if defined $m->login_tty;
35    return $s;
36}
37
38sub long_sender {
39    my $m = shift;
40    return $m->zsig;
41}
42
43sub context {
44    return shift->class;
45}
46
47sub subcontext {
48    return shift->instance;
49}
50
51sub login_tty {
52    my ($m) = @_;
53    return undef if (!$m->is_loginout);
54    return undef if (!defined($m->fields));
55    return $m->fields->[2];
56}
57
58sub login_host {
59    my ($m) = @_;
60    return undef if (!$m->is_loginout);
61    return undef if (!defined($m->fields));
62    return $m->fields->[0];
63}
64
65sub zwriteline  { return shift->{"zwriteline"}; }
66
67sub is_ping     { return (lc(shift->opcode) eq "ping"); }
68
69sub is_mail {
70    my ($m) = @_;
71    return ((lc($m->class) eq "mail") && $m->is_private);
72}
73
74sub pretty_sender {
75    my ($m) = @_;
76    return strip_realm($m->sender);
77}
78
79sub pretty_recipient {
80    my ($m) = @_;
81    return strip_realm($m->recipient);
82}
83
84# Portion of the reply command that preserves the context
85sub context_reply_cmd {
86    my $mclass = shift;
87    my $minstance = shift;
88    my @class;
89    if (lc($mclass) ne "message") {
90        @class = ('-c', $mclass);
91    }
92    my @instance;
93    if (lc($minstance) ne "personal") {
94        @instance = ('-i', $minstance);
95    }
96    return (@class, @instance);
97}
98
99sub personal_context {
100    my ($m) = @_;
101    return BarnOwl::quote(context_reply_cmd($m->class, $m->instance));
102}
103
104sub short_personal_context {
105    my ($m) = @_;
106    if(lc($m->class) eq 'message')
107    {
108        if(lc($m->instance) eq 'personal')
109        {
110            return '';
111        } else {
112            return $m->instance;
113        }
114    } else {
115        return $m->class;
116    }
117}
118
119# These are arguably zephyr-specific
120sub class       { return shift->{"class"}; }
121sub instance    { return shift->{"instance"}; }
122sub realm       { return shift->{"realm"}; }
123sub opcode      { return shift->{"opcode"}; }
124sub host        { return shift->{"hostname"}; }
125sub hostname    { return shift->{"hostname"}; }
126sub header      { return shift->{"header"}; }
127sub auth        { return shift->{"auth"}; }
128sub fields      { return shift->{"fields"}; }
129sub zsig        { return shift->{"zsig"}; }
130
131sub zephyr_cc {
132    my $self = shift;
133    return $1 if $self->body =~ /^\s*cc:\s+([^\n]+)/i;
134    return undef;
135}
136
137sub zephyr_cc_without_recipient {
138    my $self = shift;
139    my $recipient = lc(strip_realm($self->recipient));
140    my $cc = $self->zephyr_cc;
141    return grep { lc(strip_realm($_)) ne $recipient } split(/\s+/, $cc) if defined $cc;
142    return ();
143}
144
145sub replycmd {
146    my $self = shift;
147    my $sender = shift;
148    $sender = 0 unless defined $sender;
149    my ($class, $instance, $to, $cc);
150    if($self->is_outgoing) {
151        return $self->{zwriteline};
152    }
153
154    if($sender && $self->opcode eq WEBZEPHYR_OPCODE) {
155        $class = WEBZEPHYR_CLASS;
156        $instance = $self->pretty_sender;
157        $instance =~ s/-webzephyr$//;
158        $to = WEBZEPHYR_PRINCIPAL;
159    } elsif($self->class eq WEBZEPHYR_CLASS
160            && $self->is_loginout) {
161        $class = WEBZEPHYR_CLASS;
162        $instance = $self->instance;
163        $to = WEBZEPHYR_PRINCIPAL;
164    } elsif($self->is_loginout) {
165        $class = 'MESSAGE';
166        $instance = 'PERSONAL';
167        $to = $self->sender;
168    } elsif($sender && !$self->is_private) {
169        # Possible future feature: (Optionally?) include the class and/or
170        # instance of the message being replied to in the instance of the
171        # outgoing personal reply
172        $class = 'MESSAGE';
173        $instance = 'PERSONAL';
174        $to = $self->sender;
175    } else {
176        $class = $self->class;
177        $instance = $self->instance;
178        if ($self->recipient eq '' || $self->recipient =~ /^@/) {
179            $to = $self->recipient;
180        } else {
181            $to = $self->sender;
182            $cc = $self->zephyr_cc();
183        }
184    }
185
186    my @cmd;
187    if(lc $self->opcode eq 'crypt' and ( not $sender or $self->is_private)) {
188        # Responses to zcrypted messages should be zcrypted, so long as we
189        # aren't switching to personals
190        @cmd = ('zcrypt');
191    } else {
192        @cmd = ('zwrite');
193    }
194
195    push @cmd, context_reply_cmd($class, $instance);
196
197    if ($to ne '') {
198        $to = strip_realm($to);
199        if (defined $cc and not $sender) {
200            my @cc = grep /^[^-]/, ($to, split /\s+/, $cc);
201            my %cc = map {$_ => 1} @cc;
202            # this isn't quite right - it doesn't strip off the
203            # user if the message was addressed to them by fully qualified
204            # name
205            delete $cc{strip_realm(BarnOwl::zephyr_getsender())};
206            @cc = keys %cc;
207
208            my $sender_realm = principal_realm($self->sender);
209            if (BarnOwl::zephyr_getrealm() ne $sender_realm) {
210                @cc = map {
211                    if($_ !~ /@/) {
212                       "${_}\@${sender_realm}";
213                    } else {
214                        $_;
215                    }
216                } @cc;
217            }
218            push @cmd, '-C', @cc;
219        } else {
220            if(BarnOwl::getvar('smartstrip') eq 'on') {
221                $to = BarnOwl::zephyr_smartstrip_user($to);
222            }
223            push @cmd, $to;
224        }
225    }
226    return BarnOwl::quote(@cmd);
227}
228
229sub replysendercmd {
230    my $self = shift;
231    return $self->replycmd(1);
232}
233
234# Logging
235sub log_header {
236    my ($m) = @_;
237    my $class = $m->class;
238    my $instance = $m->instance;
239    my $opcode = $m->opcode;
240    my $timestr = $m->time;
241    my $host = $m->host;
242    my $sender = $m->pretty_sender;
243    my $zsig = $m->zsig;
244    my $rtn = "Class: $class Instance: $instance";
245    $rtn .= " Opcode: $opcode" unless !defined $opcode || $opcode eq '';
246    $rtn .= "\nTime: $timestr Host: $host"
247          . "\nFrom: $zsig <$sender>";
248    return $rtn;
249}
250
251sub log_filenames {
252    my ($m) = @_;
253    my @filenames = ();
254    if ($m->is_personal) {
255        @filenames = $m->zephyr_cc_without_recipient;
256    }
257    if ($m->is_incoming) {
258        if ($m->is_personal) {
259            push @filenames, $m->sender;
260        } else {
261            return (lc(NFKC($m->class)));
262        }
263    } else {
264        push @filenames, $m->recipient;
265    }
266    return map { lc(NFKC(strip_realm($_))) } @filenames;
267}
268
269sub log_to_class_file {
270    my ($m) = @_;
271    return !$m->is_personal;
272}
273
274sub log_base_path {
275    my ($m) = @_;
276    if ($m->log_to_class_file) {
277        return BarnOwl::getvar('classlogpath');
278    } else {
279        return BarnOwl::getvar('logpath');
280    }
281}
282
2831;
Note: See TracBrowser for help on using the repository browser.